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_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Ghost; use Ghost;
47 with Lib.Writ; use Lib.Writ;
48 with Lib.Xref; use Lib.Xref;
49 with Namet.Sp; use Namet.Sp;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
52 with Output; use Output;
53 with Par_SCO; use Par_SCO;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch12; use Sem_Ch12;
63 with Sem_Ch13; use Sem_Ch13;
64 with Sem_Disp; use Sem_Disp;
65 with Sem_Dist; use Sem_Dist;
66 with Sem_Elim; use Sem_Elim;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Intr; use Sem_Intr;
69 with Sem_Mech; use Sem_Mech;
70 with Sem_Res; use Sem_Res;
71 with Sem_Type; use Sem_Type;
72 with Sem_Util; use Sem_Util;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all lower case letters.
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 procedure Analyze_Part_Of
181 Encap_Id : out Entity_Id;
182 Legal : out Boolean);
183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
186 -- package instantiation. Encap denotes the encapsulating state or single
187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
188 -- the indicator is legal.
190 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
192 -- Query whether a particular item appears in a mixed list of nodes and
193 -- entities. It is assumed that all nodes in the list have entities.
195 procedure Check_Postcondition_Use_In_Inlined_Subprogram
197 Spec_Id : Entity_Id);
198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
202 procedure Check_State_And_Constituent_Use
206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
207 -- Global and Initializes. Determine whether a state from list States and a
208 -- corresponding constituent from list Constits (if any) appear in the same
209 -- context denoted by Context. If this is the case, emit an error.
211 procedure Contract_Freeze_Error
212 (Contract_Id : Entity_Id;
213 Freeze_Id : Entity_Id);
214 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
215 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
216 -- of a body which caused contract "freezing" and Contract_Id denotes the
217 -- entity of the affected contstruct.
219 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
220 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
221 -- Prag that duplicates previous pragma Prev.
223 function Find_Related_Context
225 Do_Checks : Boolean := False) return Node_Id;
226 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
227 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
228 -- Part_Of. Find the first source declaration or statement found while
229 -- traversing the previous node chain starting from pragma Prag. If flag
230 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
231 -- returns Empty when reaching the start of the node chain.
233 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
234 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
235 -- original one, following the renaming chain) is returned. Otherwise the
236 -- entity is returned unchanged. Should be in Einfo???
238 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
239 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
240 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
241 -- value of type SPARK_Mode_Type.
243 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
244 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
245 -- Determine whether dependency clause Clause is surrounded by extra
246 -- parentheses. If this is the case, issue an error message.
248 function Is_CCT_Instance
250 Context_Id : Entity_Id) return Boolean;
251 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
252 -- Global. Determine whether entity Ref_Id denotes the current instance of
253 -- a concurrent type. Context_Id denotes the associated context where the
256 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
257 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
258 -- pragma Depends. Determine whether the type of dependency item Item is
259 -- tagged, unconstrained array, unconstrained record or a record with at
260 -- least one unconstrained component.
262 procedure Record_Possible_Body_Reference
263 (State_Id : Entity_Id;
265 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
266 -- Global. Given an abstract state denoted by State_Id and a reference Ref
267 -- to it, determine whether the reference appears in a package body that
268 -- will eventually refine the state. If this is the case, record the
269 -- reference for future checks (see Analyze_Refined_State_In_Decls).
271 procedure Resolve_State (N : Node_Id);
272 -- Handle the overloading of state names by functions. When N denotes a
273 -- function, this routine finds the corresponding state and sets the entity
274 -- of N to that of the state.
276 procedure Rewrite_Assertion_Kind (N : Node_Id);
277 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
278 -- then it is rewritten as an identifier with the corresponding special
279 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
282 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
283 -- Place semantic information on the argument of an Elaborate/Elaborate_All
284 -- pragma. Entity name for unit and its parents is taken from item in
285 -- previous with_clause that mentions the unit.
287 Dummy : Integer := 0;
288 pragma Volatile (Dummy);
289 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
292 pragma No_Inline (ip);
293 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
294 -- is just to help debugging the front end. If a pragma Inspection_Point
295 -- is added to a source program, then breaking on ip will get you to that
296 -- point in the program.
299 pragma No_Inline (rv);
300 -- This is a dummy function called by the processing for pragma Reviewable.
301 -- It is there for assisting front end debugging. By placing a Reviewable
302 -- pragma in the source program, a breakpoint on rv catches this place in
303 -- the source, allowing convenient stepping to the point of interest.
305 -------------------------------
306 -- Adjust_External_Name_Case --
307 -------------------------------
309 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
313 -- Adjust case of literal if required
315 if Opt.External_Name_Exp_Casing = As_Is then
319 -- Copy existing string
325 for J in 1 .. String_Length (Strval (N)) loop
326 CC := Get_String_Char (Strval (N), J);
328 if Opt.External_Name_Exp_Casing = Uppercase
329 and then CC >= Get_Char_Code ('a')
330 and then CC <= Get_Char_Code ('z')
332 Store_String_Char (CC - 32);
334 elsif Opt.External_Name_Exp_Casing = Lowercase
335 and then CC >= Get_Char_Code ('A')
336 and then CC <= Get_Char_Code ('Z')
338 Store_String_Char (CC + 32);
341 Store_String_Char (CC);
346 Make_String_Literal (Sloc (N),
347 Strval => End_String);
349 end Adjust_External_Name_Case;
351 -----------------------------------------
352 -- Analyze_Contract_Cases_In_Decl_Part --
353 -----------------------------------------
355 procedure Analyze_Contract_Cases_In_Decl_Part
357 Freeze_Id : Entity_Id := Empty)
359 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
360 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
362 Others_Seen : Boolean := False;
363 -- This flag is set when an "others" choice is encountered. It is used
364 -- to detect multiple illegal occurrences of "others".
366 procedure Analyze_Contract_Case (CCase : Node_Id);
367 -- Verify the legality of a single contract case
369 ---------------------------
370 -- Analyze_Contract_Case --
371 ---------------------------
373 procedure Analyze_Contract_Case (CCase : Node_Id) is
374 Case_Guard : Node_Id;
377 Extra_Guard : Node_Id;
380 if Nkind (CCase) = N_Component_Association then
381 Case_Guard := First (Choices (CCase));
382 Conseq := Expression (CCase);
384 -- Each contract case must have exactly one case guard
386 Extra_Guard := Next (Case_Guard);
388 if Present (Extra_Guard) then
390 ("contract case must have exactly one case guard",
394 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
396 if Nkind (Case_Guard) = N_Others_Choice then
399 ("only one others choice allowed in contract cases",
405 elsif Others_Seen then
407 ("others must be the last choice in contract cases", N);
410 -- Preanalyze the case guard and consequence
412 if Nkind (Case_Guard) /= N_Others_Choice then
413 Errors := Serious_Errors_Detected;
414 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
416 -- Emit a clarification message when the case guard contains
417 -- at least one undefined reference, possibly due to contract
420 if Errors /= Serious_Errors_Detected
421 and then Present (Freeze_Id)
422 and then Has_Undefined_Reference (Case_Guard)
424 Contract_Freeze_Error (Spec_Id, Freeze_Id);
428 Errors := Serious_Errors_Detected;
429 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
431 -- Emit a clarification message when the consequence contains
432 -- at least one undefined reference, possibly due to contract
435 if Errors /= Serious_Errors_Detected
436 and then Present (Freeze_Id)
437 and then Has_Undefined_Reference (Conseq)
439 Contract_Freeze_Error (Spec_Id, Freeze_Id);
442 -- The contract case is malformed
445 Error_Msg_N ("wrong syntax in contract case", CCase);
447 end Analyze_Contract_Case;
451 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
453 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
456 Restore_Scope : Boolean := False;
458 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
461 -- Do not analyze the pragma multiple times
463 if Is_Analyzed_Pragma (N) then
467 -- Set the Ghost mode in effect from the pragma. Due to the delayed
468 -- analysis of the pragma, the Ghost mode at point of declaration and
469 -- point of analysis may not necessarily be the same. Use the mode in
470 -- effect at the point of declaration.
474 -- Single and multiple contract cases must appear in aggregate form. If
475 -- this is not the case, then either the parser of the analysis of the
476 -- pragma failed to produce an aggregate.
478 pragma Assert (Nkind (CCases) = N_Aggregate);
480 if Present (Component_Associations (CCases)) then
482 -- Ensure that the formal parameters are visible when analyzing all
483 -- clauses. This falls out of the general rule of aspects pertaining
484 -- to subprogram declarations.
486 if not In_Open_Scopes (Spec_Id) then
487 Restore_Scope := True;
488 Push_Scope (Spec_Id);
490 if Is_Generic_Subprogram (Spec_Id) then
491 Install_Generic_Formals (Spec_Id);
493 Install_Formals (Spec_Id);
497 CCase := First (Component_Associations (CCases));
498 while Present (CCase) loop
499 Analyze_Contract_Case (CCase);
503 if Restore_Scope then
507 -- Currently it is not possible to inline pre/postconditions on a
508 -- subprogram subject to pragma Inline_Always.
510 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
512 -- Otherwise the pragma is illegal
515 Error_Msg_N ("wrong syntax for constract cases", N);
518 Ghost_Mode := Save_Ghost_Mode;
519 Set_Is_Analyzed_Pragma (N);
520 end Analyze_Contract_Cases_In_Decl_Part;
522 ----------------------------------
523 -- Analyze_Depends_In_Decl_Part --
524 ----------------------------------
526 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
527 Loc : constant Source_Ptr := Sloc (N);
528 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
529 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
531 All_Inputs_Seen : Elist_Id := No_Elist;
532 -- A list containing the entities of all the inputs processed so far.
533 -- The list is populated with unique entities because the same input
534 -- may appear in multiple input lists.
536 All_Outputs_Seen : Elist_Id := No_Elist;
537 -- A list containing the entities of all the outputs processed so far.
538 -- The list is populated with unique entities because output items are
539 -- unique in a dependence relation.
541 Constits_Seen : Elist_Id := No_Elist;
542 -- A list containing the entities of all constituents processed so far.
543 -- It aids in detecting illegal usage of a state and a corresponding
544 -- constituent in pragma [Refinde_]Depends.
546 Global_Seen : Boolean := False;
547 -- A flag set when pragma Global has been processed
549 Null_Output_Seen : Boolean := False;
550 -- A flag used to track the legality of a null output
552 Result_Seen : Boolean := False;
553 -- A flag set when Spec_Id'Result is processed
555 States_Seen : Elist_Id := No_Elist;
556 -- A list containing the entities of all states processed so far. It
557 -- helps in detecting illegal usage of a state and a corresponding
558 -- constituent in pragma [Refined_]Depends.
560 Subp_Inputs : Elist_Id := No_Elist;
561 Subp_Outputs : Elist_Id := No_Elist;
562 -- Two lists containing the full set of inputs and output of the related
563 -- subprograms. Note that these lists contain both nodes and entities.
565 Task_Input_Seen : Boolean := False;
566 Task_Output_Seen : Boolean := False;
567 -- Flags used to track the implicit dependence of a task unit on itself
569 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
570 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
571 -- to the name buffer. The individual kinds are as follows:
572 -- E_Abstract_State - "state"
573 -- E_Constant - "constant"
574 -- E_Discriminant - "discriminant"
575 -- E_Generic_In_Out_Parameter - "generic parameter"
576 -- E_Generic_In_Parameter - "generic parameter"
577 -- E_In_Parameter - "parameter"
578 -- E_In_Out_Parameter - "parameter"
579 -- E_Loop_Parameter - "loop parameter"
580 -- E_Out_Parameter - "parameter"
581 -- E_Protected_Type - "current instance of protected type"
582 -- E_Task_Type - "current instance of task type"
583 -- E_Variable - "global"
585 procedure Analyze_Dependency_Clause
588 -- Verify the legality of a single dependency clause. Flag Is_Last
589 -- denotes whether Clause is the last clause in the relation.
591 procedure Check_Function_Return;
592 -- Verify that Funtion'Result appears as one of the outputs
593 -- (SPARK RM 6.1.5(10)).
600 -- Ensure that an item fulfills its designated input and/or output role
601 -- as specified by pragma Global (if any) or the enclosing context. If
602 -- this is not the case, emit an error. Item and Item_Id denote the
603 -- attributes of an item. Flag Is_Input should be set when item comes
604 -- from an input list. Flag Self_Ref should be set when the item is an
605 -- output and the dependency clause has operator "+".
607 procedure Check_Usage
608 (Subp_Items : Elist_Id;
609 Used_Items : Elist_Id;
611 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
612 -- error if this is not the case.
614 procedure Normalize_Clause (Clause : Node_Id);
615 -- Remove a self-dependency "+" from the input list of a clause
617 -----------------------------
618 -- Add_Item_To_Name_Buffer --
619 -----------------------------
621 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
623 if Ekind (Item_Id) = E_Abstract_State then
624 Add_Str_To_Name_Buffer ("state");
626 elsif Ekind (Item_Id) = E_Constant then
627 Add_Str_To_Name_Buffer ("constant");
629 elsif Ekind (Item_Id) = E_Discriminant then
630 Add_Str_To_Name_Buffer ("discriminant");
632 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
633 E_Generic_In_Parameter)
635 Add_Str_To_Name_Buffer ("generic parameter");
637 elsif Is_Formal (Item_Id) then
638 Add_Str_To_Name_Buffer ("parameter");
640 elsif Ekind (Item_Id) = E_Loop_Parameter then
641 Add_Str_To_Name_Buffer ("loop parameter");
643 elsif Ekind (Item_Id) = E_Protected_Type
644 or else Is_Single_Protected_Object (Item_Id)
646 Add_Str_To_Name_Buffer ("current instance of protected type");
648 elsif Ekind (Item_Id) = E_Task_Type
649 or else Is_Single_Task_Object (Item_Id)
651 Add_Str_To_Name_Buffer ("current instance of task type");
653 elsif Ekind (Item_Id) = E_Variable then
654 Add_Str_To_Name_Buffer ("global");
656 -- The routine should not be called with non-SPARK items
661 end Add_Item_To_Name_Buffer;
663 -------------------------------
664 -- Analyze_Dependency_Clause --
665 -------------------------------
667 procedure Analyze_Dependency_Clause
671 procedure Analyze_Input_List (Inputs : Node_Id);
672 -- Verify the legality of a single input list
674 procedure Analyze_Input_Output
679 Seen : in out Elist_Id;
680 Null_Seen : in out Boolean;
681 Non_Null_Seen : in out Boolean);
682 -- Verify the legality of a single input or output item. Flag
683 -- Is_Input should be set whenever Item is an input, False when it
684 -- denotes an output. Flag Self_Ref should be set when the item is an
685 -- output and the dependency clause has a "+". Flag Top_Level should
686 -- be set whenever Item appears immediately within an input or output
687 -- list. Seen is a collection of all abstract states, objects and
688 -- formals processed so far. Flag Null_Seen denotes whether a null
689 -- input or output has been encountered. Flag Non_Null_Seen denotes
690 -- whether a non-null input or output has been encountered.
692 ------------------------
693 -- Analyze_Input_List --
694 ------------------------
696 procedure Analyze_Input_List (Inputs : Node_Id) is
697 Inputs_Seen : Elist_Id := No_Elist;
698 -- A list containing the entities of all inputs that appear in the
699 -- current input list.
701 Non_Null_Input_Seen : Boolean := False;
702 Null_Input_Seen : Boolean := False;
703 -- Flags used to check the legality of an input list
708 -- Multiple inputs appear as an aggregate
710 if Nkind (Inputs) = N_Aggregate then
711 if Present (Component_Associations (Inputs)) then
713 ("nested dependency relations not allowed", Inputs);
715 elsif Present (Expressions (Inputs)) then
716 Input := First (Expressions (Inputs));
717 while Present (Input) loop
724 Null_Seen => Null_Input_Seen,
725 Non_Null_Seen => Non_Null_Input_Seen);
730 -- Syntax error, always report
733 Error_Msg_N ("malformed input dependency list", Inputs);
736 -- Process a solitary input
745 Null_Seen => Null_Input_Seen,
746 Non_Null_Seen => Non_Null_Input_Seen);
749 -- Detect an illegal dependency clause of the form
753 if Null_Output_Seen and then Null_Input_Seen then
755 ("null dependency clause cannot have a null input list",
758 end Analyze_Input_List;
760 --------------------------
761 -- Analyze_Input_Output --
762 --------------------------
764 procedure Analyze_Input_Output
769 Seen : in out Elist_Id;
770 Null_Seen : in out Boolean;
771 Non_Null_Seen : in out Boolean)
773 procedure Current_Task_Instance_Seen;
774 -- Set the appropriate global flag when the current instance of a
775 -- task unit is encountered.
777 --------------------------------
778 -- Current_Task_Instance_Seen --
779 --------------------------------
781 procedure Current_Task_Instance_Seen is
784 Task_Input_Seen := True;
786 Task_Output_Seen := True;
788 end Current_Task_Instance_Seen;
792 Is_Output : constant Boolean := not Is_Input;
796 -- Start of processing for Analyze_Input_Output
799 -- Multiple input or output items appear as an aggregate
801 if Nkind (Item) = N_Aggregate then
802 if not Top_Level then
803 SPARK_Msg_N ("nested grouping of items not allowed", Item);
805 elsif Present (Component_Associations (Item)) then
807 ("nested dependency relations not allowed", Item);
809 -- Recursively analyze the grouped items
811 elsif Present (Expressions (Item)) then
812 Grouped := First (Expressions (Item));
813 while Present (Grouped) loop
816 Is_Input => Is_Input,
817 Self_Ref => Self_Ref,
820 Null_Seen => Null_Seen,
821 Non_Null_Seen => Non_Null_Seen);
826 -- Syntax error, always report
829 Error_Msg_N ("malformed dependency list", Item);
832 -- Process attribute 'Result in the context of a dependency clause
834 elsif Is_Attribute_Result (Item) then
835 Non_Null_Seen := True;
839 -- Attribute 'Result is allowed to appear on the output side of
840 -- a dependency clause (SPARK RM 6.1.5(6)).
843 SPARK_Msg_N ("function result cannot act as input", Item);
847 ("cannot mix null and non-null dependency items", Item);
853 -- Detect multiple uses of null in a single dependency list or
854 -- throughout the whole relation. Verify the placement of a null
855 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
857 elsif Nkind (Item) = N_Null then
860 ("multiple null dependency relations not allowed", Item);
862 elsif Non_Null_Seen then
864 ("cannot mix null and non-null dependency items", Item);
872 ("null output list must be the last clause in a "
873 & "dependency relation", Item);
875 -- Catch a useless dependence of the form:
880 ("useless dependence, null depends on itself", Item);
888 Non_Null_Seen := True;
891 SPARK_Msg_N ("cannot mix null and non-null items", Item);
895 Resolve_State (Item);
897 -- Find the entity of the item. If this is a renaming, climb
898 -- the renaming chain to reach the root object. Renamings of
899 -- non-entire objects do not yield an entity (Empty).
901 Item_Id := Entity_Of (Item);
903 if Present (Item_Id) then
907 if Ekind_In (Item_Id, E_Constant,
912 -- Current instances of concurrent types
914 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
919 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
920 E_Generic_In_Parameter,
928 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
930 -- The item denotes a concurrent type. Note that single
931 -- protected/task types are not considered here because
932 -- they behave as objects in the context of pragma
933 -- [Refined_]Depends.
935 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
937 -- This use is legal as long as the concurrent type is
938 -- the current instance of an enclosing type.
940 if Is_CCT_Instance (Item_Id, Spec_Id) then
942 -- The dependence of a task unit on itself is
943 -- implicit and may or may not be explicitly
944 -- specified (SPARK RM 6.1.4).
946 if Ekind (Item_Id) = E_Task_Type then
947 Current_Task_Instance_Seen;
950 -- Otherwise this is not the current instance
954 ("invalid use of subtype mark in dependency "
958 -- The dependency of a task unit on itself is implicit
959 -- and may or may not be explicitly specified
962 elsif Is_Single_Task_Object (Item_Id)
963 and then Is_CCT_Instance (Item_Id, Spec_Id)
965 Current_Task_Instance_Seen;
968 -- Ensure that the item fulfills its role as input and/or
969 -- output as specified by pragma Global or the enclosing
972 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
974 -- Detect multiple uses of the same state, variable or
975 -- formal parameter. If this is not the case, add the
976 -- item to the list of processed relations.
978 if Contains (Seen, Item_Id) then
980 ("duplicate use of item &", Item, Item_Id);
982 Append_New_Elmt (Item_Id, Seen);
985 -- Detect illegal use of an input related to a null
986 -- output. Such input items cannot appear in other
987 -- input lists (SPARK RM 6.1.5(13)).
990 and then Null_Output_Seen
991 and then Contains (All_Inputs_Seen, Item_Id)
994 ("input of a null output list cannot appear in "
995 & "multiple input lists", Item);
998 -- Add an input or a self-referential output to the list
999 -- of all processed inputs.
1001 if Is_Input or else Self_Ref then
1002 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1005 -- State related checks (SPARK RM 6.1.5(3))
1007 if Ekind (Item_Id) = E_Abstract_State then
1009 -- Package and subprogram bodies are instantiated
1010 -- individually in a separate compiler pass. Due to
1011 -- this mode of instantiation, the refinement of a
1012 -- state may no longer be visible when a subprogram
1013 -- body contract is instantiated. Since the generic
1014 -- template is legal, do not perform this check in
1015 -- the instance to circumvent this oddity.
1017 if Is_Generic_Instance (Spec_Id) then
1020 -- An abstract state with visible refinement cannot
1021 -- appear in pragma [Refined_]Depends as its place
1022 -- must be taken by some of its constituents
1023 -- (SPARK RM 6.1.4(7)).
1025 elsif Has_Visible_Refinement (Item_Id) then
1027 ("cannot mention state & in dependence relation",
1029 SPARK_Msg_N ("\use its constituents instead", Item);
1032 -- If the reference to the abstract state appears in
1033 -- an enclosing package body that will eventually
1034 -- refine the state, record the reference for future
1038 Record_Possible_Body_Reference
1039 (State_Id => Item_Id,
1044 -- When the item renames an entire object, replace the
1045 -- item with a reference to the object.
1047 if Entity (Item) /= Item_Id then
1049 New_Occurrence_Of (Item_Id, Sloc (Item)));
1053 -- Add the entity of the current item to the list of
1056 if Ekind (Item_Id) = E_Abstract_State then
1057 Append_New_Elmt (Item_Id, States_Seen);
1059 -- The variable may eventually become a constituent of a
1060 -- single protected/task type. Record the reference now
1061 -- and verify its legality when analyzing the contract of
1062 -- the variable (SPARK RM 9.3).
1064 elsif Ekind (Item_Id) = E_Variable then
1065 Record_Possible_Part_Of_Reference
1070 if Ekind_In (Item_Id, E_Abstract_State,
1073 and then Present (Encapsulating_State (Item_Id))
1075 Append_New_Elmt (Item_Id, Constits_Seen);
1078 -- All other input/output items are illegal
1079 -- (SPARK RM 6.1.5(1)).
1083 ("item must denote parameter, variable, state or "
1084 & "current instance of concurren type", Item);
1087 -- All other input/output items are illegal
1088 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1092 ("item must denote parameter, variable, state or current "
1093 & "instance of concurrent type", Item);
1096 end Analyze_Input_Output;
1104 Non_Null_Output_Seen : Boolean := False;
1105 -- Flag used to check the legality of an output list
1107 -- Start of processing for Analyze_Dependency_Clause
1110 Inputs := Expression (Clause);
1113 -- An input list with a self-dependency appears as operator "+" where
1114 -- the actuals inputs are the right operand.
1116 if Nkind (Inputs) = N_Op_Plus then
1117 Inputs := Right_Opnd (Inputs);
1121 -- Process the output_list of a dependency_clause
1123 Output := First (Choices (Clause));
1124 while Present (Output) loop
1125 Analyze_Input_Output
1128 Self_Ref => Self_Ref,
1130 Seen => All_Outputs_Seen,
1131 Null_Seen => Null_Output_Seen,
1132 Non_Null_Seen => Non_Null_Output_Seen);
1137 -- Process the input_list of a dependency_clause
1139 Analyze_Input_List (Inputs);
1140 end Analyze_Dependency_Clause;
1142 ---------------------------
1143 -- Check_Function_Return --
1144 ---------------------------
1146 procedure Check_Function_Return is
1148 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1149 and then not Result_Seen
1152 ("result of & must appear in exactly one output list",
1155 end Check_Function_Return;
1161 procedure Check_Role
1163 Item_Id : Entity_Id;
1168 (Item_Is_Input : out Boolean;
1169 Item_Is_Output : out Boolean);
1170 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1171 -- Item_Is_Output are set depending on the role.
1173 procedure Role_Error
1174 (Item_Is_Input : Boolean;
1175 Item_Is_Output : Boolean);
1176 -- Emit an error message concerning the incorrect use of Item in
1177 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1178 -- denote whether the item is an input and/or an output.
1185 (Item_Is_Input : out Boolean;
1186 Item_Is_Output : out Boolean)
1189 Item_Is_Input := False;
1190 Item_Is_Output := False;
1194 if Ekind (Item_Id) = E_Abstract_State then
1196 -- When pragma Global is present, the mode of the state may be
1197 -- further constrained by setting a more restrictive mode.
1200 if Appears_In (Subp_Inputs, Item_Id) then
1201 Item_Is_Input := True;
1204 if Appears_In (Subp_Outputs, Item_Id) then
1205 Item_Is_Output := True;
1208 -- Otherwise the state has a default IN OUT mode
1211 Item_Is_Input := True;
1212 Item_Is_Output := True;
1217 elsif Ekind_In (Item_Id, E_Constant,
1221 Item_Is_Input := True;
1225 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1228 Item_Is_Input := True;
1230 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1233 Item_Is_Input := True;
1234 Item_Is_Output := True;
1236 elsif Ekind (Item_Id) = E_Out_Parameter then
1237 if Scope (Item_Id) = Spec_Id then
1239 -- An OUT parameter of the related subprogram has mode IN
1240 -- if its type is unconstrained or tagged because array
1241 -- bounds, discriminants or tags can be read.
1243 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1244 Item_Is_Input := True;
1247 Item_Is_Output := True;
1249 -- An OUT parameter of an enclosing subprogram behaves as a
1250 -- read-write variable in which case the mode is IN OUT.
1253 Item_Is_Input := True;
1254 Item_Is_Output := True;
1259 elsif Ekind (Item_Id) = E_Protected_Type then
1261 -- A protected type acts as a formal parameter of mode IN when
1262 -- it applies to a protected function.
1264 if Ekind (Spec_Id) = E_Function then
1265 Item_Is_Input := True;
1267 -- Otherwise the protected type acts as a formal of mode IN OUT
1270 Item_Is_Input := True;
1271 Item_Is_Output := True;
1276 elsif Ekind (Item_Id) = E_Task_Type then
1277 Item_Is_Input := True;
1278 Item_Is_Output := True;
1282 else pragma Assert (Ekind (Item_Id) = E_Variable);
1284 -- When pragma Global is present, the mode of the variable may
1285 -- be further constrained by setting a more restrictive mode.
1289 -- A variable has mode IN when its type is unconstrained or
1290 -- tagged because array bounds, discriminants or tags can be
1293 if Appears_In (Subp_Inputs, Item_Id)
1294 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1296 Item_Is_Input := True;
1299 if Appears_In (Subp_Outputs, Item_Id) then
1300 Item_Is_Output := True;
1303 -- Otherwise the variable has a default IN OUT mode
1306 Item_Is_Input := True;
1307 Item_Is_Output := True;
1316 procedure Role_Error
1317 (Item_Is_Input : Boolean;
1318 Item_Is_Output : Boolean)
1320 Error_Msg : Name_Id;
1325 -- When the item is not part of the input and the output set of
1326 -- the related subprogram, then it appears as extra in pragma
1327 -- [Refined_]Depends.
1329 if not Item_Is_Input and then not Item_Is_Output then
1330 Add_Item_To_Name_Buffer (Item_Id);
1331 Add_Str_To_Name_Buffer
1332 (" & cannot appear in dependence relation");
1334 Error_Msg := Name_Find;
1335 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1337 Error_Msg_Name_1 := Chars (Spec_Id);
1339 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1340 & "set of subprogram %"), Item, Item_Id);
1342 -- The mode of the item and its role in pragma [Refined_]Depends
1343 -- are in conflict. Construct a detailed message explaining the
1344 -- illegality (SPARK RM 6.1.5(5-6)).
1347 if Item_Is_Input then
1348 Add_Str_To_Name_Buffer ("read-only");
1350 Add_Str_To_Name_Buffer ("write-only");
1353 Add_Char_To_Name_Buffer (' ');
1354 Add_Item_To_Name_Buffer (Item_Id);
1355 Add_Str_To_Name_Buffer (" & cannot appear as ");
1357 if Item_Is_Input then
1358 Add_Str_To_Name_Buffer ("output");
1360 Add_Str_To_Name_Buffer ("input");
1363 Add_Str_To_Name_Buffer (" in dependence relation");
1364 Error_Msg := Name_Find;
1365 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1371 Item_Is_Input : Boolean;
1372 Item_Is_Output : Boolean;
1374 -- Start of processing for Check_Role
1377 Find_Role (Item_Is_Input, Item_Is_Output);
1382 if not Item_Is_Input then
1383 Role_Error (Item_Is_Input, Item_Is_Output);
1386 -- Self-referential item
1389 if not Item_Is_Input or else not Item_Is_Output then
1390 Role_Error (Item_Is_Input, Item_Is_Output);
1395 elsif not Item_Is_Output then
1396 Role_Error (Item_Is_Input, Item_Is_Output);
1404 procedure Check_Usage
1405 (Subp_Items : Elist_Id;
1406 Used_Items : Elist_Id;
1409 procedure Usage_Error (Item_Id : Entity_Id);
1410 -- Emit an error concerning the illegal usage of an item
1416 procedure Usage_Error (Item_Id : Entity_Id) is
1417 Error_Msg : Name_Id;
1424 -- Unconstrained and tagged items are not part of the explicit
1425 -- input set of the related subprogram, they do not have to be
1426 -- present in a dependence relation and should not be flagged
1427 -- (SPARK RM 6.1.5(8)).
1429 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1432 Add_Item_To_Name_Buffer (Item_Id);
1433 Add_Str_To_Name_Buffer
1434 (" & is missing from input dependence list");
1436 Error_Msg := Name_Find;
1437 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1440 -- Output case (SPARK RM 6.1.5(10))
1445 Add_Item_To_Name_Buffer (Item_Id);
1446 Add_Str_To_Name_Buffer
1447 (" & is missing from output dependence list");
1449 Error_Msg := Name_Find;
1450 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1458 Item_Id : Entity_Id;
1460 -- Start of processing for Check_Usage
1463 if No (Subp_Items) then
1467 -- Each input or output of the subprogram must appear in a dependency
1470 Elmt := First_Elmt (Subp_Items);
1471 while Present (Elmt) loop
1472 Item := Node (Elmt);
1474 if Nkind (Item) = N_Defining_Identifier then
1477 Item_Id := Entity_Of (Item);
1480 -- The item does not appear in a dependency
1482 if Present (Item_Id)
1483 and then not Contains (Used_Items, Item_Id)
1485 if Is_Formal (Item_Id) then
1486 Usage_Error (Item_Id);
1488 -- The current instance of a protected type behaves as a formal
1489 -- parameter (SPARK RM 6.1.4).
1491 elsif Ekind (Item_Id) = E_Protected_Type
1492 or else Is_Single_Protected_Object (Item_Id)
1494 Usage_Error (Item_Id);
1496 -- The current instance of a task type behaves as a formal
1497 -- parameter (SPARK RM 6.1.4).
1499 elsif Ekind (Item_Id) = E_Task_Type
1500 or else Is_Single_Task_Object (Item_Id)
1502 -- The dependence of a task unit on itself is implicit and
1503 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1504 -- Emit an error if only one input/output is present.
1506 if Task_Input_Seen /= Task_Output_Seen then
1507 Usage_Error (Item_Id);
1510 -- States and global objects are not used properly only when
1511 -- the subprogram is subject to pragma Global.
1513 elsif Global_Seen then
1514 Usage_Error (Item_Id);
1522 ----------------------
1523 -- Normalize_Clause --
1524 ----------------------
1526 procedure Normalize_Clause (Clause : Node_Id) is
1527 procedure Create_Or_Modify_Clause
1533 Multiple : Boolean);
1534 -- Create a brand new clause to represent the self-reference or
1535 -- modify the input and/or output lists of an existing clause. Output
1536 -- denotes a self-referencial output. Outputs is the output list of a
1537 -- clause. Inputs is the input list of a clause. After denotes the
1538 -- clause after which the new clause is to be inserted. Flag In_Place
1539 -- should be set when normalizing the last output of an output list.
1540 -- Flag Multiple should be set when Output comes from a list with
1543 -----------------------------
1544 -- Create_Or_Modify_Clause --
1545 -----------------------------
1547 procedure Create_Or_Modify_Clause
1555 procedure Propagate_Output
1558 -- Handle the various cases of output propagation to the input
1559 -- list. Output denotes a self-referencial output item. Inputs
1560 -- is the input list of a clause.
1562 ----------------------
1563 -- Propagate_Output --
1564 ----------------------
1566 procedure Propagate_Output
1570 function In_Input_List
1572 Inputs : List_Id) return Boolean;
1573 -- Determine whether a particulat item appears in the input
1574 -- list of a clause.
1580 function In_Input_List
1582 Inputs : List_Id) return Boolean
1587 Elmt := First (Inputs);
1588 while Present (Elmt) loop
1589 if Entity_Of (Elmt) = Item then
1601 Output_Id : constant Entity_Id := Entity_Of (Output);
1604 -- Start of processing for Propagate_Output
1607 -- The clause is of the form:
1609 -- (Output =>+ null)
1611 -- Remove null input and replace it with a copy of the output:
1613 -- (Output => Output)
1615 if Nkind (Inputs) = N_Null then
1616 Rewrite (Inputs, New_Copy_Tree (Output));
1618 -- The clause is of the form:
1620 -- (Output =>+ (Input1, ..., InputN))
1622 -- Determine whether the output is not already mentioned in the
1623 -- input list and if not, add it to the list of inputs:
1625 -- (Output => (Output, Input1, ..., InputN))
1627 elsif Nkind (Inputs) = N_Aggregate then
1628 Grouped := Expressions (Inputs);
1630 if not In_Input_List
1634 Prepend_To (Grouped, New_Copy_Tree (Output));
1637 -- The clause is of the form:
1639 -- (Output =>+ Input)
1641 -- If the input does not mention the output, group the two
1644 -- (Output => (Output, Input))
1646 elsif Entity_Of (Inputs) /= Output_Id then
1648 Make_Aggregate (Loc,
1649 Expressions => New_List (
1650 New_Copy_Tree (Output),
1651 New_Copy_Tree (Inputs))));
1653 end Propagate_Output;
1657 Loc : constant Source_Ptr := Sloc (Clause);
1658 New_Clause : Node_Id;
1660 -- Start of processing for Create_Or_Modify_Clause
1663 -- A null output depending on itself does not require any
1666 if Nkind (Output) = N_Null then
1669 -- A function result cannot depend on itself because it cannot
1670 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1672 elsif Is_Attribute_Result (Output) then
1673 SPARK_Msg_N ("function result cannot depend on itself", Output);
1677 -- When performing the transformation in place, simply add the
1678 -- output to the list of inputs (if not already there). This
1679 -- case arises when dealing with the last output of an output
1680 -- list. Perform the normalization in place to avoid generating
1681 -- a malformed tree.
1684 Propagate_Output (Output, Inputs);
1686 -- A list with multiple outputs is slowly trimmed until only
1687 -- one element remains. When this happens, replace aggregate
1688 -- with the element itself.
1692 Rewrite (Outputs, Output);
1698 -- Unchain the output from its output list as it will appear in
1699 -- a new clause. Note that we cannot simply rewrite the output
1700 -- as null because this will violate the semantics of pragma
1705 -- Generate a new clause of the form:
1706 -- (Output => Inputs)
1709 Make_Component_Association (Loc,
1710 Choices => New_List (Output),
1711 Expression => New_Copy_Tree (Inputs));
1713 -- The new clause contains replicated content that has already
1714 -- been analyzed. There is not need to reanalyze or renormalize
1717 Set_Analyzed (New_Clause);
1720 (Output => First (Choices (New_Clause)),
1721 Inputs => Expression (New_Clause));
1723 Insert_After (After, New_Clause);
1725 end Create_Or_Modify_Clause;
1729 Outputs : constant Node_Id := First (Choices (Clause));
1731 Last_Output : Node_Id;
1732 Next_Output : Node_Id;
1735 -- Start of processing for Normalize_Clause
1738 -- A self-dependency appears as operator "+". Remove the "+" from the
1739 -- tree by moving the real inputs to their proper place.
1741 if Nkind (Expression (Clause)) = N_Op_Plus then
1742 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1743 Inputs := Expression (Clause);
1745 -- Multiple outputs appear as an aggregate
1747 if Nkind (Outputs) = N_Aggregate then
1748 Last_Output := Last (Expressions (Outputs));
1750 Output := First (Expressions (Outputs));
1751 while Present (Output) loop
1753 -- Normalization may remove an output from its list,
1754 -- preserve the subsequent output now.
1756 Next_Output := Next (Output);
1758 Create_Or_Modify_Clause
1763 In_Place => Output = Last_Output,
1766 Output := Next_Output;
1772 Create_Or_Modify_Clause
1781 end Normalize_Clause;
1785 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1786 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1790 Last_Clause : Node_Id;
1791 Restore_Scope : Boolean := False;
1793 -- Start of processing for Analyze_Depends_In_Decl_Part
1796 -- Do not analyze the pragma multiple times
1798 if Is_Analyzed_Pragma (N) then
1802 -- Empty dependency list
1804 if Nkind (Deps) = N_Null then
1806 -- Gather all states, objects and formal parameters that the
1807 -- subprogram may depend on. These items are obtained from the
1808 -- parameter profile or pragma [Refined_]Global (if available).
1810 Collect_Subprogram_Inputs_Outputs
1811 (Subp_Id => Subp_Id,
1812 Subp_Inputs => Subp_Inputs,
1813 Subp_Outputs => Subp_Outputs,
1814 Global_Seen => Global_Seen);
1816 -- Verify that every input or output of the subprogram appear in a
1819 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1820 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1821 Check_Function_Return;
1823 -- Dependency clauses appear as component associations of an aggregate
1825 elsif Nkind (Deps) = N_Aggregate then
1827 -- Do not attempt to perform analysis of a syntactically illegal
1828 -- clause as this will lead to misleading errors.
1830 if Has_Extra_Parentheses (Deps) then
1834 if Present (Component_Associations (Deps)) then
1835 Last_Clause := Last (Component_Associations (Deps));
1837 -- Gather all states, objects and formal parameters that the
1838 -- subprogram may depend on. These items are obtained from the
1839 -- parameter profile or pragma [Refined_]Global (if available).
1841 Collect_Subprogram_Inputs_Outputs
1842 (Subp_Id => Subp_Id,
1843 Subp_Inputs => Subp_Inputs,
1844 Subp_Outputs => Subp_Outputs,
1845 Global_Seen => Global_Seen);
1847 -- When pragma [Refined_]Depends appears on a single concurrent
1848 -- type, it is relocated to the anonymous object.
1850 if Is_Single_Concurrent_Object (Spec_Id) then
1853 -- Ensure that the formal parameters are visible when analyzing
1854 -- all clauses. This falls out of the general rule of aspects
1855 -- pertaining to subprogram declarations.
1857 elsif not In_Open_Scopes (Spec_Id) then
1858 Restore_Scope := True;
1859 Push_Scope (Spec_Id);
1861 if Ekind (Spec_Id) = E_Task_Type then
1862 if Has_Discriminants (Spec_Id) then
1863 Install_Discriminants (Spec_Id);
1866 elsif Is_Generic_Subprogram (Spec_Id) then
1867 Install_Generic_Formals (Spec_Id);
1870 Install_Formals (Spec_Id);
1874 Clause := First (Component_Associations (Deps));
1875 while Present (Clause) loop
1876 Errors := Serious_Errors_Detected;
1878 -- The normalization mechanism may create extra clauses that
1879 -- contain replicated input and output names. There is no need
1880 -- to reanalyze them.
1882 if not Analyzed (Clause) then
1883 Set_Analyzed (Clause);
1885 Analyze_Dependency_Clause
1887 Is_Last => Clause = Last_Clause);
1890 -- Do not normalize a clause if errors were detected (count
1891 -- of Serious_Errors has increased) because the inputs and/or
1892 -- outputs may denote illegal items. Normalization is disabled
1893 -- in ASIS mode as it alters the tree by introducing new nodes
1894 -- similar to expansion.
1896 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1897 Normalize_Clause (Clause);
1903 if Restore_Scope then
1907 -- Verify that every input or output of the subprogram appear in a
1910 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1911 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1912 Check_Function_Return;
1914 -- The dependency list is malformed. This is a syntax error, always
1918 Error_Msg_N ("malformed dependency relation", Deps);
1922 -- The top level dependency relation is malformed. This is a syntax
1923 -- error, always report.
1926 Error_Msg_N ("malformed dependency relation", Deps);
1930 -- Ensure that a state and a corresponding constituent do not appear
1931 -- together in pragma [Refined_]Depends.
1933 Check_State_And_Constituent_Use
1934 (States => States_Seen,
1935 Constits => Constits_Seen,
1939 Set_Is_Analyzed_Pragma (N);
1940 end Analyze_Depends_In_Decl_Part;
1942 --------------------------------------------
1943 -- Analyze_External_Property_In_Decl_Part --
1944 --------------------------------------------
1946 procedure Analyze_External_Property_In_Decl_Part
1948 Expr_Val : out Boolean)
1950 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1951 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1952 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1958 -- Do not analyze the pragma multiple times
1960 if Is_Analyzed_Pragma (N) then
1964 Error_Msg_Name_1 := Pragma_Name (N);
1966 -- An external property pragma must apply to an effectively volatile
1967 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1968 -- The check is performed at the end of the declarative region due to a
1969 -- possible out-of-order arrangement of pragmas:
1972 -- pragma Async_Readers (Obj);
1973 -- pragma Volatile (Obj);
1975 if not Is_Effectively_Volatile (Obj_Id) then
1977 ("external property % must apply to a volatile object", N);
1980 -- Ensure that the Boolean expression (if present) is static. A missing
1981 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1985 if Present (Arg1) then
1986 Expr := Get_Pragma_Arg (Arg1);
1988 if Is_OK_Static_Expression (Expr) then
1989 Expr_Val := Is_True (Expr_Value (Expr));
1993 Set_Is_Analyzed_Pragma (N);
1994 end Analyze_External_Property_In_Decl_Part;
1996 ---------------------------------
1997 -- Analyze_Global_In_Decl_Part --
1998 ---------------------------------
2000 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2001 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2002 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2003 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2005 Constits_Seen : Elist_Id := No_Elist;
2006 -- A list containing the entities of all constituents processed so far.
2007 -- It aids in detecting illegal usage of a state and a corresponding
2008 -- constituent in pragma [Refinde_]Global.
2010 Seen : Elist_Id := No_Elist;
2011 -- A list containing the entities of all the items processed so far. It
2012 -- plays a role in detecting distinct entities.
2014 States_Seen : Elist_Id := No_Elist;
2015 -- A list containing the entities of all states processed so far. It
2016 -- helps in detecting illegal usage of a state and a corresponding
2017 -- constituent in pragma [Refined_]Global.
2019 In_Out_Seen : Boolean := False;
2020 Input_Seen : Boolean := False;
2021 Output_Seen : Boolean := False;
2022 Proof_Seen : Boolean := False;
2023 -- Flags used to verify the consistency of modes
2025 procedure Analyze_Global_List
2027 Global_Mode : Name_Id := Name_Input);
2028 -- Verify the legality of a single global list declaration. Global_Mode
2029 -- denotes the current mode in effect.
2031 -------------------------
2032 -- Analyze_Global_List --
2033 -------------------------
2035 procedure Analyze_Global_List
2037 Global_Mode : Name_Id := Name_Input)
2039 procedure Analyze_Global_Item
2041 Global_Mode : Name_Id);
2042 -- Verify the legality of a single global item declaration denoted by
2043 -- Item. Global_Mode denotes the current mode in effect.
2045 procedure Check_Duplicate_Mode
2047 Status : in out Boolean);
2048 -- Flag Status denotes whether a particular mode has been seen while
2049 -- processing a global list. This routine verifies that Mode is not a
2050 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2052 procedure Check_Mode_Restriction_In_Enclosing_Context
2054 Item_Id : Entity_Id);
2055 -- Verify that an item of mode In_Out or Output does not appear as an
2056 -- input in the Global aspect of an enclosing subprogram. If this is
2057 -- the case, emit an error. Item and Item_Id are respectively the
2058 -- item and its entity.
2060 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2061 -- Mode denotes either In_Out or Output. Depending on the kind of the
2062 -- related subprogram, emit an error if those two modes apply to a
2063 -- function (SPARK RM 6.1.4(10)).
2065 -------------------------
2066 -- Analyze_Global_Item --
2067 -------------------------
2069 procedure Analyze_Global_Item
2071 Global_Mode : Name_Id)
2073 Item_Id : Entity_Id;
2076 -- Detect one of the following cases
2078 -- with Global => (null, Name)
2079 -- with Global => (Name_1, null, Name_2)
2080 -- with Global => (Name, null)
2082 if Nkind (Item) = N_Null then
2083 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2088 Resolve_State (Item);
2090 -- Find the entity of the item. If this is a renaming, climb the
2091 -- renaming chain to reach the root object. Renamings of non-
2092 -- entire objects do not yield an entity (Empty).
2094 Item_Id := Entity_Of (Item);
2096 if Present (Item_Id) then
2098 -- A global item may denote a formal parameter of an enclosing
2099 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2100 -- provide a better error diagnostic.
2102 if Is_Formal (Item_Id) then
2103 if Scope (Item_Id) = Spec_Id then
2105 (Fix_Msg (Spec_Id, "global item cannot reference "
2106 & "parameter of subprogram &"), Item, Spec_Id);
2110 -- A global item may denote a concurrent type as long as it is
2111 -- the current instance of an enclosing protected or task type
2112 -- (SPARK RM 6.1.4).
2114 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2115 if Is_CCT_Instance (Item_Id, Spec_Id) then
2117 -- Pragma [Refined_]Global associated with a protected
2118 -- subprogram cannot mention the current instance of a
2119 -- protected type because the instance behaves as a
2120 -- formal parameter.
2122 if Ekind (Item_Id) = E_Protected_Type then
2123 Error_Msg_Name_1 := Chars (Item_Id);
2125 (Fix_Msg (Spec_Id, "global item of subprogram & "
2126 & "cannot reference current instance of protected "
2127 & "type %"), Item, Spec_Id);
2130 -- Pragma [Refined_]Global associated with a task type
2131 -- cannot mention the current instance of a task type
2132 -- because the instance behaves as a formal parameter.
2134 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2135 Error_Msg_Name_1 := Chars (Item_Id);
2137 (Fix_Msg (Spec_Id, "global item of subprogram & "
2138 & "cannot reference current instance of task type "
2139 & "%"), Item, Spec_Id);
2143 -- Otherwise the global item denotes a subtype mark that is
2144 -- not a current instance.
2148 ("invalid use of subtype mark in global list", Item);
2152 -- A global item may denote the anonymous object created for a
2153 -- single protected/task type as long as the current instance
2154 -- is the same single type (SPARK RM 6.1.4).
2156 elsif Is_Single_Concurrent_Object (Item_Id)
2157 and then Is_CCT_Instance (Item_Id, Spec_Id)
2159 -- Pragma [Refined_]Global associated with a protected
2160 -- subprogram cannot mention the current instance of a
2161 -- protected type because the instance behaves as a formal
2164 if Is_Single_Protected_Object (Item_Id) then
2165 Error_Msg_Name_1 := Chars (Item_Id);
2167 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2168 & "reference current instance of protected type %"),
2172 -- Pragma [Refined_]Global associated with a task type
2173 -- cannot mention the current instance of a task type
2174 -- because the instance behaves as a formal parameter.
2176 else pragma Assert (Is_Single_Task_Object (Item_Id));
2177 Error_Msg_Name_1 := Chars (Item_Id);
2179 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2180 & "reference current instance of task type %"),
2185 -- A formal object may act as a global item inside a generic
2187 elsif Is_Formal_Object (Item_Id) then
2190 -- The only legal references are those to abstract states,
2191 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2193 elsif not Ekind_In (Item_Id, E_Abstract_State,
2200 ("global item must denote object, state or current "
2201 & "instance of concurrent type", Item);
2205 -- State related checks
2207 if Ekind (Item_Id) = E_Abstract_State then
2209 -- Package and subprogram bodies are instantiated
2210 -- individually in a separate compiler pass. Due to this
2211 -- mode of instantiation, the refinement of a state may
2212 -- no longer be visible when a subprogram body contract
2213 -- is instantiated. Since the generic template is legal,
2214 -- do not perform this check in the instance to circumvent
2217 if Is_Generic_Instance (Spec_Id) then
2220 -- An abstract state with visible refinement cannot appear
2221 -- in pragma [Refined_]Global as its place must be taken by
2222 -- some of its constituents (SPARK RM 6.1.4(7)).
2224 elsif Has_Visible_Refinement (Item_Id) then
2226 ("cannot mention state & in global refinement",
2228 SPARK_Msg_N ("\use its constituents instead", Item);
2231 -- An external state cannot appear as a global item of a
2232 -- nonvolatile function (SPARK RM 7.1.3(8)).
2234 elsif Is_External_State (Item_Id)
2235 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2236 and then not Is_Volatile_Function (Spec_Id)
2239 ("external state & cannot act as global item of "
2240 & "nonvolatile function", Item, Item_Id);
2243 -- If the reference to the abstract state appears in an
2244 -- enclosing package body that will eventually refine the
2245 -- state, record the reference for future checks.
2248 Record_Possible_Body_Reference
2249 (State_Id => Item_Id,
2253 -- Constant related checks
2255 elsif Ekind (Item_Id) = E_Constant then
2257 -- A constant is a read-only item, therefore it cannot act
2260 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2262 ("constant & cannot act as output", Item, Item_Id);
2266 -- Discriminant related checks
2268 elsif Ekind (Item_Id) = E_Discriminant then
2270 -- A discriminant is a read-only item, therefore it cannot
2271 -- act as an output.
2273 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2275 ("discriminant & cannot act as output", Item, Item_Id);
2279 -- Loop parameter related checks
2281 elsif Ekind (Item_Id) = E_Loop_Parameter then
2283 -- A loop parameter is a read-only item, therefore it cannot
2284 -- act as an output.
2286 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2288 ("loop parameter & cannot act as output",
2293 -- Variable related checks. These are only relevant when
2294 -- SPARK_Mode is on as they are not standard Ada legality
2297 elsif SPARK_Mode = On
2298 and then Ekind (Item_Id) = E_Variable
2299 and then Is_Effectively_Volatile (Item_Id)
2301 -- An effectively volatile object cannot appear as a global
2302 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2304 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2305 and then not Is_Volatile_Function (Spec_Id)
2308 ("volatile object & cannot act as global item of a "
2309 & "function", Item, Item_Id);
2312 -- An effectively volatile object with external property
2313 -- Effective_Reads set to True must have mode Output or
2314 -- In_Out (SPARK RM 7.1.3(10)).
2316 elsif Effective_Reads_Enabled (Item_Id)
2317 and then Global_Mode = Name_Input
2320 ("volatile object & with property Effective_Reads must "
2321 & "have mode In_Out or Output", Item, Item_Id);
2326 -- When the item renames an entire object, replace the item
2327 -- with a reference to the object.
2329 if Entity (Item) /= Item_Id then
2330 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2334 -- Some form of illegal construct masquerading as a name
2335 -- (SPARK RM 6.1.4(4)).
2339 ("global item must denote object, state or current instance "
2340 & "of concurrent type", Item);
2344 -- Verify that an output does not appear as an input in an
2345 -- enclosing subprogram.
2347 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2348 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2351 -- The same entity might be referenced through various way.
2352 -- Check the entity of the item rather than the item itself
2353 -- (SPARK RM 6.1.4(10)).
2355 if Contains (Seen, Item_Id) then
2356 SPARK_Msg_N ("duplicate global item", Item);
2358 -- Add the entity of the current item to the list of processed
2362 Append_New_Elmt (Item_Id, Seen);
2364 if Ekind (Item_Id) = E_Abstract_State then
2365 Append_New_Elmt (Item_Id, States_Seen);
2367 -- The variable may eventually become a constituent of a single
2368 -- protected/task type. Record the reference now and verify its
2369 -- legality when analyzing the contract of the variable
2372 elsif Ekind (Item_Id) = E_Variable then
2373 Record_Possible_Part_Of_Reference
2378 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2379 and then Present (Encapsulating_State (Item_Id))
2381 Append_New_Elmt (Item_Id, Constits_Seen);
2384 end Analyze_Global_Item;
2386 --------------------------
2387 -- Check_Duplicate_Mode --
2388 --------------------------
2390 procedure Check_Duplicate_Mode
2392 Status : in out Boolean)
2396 SPARK_Msg_N ("duplicate global mode", Mode);
2400 end Check_Duplicate_Mode;
2402 -------------------------------------------------
2403 -- Check_Mode_Restriction_In_Enclosing_Context --
2404 -------------------------------------------------
2406 procedure Check_Mode_Restriction_In_Enclosing_Context
2408 Item_Id : Entity_Id)
2410 Context : Entity_Id;
2412 Inputs : Elist_Id := No_Elist;
2413 Outputs : Elist_Id := No_Elist;
2416 -- Traverse the scope stack looking for enclosing subprograms
2417 -- subject to pragma [Refined_]Global.
2419 Context := Scope (Subp_Id);
2420 while Present (Context) and then Context /= Standard_Standard loop
2421 if Is_Subprogram (Context)
2423 (Present (Get_Pragma (Context, Pragma_Global))
2425 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2427 Collect_Subprogram_Inputs_Outputs
2428 (Subp_Id => Context,
2429 Subp_Inputs => Inputs,
2430 Subp_Outputs => Outputs,
2431 Global_Seen => Dummy);
2433 -- The item is classified as In_Out or Output but appears as
2434 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2436 if Appears_In (Inputs, Item_Id)
2437 and then not Appears_In (Outputs, Item_Id)
2440 ("global item & cannot have mode In_Out or Output",
2444 (Fix_Msg (Subp_Id, "\item already appears as input of "
2445 & "subprogram &"), Item, Context);
2447 -- Stop the traversal once an error has been detected
2453 Context := Scope (Context);
2455 end Check_Mode_Restriction_In_Enclosing_Context;
2457 ----------------------------------------
2458 -- Check_Mode_Restriction_In_Function --
2459 ----------------------------------------
2461 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2463 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2465 ("global mode & is not applicable to functions", Mode);
2467 end Check_Mode_Restriction_In_Function;
2475 -- Start of processing for Analyze_Global_List
2478 if Nkind (List) = N_Null then
2479 Set_Analyzed (List);
2481 -- Single global item declaration
2483 elsif Nkind_In (List, N_Expanded_Name,
2485 N_Selected_Component)
2487 Analyze_Global_Item (List, Global_Mode);
2489 -- Simple global list or moded global list declaration
2491 elsif Nkind (List) = N_Aggregate then
2492 Set_Analyzed (List);
2494 -- The declaration of a simple global list appear as a collection
2497 if Present (Expressions (List)) then
2498 if Present (Component_Associations (List)) then
2500 ("cannot mix moded and non-moded global lists", List);
2503 Item := First (Expressions (List));
2504 while Present (Item) loop
2505 Analyze_Global_Item (Item, Global_Mode);
2509 -- The declaration of a moded global list appears as a collection
2510 -- of component associations where individual choices denote
2513 elsif Present (Component_Associations (List)) then
2514 if Present (Expressions (List)) then
2516 ("cannot mix moded and non-moded global lists", List);
2519 Assoc := First (Component_Associations (List));
2520 while Present (Assoc) loop
2521 Mode := First (Choices (Assoc));
2523 if Nkind (Mode) = N_Identifier then
2524 if Chars (Mode) = Name_In_Out then
2525 Check_Duplicate_Mode (Mode, In_Out_Seen);
2526 Check_Mode_Restriction_In_Function (Mode);
2528 elsif Chars (Mode) = Name_Input then
2529 Check_Duplicate_Mode (Mode, Input_Seen);
2531 elsif Chars (Mode) = Name_Output then
2532 Check_Duplicate_Mode (Mode, Output_Seen);
2533 Check_Mode_Restriction_In_Function (Mode);
2535 elsif Chars (Mode) = Name_Proof_In then
2536 Check_Duplicate_Mode (Mode, Proof_Seen);
2539 SPARK_Msg_N ("invalid mode selector", Mode);
2543 SPARK_Msg_N ("invalid mode selector", Mode);
2546 -- Items in a moded list appear as a collection of
2547 -- expressions. Reuse the existing machinery to analyze
2551 (List => Expression (Assoc),
2552 Global_Mode => Chars (Mode));
2560 raise Program_Error;
2563 -- Any other attempt to declare a global item is illegal. This is a
2564 -- syntax error, always report.
2567 Error_Msg_N ("malformed global list", List);
2569 end Analyze_Global_List;
2573 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2575 Restore_Scope : Boolean := False;
2577 -- Start of processing for Analyze_Global_In_Decl_Part
2580 -- Do not analyze the pragma multiple times
2582 if Is_Analyzed_Pragma (N) then
2586 -- There is nothing to be done for a null global list
2588 if Nkind (Items) = N_Null then
2589 Set_Analyzed (Items);
2591 -- Analyze the various forms of global lists and items. Note that some
2592 -- of these may be malformed in which case the analysis emits error
2596 -- When pragma [Refined_]Global appears on a single concurrent type,
2597 -- it is relocated to the anonymous object.
2599 if Is_Single_Concurrent_Object (Spec_Id) then
2602 -- Ensure that the formal parameters are visible when processing an
2603 -- item. This falls out of the general rule of aspects pertaining to
2604 -- subprogram declarations.
2606 elsif not In_Open_Scopes (Spec_Id) then
2607 Restore_Scope := True;
2608 Push_Scope (Spec_Id);
2610 if Ekind (Spec_Id) = E_Task_Type then
2611 if Has_Discriminants (Spec_Id) then
2612 Install_Discriminants (Spec_Id);
2615 elsif Is_Generic_Subprogram (Spec_Id) then
2616 Install_Generic_Formals (Spec_Id);
2619 Install_Formals (Spec_Id);
2623 Analyze_Global_List (Items);
2625 if Restore_Scope then
2630 -- Ensure that a state and a corresponding constituent do not appear
2631 -- together in pragma [Refined_]Global.
2633 Check_State_And_Constituent_Use
2634 (States => States_Seen,
2635 Constits => Constits_Seen,
2638 Set_Is_Analyzed_Pragma (N);
2639 end Analyze_Global_In_Decl_Part;
2641 --------------------------------------------
2642 -- Analyze_Initial_Condition_In_Decl_Part --
2643 --------------------------------------------
2645 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2646 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2647 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2648 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2650 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2653 -- Do not analyze the pragma multiple times
2655 if Is_Analyzed_Pragma (N) then
2659 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2660 -- analysis of the pragma, the Ghost mode at point of declaration and
2661 -- point of analysis may not necessarily be the same. Use the mode in
2662 -- effect at the point of declaration.
2666 -- The expression is preanalyzed because it has not been moved to its
2667 -- final place yet. A direct analysis may generate side effects and this
2668 -- is not desired at this point.
2670 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2671 Ghost_Mode := Save_Ghost_Mode;
2673 Set_Is_Analyzed_Pragma (N);
2674 end Analyze_Initial_Condition_In_Decl_Part;
2676 --------------------------------------
2677 -- Analyze_Initializes_In_Decl_Part --
2678 --------------------------------------
2680 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2681 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2682 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2684 Constits_Seen : Elist_Id := No_Elist;
2685 -- A list containing the entities of all constituents processed so far.
2686 -- It aids in detecting illegal usage of a state and a corresponding
2687 -- constituent in pragma Initializes.
2689 Items_Seen : Elist_Id := No_Elist;
2690 -- A list of all initialization items processed so far. This list is
2691 -- used to detect duplicate items.
2693 Non_Null_Seen : Boolean := False;
2694 Null_Seen : Boolean := False;
2695 -- Flags used to check the legality of a null initialization list
2697 States_And_Objs : Elist_Id := No_Elist;
2698 -- A list of all abstract states and objects declared in the visible
2699 -- declarations of the related package. This list is used to detect the
2700 -- legality of initialization items.
2702 States_Seen : Elist_Id := No_Elist;
2703 -- A list containing the entities of all states processed so far. It
2704 -- helps in detecting illegal usage of a state and a corresponding
2705 -- constituent in pragma Initializes.
2707 procedure Analyze_Initialization_Item (Item : Node_Id);
2708 -- Verify the legality of a single initialization item
2710 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2711 -- Verify the legality of a single initialization item followed by a
2712 -- list of input items.
2714 procedure Collect_States_And_Objects;
2715 -- Inspect the visible declarations of the related package and gather
2716 -- the entities of all abstract states and objects in States_And_Objs.
2718 ---------------------------------
2719 -- Analyze_Initialization_Item --
2720 ---------------------------------
2722 procedure Analyze_Initialization_Item (Item : Node_Id) is
2723 Item_Id : Entity_Id;
2726 -- Null initialization list
2728 if Nkind (Item) = N_Null then
2730 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2732 elsif Non_Null_Seen then
2734 ("cannot mix null and non-null initialization items", Item);
2739 -- Initialization item
2742 Non_Null_Seen := True;
2746 ("cannot mix null and non-null initialization items", Item);
2750 Resolve_State (Item);
2752 if Is_Entity_Name (Item) then
2753 Item_Id := Entity_Of (Item);
2755 if Ekind_In (Item_Id, E_Abstract_State,
2759 -- The state or variable must be declared in the visible
2760 -- declarations of the package (SPARK RM 7.1.5(7)).
2762 if not Contains (States_And_Objs, Item_Id) then
2763 Error_Msg_Name_1 := Chars (Pack_Id);
2765 ("initialization item & must appear in the visible "
2766 & "declarations of package %", Item, Item_Id);
2768 -- Detect a duplicate use of the same initialization item
2769 -- (SPARK RM 7.1.5(5)).
2771 elsif Contains (Items_Seen, Item_Id) then
2772 SPARK_Msg_N ("duplicate initialization item", Item);
2774 -- The item is legal, add it to the list of processed states
2778 Append_New_Elmt (Item_Id, Items_Seen);
2780 if Ekind (Item_Id) = E_Abstract_State then
2781 Append_New_Elmt (Item_Id, States_Seen);
2784 if Present (Encapsulating_State (Item_Id)) then
2785 Append_New_Elmt (Item_Id, Constits_Seen);
2789 -- The item references something that is not a state or object
2790 -- (SPARK RM 7.1.5(3)).
2794 ("initialization item must denote object or state", Item);
2797 -- Some form of illegal construct masquerading as a name
2798 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2802 ("initialization item must denote object or state", Item);
2805 end Analyze_Initialization_Item;
2807 ---------------------------------------------
2808 -- Analyze_Initialization_Item_With_Inputs --
2809 ---------------------------------------------
2811 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2812 Inputs_Seen : Elist_Id := No_Elist;
2813 -- A list of all inputs processed so far. This list is used to detect
2814 -- duplicate uses of an input.
2816 Non_Null_Seen : Boolean := False;
2817 Null_Seen : Boolean := False;
2818 -- Flags used to check the legality of an input list
2820 procedure Analyze_Input_Item (Input : Node_Id);
2821 -- Verify the legality of a single input item
2823 ------------------------
2824 -- Analyze_Input_Item --
2825 ------------------------
2827 procedure Analyze_Input_Item (Input : Node_Id) is
2828 Input_Id : Entity_Id;
2829 Input_OK : Boolean := True;
2834 if Nkind (Input) = N_Null then
2837 ("multiple null initializations not allowed", Item);
2839 elsif Non_Null_Seen then
2841 ("cannot mix null and non-null initialization item", Item);
2849 Non_Null_Seen := True;
2853 ("cannot mix null and non-null initialization item", Item);
2857 Resolve_State (Input);
2859 if Is_Entity_Name (Input) then
2860 Input_Id := Entity_Of (Input);
2862 if Ekind_In (Input_Id, E_Abstract_State,
2864 E_Generic_In_Out_Parameter,
2865 E_Generic_In_Parameter,
2871 -- The input cannot denote states or objects declared
2872 -- within the related package (SPARK RM 7.1.5(4)).
2874 if Within_Scope (Input_Id, Current_Scope) then
2876 -- Do not consider generic formal parameters or their
2877 -- respective mappings to generic formals. Even though
2878 -- the formals appear within the scope of the package,
2879 -- it is allowed for an initialization item to depend
2880 -- on an input item.
2882 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2883 E_Generic_In_Parameter)
2887 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2888 and then Present (Corresponding_Generic_Association
2889 (Declaration_Node (Input_Id)))
2895 Error_Msg_Name_1 := Chars (Pack_Id);
2897 ("input item & cannot denote a visible object or "
2898 & "state of package %", Input, Input_Id);
2902 -- Detect a duplicate use of the same input item
2903 -- (SPARK RM 7.1.5(5)).
2905 if Contains (Inputs_Seen, Input_Id) then
2907 SPARK_Msg_N ("duplicate input item", Input);
2910 -- Input is legal, add it to the list of processed inputs
2913 Append_New_Elmt (Input_Id, Inputs_Seen);
2915 if Ekind (Input_Id) = E_Abstract_State then
2916 Append_New_Elmt (Input_Id, States_Seen);
2919 if Ekind_In (Input_Id, E_Abstract_State,
2922 and then Present (Encapsulating_State (Input_Id))
2924 Append_New_Elmt (Input_Id, Constits_Seen);
2928 -- The input references something that is not a state or an
2929 -- object (SPARK RM 7.1.5(3)).
2933 ("input item must denote object or state", Input);
2936 -- Some form of illegal construct masquerading as a name
2937 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2941 ("input item must denote object or state", Input);
2944 end Analyze_Input_Item;
2948 Inputs : constant Node_Id := Expression (Item);
2952 Name_Seen : Boolean := False;
2953 -- A flag used to detect multiple item names
2955 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2958 -- Inspect the name of an item with inputs
2960 Elmt := First (Choices (Item));
2961 while Present (Elmt) loop
2963 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2966 Analyze_Initialization_Item (Elmt);
2972 -- Multiple input items appear as an aggregate
2974 if Nkind (Inputs) = N_Aggregate then
2975 if Present (Expressions (Inputs)) then
2976 Input := First (Expressions (Inputs));
2977 while Present (Input) loop
2978 Analyze_Input_Item (Input);
2983 if Present (Component_Associations (Inputs)) then
2985 ("inputs must appear in named association form", Inputs);
2988 -- Single input item
2991 Analyze_Input_Item (Inputs);
2993 end Analyze_Initialization_Item_With_Inputs;
2995 --------------------------------
2996 -- Collect_States_And_Objects --
2997 --------------------------------
2999 procedure Collect_States_And_Objects is
3000 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3004 -- Collect the abstract states defined in the package (if any)
3006 if Present (Abstract_States (Pack_Id)) then
3007 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3010 -- Collect all objects the appear in the visible declarations of the
3013 if Present (Visible_Declarations (Pack_Spec)) then
3014 Decl := First (Visible_Declarations (Pack_Spec));
3015 while Present (Decl) loop
3016 if Comes_From_Source (Decl)
3017 and then Nkind (Decl) = N_Object_Declaration
3019 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3025 end Collect_States_And_Objects;
3029 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3032 -- Start of processing for Analyze_Initializes_In_Decl_Part
3035 -- Do not analyze the pragma multiple times
3037 if Is_Analyzed_Pragma (N) then
3041 -- Nothing to do when the initialization list is empty
3043 if Nkind (Inits) = N_Null then
3047 -- Single and multiple initialization clauses appear as an aggregate. If
3048 -- this is not the case, then either the parser or the analysis of the
3049 -- pragma failed to produce an aggregate.
3051 pragma Assert (Nkind (Inits) = N_Aggregate);
3053 -- Initialize the various lists used during analysis
3055 Collect_States_And_Objects;
3057 if Present (Expressions (Inits)) then
3058 Init := First (Expressions (Inits));
3059 while Present (Init) loop
3060 Analyze_Initialization_Item (Init);
3065 if Present (Component_Associations (Inits)) then
3066 Init := First (Component_Associations (Inits));
3067 while Present (Init) loop
3068 Analyze_Initialization_Item_With_Inputs (Init);
3073 -- Ensure that a state and a corresponding constituent do not appear
3074 -- together in pragma Initializes.
3076 Check_State_And_Constituent_Use
3077 (States => States_Seen,
3078 Constits => Constits_Seen,
3081 Set_Is_Analyzed_Pragma (N);
3082 end Analyze_Initializes_In_Decl_Part;
3084 ---------------------
3085 -- Analyze_Part_Of --
3086 ---------------------
3088 procedure Analyze_Part_Of
3090 Item_Id : Entity_Id;
3092 Encap_Id : out Entity_Id;
3093 Legal : out Boolean)
3095 Encap_Typ : Entity_Id;
3096 Item_Decl : Node_Id;
3097 Pack_Id : Entity_Id;
3098 Placement : State_Space_Kind;
3099 Parent_Unit : Entity_Id;
3102 -- Assume that the indicator is illegal
3107 if Nkind_In (Encap, N_Expanded_Name,
3109 N_Selected_Component)
3112 Resolve_State (Encap);
3114 Encap_Id := Entity (Encap);
3116 -- The encapsulator is an abstract state
3118 if Ekind (Encap_Id) = E_Abstract_State then
3121 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3123 elsif Is_Single_Concurrent_Object (Encap_Id) then
3126 -- Otherwise the encapsulator is not a legal choice
3130 ("indicator Part_Of must denote abstract state, single "
3131 & "protected type or single task type", Encap);
3135 -- This is a syntax error, always report
3139 ("indicator Part_Of must denote abstract state, single protected "
3140 & "type or single task type", Encap);
3144 -- Catch a case where indicator Part_Of denotes the abstract view of a
3145 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3147 if From_Limited_With (Encap_Id)
3148 and then Present (Non_Limited_View (Encap_Id))
3149 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3151 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3152 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3156 -- The encapsulator is an abstract state
3158 if Ekind (Encap_Id) = E_Abstract_State then
3160 -- Determine where the object, package instantiation or state lives
3161 -- with respect to the enclosing packages or package bodies.
3163 Find_Placement_In_State_Space
3164 (Item_Id => Item_Id,
3165 Placement => Placement,
3166 Pack_Id => Pack_Id);
3168 -- The item appears in a non-package construct with a declarative
3169 -- part (subprogram, block, etc). As such, the item is not allowed
3170 -- to be a part of an encapsulating state because the item is not
3173 if Placement = Not_In_Package then
3175 ("indicator Part_Of cannot appear in this context "
3176 & "(SPARK RM 7.2.6(5))", Indic);
3177 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3179 ("\& is not part of the hidden state of package %",
3182 -- The item appears in the visible state space of some package. In
3183 -- general this scenario does not warrant Part_Of except when the
3184 -- package is a private child unit and the encapsulating state is
3185 -- declared in a parent unit or a public descendant of that parent
3188 elsif Placement = Visible_State_Space then
3189 if Is_Child_Unit (Pack_Id)
3190 and then Is_Private_Descendant (Pack_Id)
3192 -- A variable or state abstraction which is part of the visible
3193 -- state of a private child unit (or one of its public
3194 -- descendants) must have its Part_Of indicator specified. The
3195 -- Part_Of indicator must denote a state abstraction declared
3196 -- by either the parent unit of the private unit or by a public
3197 -- descendant of that parent unit.
3199 -- Find nearest private ancestor (which can be the current unit
3202 Parent_Unit := Pack_Id;
3203 while Present (Parent_Unit) loop
3206 (Parent (Unit_Declaration_Node (Parent_Unit)));
3207 Parent_Unit := Scope (Parent_Unit);
3210 Parent_Unit := Scope (Parent_Unit);
3212 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3214 ("indicator Part_Of must denote abstract state or public "
3215 & "descendant of & (SPARK RM 7.2.6(3))",
3216 Indic, Parent_Unit);
3218 elsif Scope (Encap_Id) = Parent_Unit
3220 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3221 and then not Is_Private_Descendant (Scope (Encap_Id)))
3227 ("indicator Part_Of must denote abstract state or public "
3228 & "descendant of & (SPARK RM 7.2.6(3))",
3229 Indic, Parent_Unit);
3232 -- Indicator Part_Of is not needed when the related package is not
3233 -- a private child unit or a public descendant thereof.
3237 ("indicator Part_Of cannot appear in this context "
3238 & "(SPARK RM 7.2.6(5))", Indic);
3239 Error_Msg_Name_1 := Chars (Pack_Id);
3241 ("\& is declared in the visible part of package %",
3245 -- When the item appears in the private state space of a package, the
3246 -- encapsulating state must be declared in the same package.
3248 elsif Placement = Private_State_Space then
3249 if Scope (Encap_Id) /= Pack_Id then
3251 ("indicator Part_Of must designate an abstract state of "
3252 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3253 Error_Msg_Name_1 := Chars (Pack_Id);
3255 ("\& is declared in the private part of package %",
3259 -- Items declared in the body state space of a package do not need
3260 -- Part_Of indicators as the refinement has already been seen.
3264 ("indicator Part_Of cannot appear in this context "
3265 & "(SPARK RM 7.2.6(5))", Indic);
3267 if Scope (Encap_Id) = Pack_Id then
3268 Error_Msg_Name_1 := Chars (Pack_Id);
3270 ("\& is declared in the body of package %", Indic, Item_Id);
3274 -- The encapsulator is a single concurrent type
3277 Encap_Typ := Etype (Encap_Id);
3279 -- Only abstract states and variables can act as constituents of an
3280 -- encapsulating single concurrent type.
3282 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3285 -- The constituent is a constant
3287 elsif Ekind (Item_Id) = E_Constant then
3288 Error_Msg_Name_1 := Chars (Encap_Id);
3290 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3291 & "single protected type %"), Indic, Item_Id);
3293 -- The constituent is a package instantiation
3296 Error_Msg_Name_1 := Chars (Encap_Id);
3298 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3299 & "constituent of single protected type %"), Indic, Item_Id);
3302 -- When the item denotes an abstract state of a nested package, use
3303 -- the declaration of the package to detect proper placement.
3308 -- with Abstract_State => (State with Part_Of => T)
3310 if Ekind (Item_Id) = E_Abstract_State then
3311 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3313 Item_Decl := Declaration_Node (Item_Id);
3316 -- Both the item and its encapsulating single concurrent type must
3317 -- appear in the same declarative region (SPARK RM 9.3). Note that
3318 -- privacy is ignored.
3320 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3321 Error_Msg_Name_1 := Chars (Encap_Id);
3323 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3324 & "immediately within the same region as single protected "
3325 & "type %"), Indic, Item_Id);
3330 end Analyze_Part_Of;
3332 ----------------------------------
3333 -- Analyze_Part_Of_In_Decl_Part --
3334 ----------------------------------
3336 procedure Analyze_Part_Of_In_Decl_Part
3338 Freeze_Id : Entity_Id := Empty)
3340 Encap : constant Node_Id :=
3341 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3342 Errors : constant Nat := Serious_Errors_Detected;
3343 Var_Decl : constant Node_Id := Find_Related_Context (N);
3344 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3345 Constits : Elist_Id;
3346 Encap_Id : Entity_Id;
3350 -- Detect any discrepancies between the placement of the variable with
3351 -- respect to general state space and the encapsulating state or single
3358 Encap_Id => Encap_Id,
3361 -- The Part_Of indicator turns the variable into a constituent of the
3362 -- encapsulating state or single concurrent type.
3365 pragma Assert (Present (Encap_Id));
3366 Constits := Part_Of_Constituents (Encap_Id);
3368 if No (Constits) then
3369 Constits := New_Elmt_List;
3370 Set_Part_Of_Constituents (Encap_Id, Constits);
3373 Append_Elmt (Var_Id, Constits);
3374 Set_Encapsulating_State (Var_Id, Encap_Id);
3377 -- Emit a clarification message when the encapsulator is undefined,
3378 -- possibly due to contract "freezing".
3380 if Errors /= Serious_Errors_Detected
3381 and then Present (Freeze_Id)
3382 and then Has_Undefined_Reference (Encap)
3384 Contract_Freeze_Error (Var_Id, Freeze_Id);
3386 end Analyze_Part_Of_In_Decl_Part;
3388 --------------------
3389 -- Analyze_Pragma --
3390 --------------------
3392 procedure Analyze_Pragma (N : Node_Id) is
3393 Loc : constant Source_Ptr := Sloc (N);
3394 Prag_Id : Pragma_Id;
3397 -- Name of the source pragma, or name of the corresponding aspect for
3398 -- pragmas which originate in a source aspect. In the latter case, the
3399 -- name may be different from the pragma name.
3401 Pragma_Exit : exception;
3402 -- This exception is used to exit pragma processing completely. It
3403 -- is used when an error is detected, and no further processing is
3404 -- required. It is also used if an earlier error has left the tree in
3405 -- a state where the pragma should not be processed.
3408 -- Number of pragma argument associations
3414 -- First four pragma arguments (pragma argument association nodes, or
3415 -- Empty if the corresponding argument does not exist).
3417 type Name_List is array (Natural range <>) of Name_Id;
3418 type Args_List is array (Natural range <>) of Node_Id;
3419 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3421 -----------------------
3422 -- Local Subprograms --
3423 -----------------------
3425 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3426 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3427 -- get the given string argument, and place it in Name_Buffer, adding
3428 -- leading and trailing asterisks if they are not already present. The
3429 -- caller has already checked that Arg is a static string expression.
3431 procedure Ada_2005_Pragma;
3432 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3433 -- Ada 95 mode, these are implementation defined pragmas, so should be
3434 -- caught by the No_Implementation_Pragmas restriction.
3436 procedure Ada_2012_Pragma;
3437 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3438 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3439 -- should be caught by the No_Implementation_Pragmas restriction.
3441 procedure Analyze_Depends_Global
3442 (Spec_Id : out Entity_Id;
3443 Subp_Decl : out Node_Id;
3444 Legal : out Boolean);
3445 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3446 -- legality of the placement and related context of the pragma. Spec_Id
3447 -- is the entity of the related subprogram. Subp_Decl is the declaration
3448 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3450 procedure Analyze_If_Present (Id : Pragma_Id);
3451 -- Inspect the remainder of the list containing pragma N and look for
3452 -- a pragma that matches Id. If found, analyze the pragma.
3454 procedure Analyze_Pre_Post_Condition;
3455 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3457 procedure Analyze_Refined_Depends_Global_Post
3458 (Spec_Id : out Entity_Id;
3459 Body_Id : out Entity_Id;
3460 Legal : out Boolean);
3461 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3462 -- Refined_Global and Refined_Post. Verify the legality of the placement
3463 -- and related context of the pragma. Spec_Id is the entity of the
3464 -- related subprogram. Body_Id is the entity of the subprogram body.
3465 -- Flag Legal is set when the pragma is legal.
3467 procedure Check_Ada_83_Warning;
3468 -- Issues a warning message for the current pragma if operating in Ada
3469 -- 83 mode (used for language pragmas that are not a standard part of
3470 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3473 procedure Check_Arg_Count (Required : Nat);
3474 -- Check argument count for pragma is equal to given parameter. If not,
3475 -- then issue an error message and raise Pragma_Exit.
3477 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3478 -- Arg which can either be a pragma argument association, in which case
3479 -- the check is applied to the expression of the association or an
3480 -- expression directly.
3482 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3483 -- Check that an argument has the right form for an EXTERNAL_NAME
3484 -- parameter of an extended import/export pragma. The rule is that the
3485 -- name must be an identifier or string literal (in Ada 83 mode) or a
3486 -- static string expression (in Ada 95 mode).
3488 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3489 -- Check the specified argument Arg to make sure that it is an
3490 -- identifier. If not give error and raise Pragma_Exit.
3492 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3493 -- Check the specified argument Arg to make sure that it is an integer
3494 -- literal. If not give error and raise Pragma_Exit.
3496 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3497 -- Check the specified argument Arg to make sure that it has the proper
3498 -- syntactic form for a local name and meets the semantic requirements
3499 -- for a local name. The local name is analyzed as part of the
3500 -- processing for this call. In addition, the local name is required
3501 -- to represent an entity at the library level.
3503 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3504 -- Check the specified argument Arg to make sure that it has the proper
3505 -- syntactic form for a local name and meets the semantic requirements
3506 -- for a local name. The local name is analyzed as part of the
3507 -- processing for this call.
3509 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3510 -- Check the specified argument Arg to make sure that it is a valid
3511 -- locking policy name. If not give error and raise Pragma_Exit.
3513 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3514 -- Check the specified argument Arg to make sure that it is a valid
3515 -- elaboration policy name. If not give error and raise Pragma_Exit.
3517 procedure Check_Arg_Is_One_Of
3520 procedure Check_Arg_Is_One_Of
3522 N1, N2, N3 : Name_Id);
3523 procedure Check_Arg_Is_One_Of
3525 N1, N2, N3, N4 : Name_Id);
3526 procedure Check_Arg_Is_One_Of
3528 N1, N2, N3, N4, N5 : Name_Id);
3529 -- Check the specified argument Arg to make sure that it is an
3530 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3531 -- present). If not then give error and raise Pragma_Exit.
3533 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3534 -- Check the specified argument Arg to make sure that it is a valid
3535 -- queuing policy name. If not give error and raise Pragma_Exit.
3537 procedure Check_Arg_Is_OK_Static_Expression
3539 Typ : Entity_Id := Empty);
3540 -- Check the specified argument Arg to make sure that it is a static
3541 -- expression of the given type (i.e. it will be analyzed and resolved
3542 -- using this type, which can be any valid argument to Resolve, e.g.
3543 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3544 -- Typ is left Empty, then any static expression is allowed. Includes
3545 -- checking that the argument does not raise Constraint_Error.
3547 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3548 -- Check the specified argument Arg to make sure that it is a valid task
3549 -- dispatching policy name. If not give error and raise Pragma_Exit.
3551 procedure Check_Arg_Order (Names : Name_List);
3552 -- Checks for an instance of two arguments with identifiers for the
3553 -- current pragma which are not in the sequence indicated by Names,
3554 -- and if so, generates a fatal message about bad order of arguments.
3556 procedure Check_At_Least_N_Arguments (N : Nat);
3557 -- Check there are at least N arguments present
3559 procedure Check_At_Most_N_Arguments (N : Nat);
3560 -- Check there are no more than N arguments present
3562 procedure Check_Component
3565 In_Variant_Part : Boolean := False);
3566 -- Examine an Unchecked_Union component for correct use of per-object
3567 -- constrained subtypes, and for restrictions on finalizable components.
3568 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3569 -- should be set when Comp comes from a record variant.
3571 procedure Check_Duplicate_Pragma (E : Entity_Id);
3572 -- Check if a rep item of the same name as the current pragma is already
3573 -- chained as a rep pragma to the given entity. If so give a message
3574 -- about the duplicate, and then raise Pragma_Exit so does not return.
3575 -- Note that if E is a type, then this routine avoids flagging a pragma
3576 -- which applies to a parent type from which E is derived.
3578 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3579 -- Nam is an N_String_Literal node containing the external name set by
3580 -- an Import or Export pragma (or extended Import or Export pragma).
3581 -- This procedure checks for possible duplications if this is the export
3582 -- case, and if found, issues an appropriate error message.
3584 procedure Check_Expr_Is_OK_Static_Expression
3586 Typ : Entity_Id := Empty);
3587 -- Check the specified expression Expr to make sure that it is a static
3588 -- expression of the given type (i.e. it will be analyzed and resolved
3589 -- using this type, which can be any valid argument to Resolve, e.g.
3590 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3591 -- Typ is left Empty, then any static expression is allowed. Includes
3592 -- checking that the expression does not raise Constraint_Error.
3594 procedure Check_First_Subtype (Arg : Node_Id);
3595 -- Checks that Arg, whose expression is an entity name, references a
3598 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3599 -- Checks that the given argument has an identifier, and if so, requires
3600 -- it to match the given identifier name. If there is no identifier, or
3601 -- a non-matching identifier, then an error message is given and
3602 -- Pragma_Exit is raised.
3604 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3605 -- Checks that the given argument has an identifier, and if so, requires
3606 -- it to match one of the given identifier names. If there is no
3607 -- identifier, or a non-matching identifier, then an error message is
3608 -- given and Pragma_Exit is raised.
3610 procedure Check_In_Main_Program;
3611 -- Common checks for pragmas that appear within a main program
3612 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3614 procedure Check_Interrupt_Or_Attach_Handler;
3615 -- Common processing for first argument of pragma Interrupt_Handler or
3616 -- pragma Attach_Handler.
3618 procedure Check_Loop_Pragma_Placement;
3619 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3620 -- appear immediately within a construct restricted to loops, and that
3621 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3623 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3624 -- Check that pragma appears in a declarative part, or in a package
3625 -- specification, i.e. that it does not occur in a statement sequence
3628 procedure Check_No_Identifier (Arg : Node_Id);
3629 -- Checks that the given argument does not have an identifier. If
3630 -- an identifier is present, then an error message is issued, and
3631 -- Pragma_Exit is raised.
3633 procedure Check_No_Identifiers;
3634 -- Checks that none of the arguments to the pragma has an identifier.
3635 -- If any argument has an identifier, then an error message is issued,
3636 -- and Pragma_Exit is raised.
3638 procedure Check_No_Link_Name;
3639 -- Checks that no link name is specified
3641 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3642 -- Checks if the given argument has an identifier, and if so, requires
3643 -- it to match the given identifier name. If there is a non-matching
3644 -- identifier, then an error message is given and Pragma_Exit is raised.
3646 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3647 -- Checks if the given argument has an identifier, and if so, requires
3648 -- it to match the given identifier name. If there is a non-matching
3649 -- identifier, then an error message is given and Pragma_Exit is raised.
3650 -- In this version of the procedure, the identifier name is given as
3651 -- a string with lower case letters.
3653 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3654 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3655 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3656 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3657 -- is an OK static boolean expression. Emit an error if this is not the
3660 procedure Check_Static_Constraint (Constr : Node_Id);
3661 -- Constr is a constraint from an N_Subtype_Indication node from a
3662 -- component constraint in an Unchecked_Union type. This routine checks
3663 -- that the constraint is static as required by the restrictions for
3666 procedure Check_Valid_Configuration_Pragma;
3667 -- Legality checks for placement of a configuration pragma
3669 procedure Check_Valid_Library_Unit_Pragma;
3670 -- Legality checks for library unit pragmas. A special case arises for
3671 -- pragmas in generic instances that come from copies of the original
3672 -- library unit pragmas in the generic templates. In the case of other
3673 -- than library level instantiations these can appear in contexts which
3674 -- would normally be invalid (they only apply to the original template
3675 -- and to library level instantiations), and they are simply ignored,
3676 -- which is implemented by rewriting them as null statements.
3678 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3679 -- Check an Unchecked_Union variant for lack of nested variants and
3680 -- presence of at least one component. UU_Typ is the related Unchecked_
3683 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3684 -- Subsidiary routine to the processing of pragmas Abstract_State,
3685 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3686 -- Refined_Global and Refined_State. Transform argument Arg into
3687 -- an aggregate if not one already. N_Null is never transformed.
3688 -- Arg may denote an aspect specification or a pragma argument
3691 procedure Error_Pragma (Msg : String);
3692 pragma No_Return (Error_Pragma);
3693 -- Outputs error message for current pragma. The message contains a %
3694 -- that will be replaced with the pragma name, and the flag is placed
3695 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3696 -- calls Fix_Error (see spec of that procedure for details).
3698 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3699 pragma No_Return (Error_Pragma_Arg);
3700 -- Outputs error message for current pragma. The message may contain
3701 -- a % that will be replaced with the pragma name. The parameter Arg
3702 -- may either be a pragma argument association, in which case the flag
3703 -- is placed on the expression of this association, or an expression,
3704 -- in which case the flag is placed directly on the expression. The
3705 -- message is placed using Error_Msg_N, so the message may also contain
3706 -- an & insertion character which will reference the given Arg value.
3707 -- After placing the message, Pragma_Exit is raised. Note: this routine
3708 -- calls Fix_Error (see spec of that procedure for details).
3710 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3711 pragma No_Return (Error_Pragma_Arg);
3712 -- Similar to above form of Error_Pragma_Arg except that two messages
3713 -- are provided, the second is a continuation comment starting with \.
3715 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3716 pragma No_Return (Error_Pragma_Arg_Ident);
3717 -- Outputs error message for current pragma. The message may contain a %
3718 -- that will be replaced with the pragma name. The parameter Arg must be
3719 -- a pragma argument association with a non-empty identifier (i.e. its
3720 -- Chars field must be set), and the error message is placed on the
3721 -- identifier. The message is placed using Error_Msg_N so the message
3722 -- may also contain an & insertion character which will reference
3723 -- the identifier. After placing the message, Pragma_Exit is raised.
3724 -- Note: this routine calls Fix_Error (see spec of that procedure for
3727 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3728 pragma No_Return (Error_Pragma_Ref);
3729 -- Outputs error message for current pragma. The message may contain
3730 -- a % that will be replaced with the pragma name. The parameter Ref
3731 -- must be an entity whose name can be referenced by & and sloc by #.
3732 -- After placing the message, Pragma_Exit is raised. Note: this routine
3733 -- calls Fix_Error (see spec of that procedure for details).
3735 function Find_Lib_Unit_Name return Entity_Id;
3736 -- Used for a library unit pragma to find the entity to which the
3737 -- library unit pragma applies, returns the entity found.
3739 procedure Find_Program_Unit_Name (Id : Node_Id);
3740 -- If the pragma is a compilation unit pragma, the id must denote the
3741 -- compilation unit in the same compilation, and the pragma must appear
3742 -- in the list of preceding or trailing pragmas. If it is a program
3743 -- unit pragma that is not a compilation unit pragma, then the
3744 -- identifier must be visible.
3746 function Find_Unique_Parameterless_Procedure
3748 Arg : Node_Id) return Entity_Id;
3749 -- Used for a procedure pragma to find the unique parameterless
3750 -- procedure identified by Name, returns it if it exists, otherwise
3751 -- errors out and uses Arg as the pragma argument for the message.
3753 function Fix_Error (Msg : String) return String;
3754 -- This is called prior to issuing an error message. Msg is the normal
3755 -- error message issued in the pragma case. This routine checks for the
3756 -- case of a pragma coming from an aspect in the source, and returns a
3757 -- message suitable for the aspect case as follows:
3759 -- Each substring "pragma" is replaced by "aspect"
3761 -- If "argument of" is at the start of the error message text, it is
3762 -- replaced by "entity for".
3764 -- If "argument" is at the start of the error message text, it is
3765 -- replaced by "entity".
3767 -- So for example, "argument of pragma X must be discrete type"
3768 -- returns "entity for aspect X must be a discrete type".
3770 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3771 -- be different from the pragma name). If the current pragma results
3772 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3773 -- original pragma name.
3775 procedure Gather_Associations
3777 Args : out Args_List);
3778 -- This procedure is used to gather the arguments for a pragma that
3779 -- permits arbitrary ordering of parameters using the normal rules
3780 -- for named and positional parameters. The Names argument is a list
3781 -- of Name_Id values that corresponds to the allowed pragma argument
3782 -- association identifiers in order. The result returned in Args is
3783 -- a list of corresponding expressions that are the pragma arguments.
3784 -- Note that this is a list of expressions, not of pragma argument
3785 -- associations (Gather_Associations has completely checked all the
3786 -- optional identifiers when it returns). An entry in Args is Empty
3787 -- on return if the corresponding argument is not present.
3789 procedure GNAT_Pragma;
3790 -- Called for all GNAT defined pragmas to check the relevant restriction
3791 -- (No_Implementation_Pragmas).
3793 function Is_Before_First_Decl
3794 (Pragma_Node : Node_Id;
3795 Decls : List_Id) return Boolean;
3796 -- Return True if Pragma_Node is before the first declarative item in
3797 -- Decls where Decls is the list of declarative items.
3799 function Is_Configuration_Pragma return Boolean;
3800 -- Determines if the placement of the current pragma is appropriate
3801 -- for a configuration pragma.
3803 function Is_In_Context_Clause return Boolean;
3804 -- Returns True if pragma appears within the context clause of a unit,
3805 -- and False for any other placement (does not generate any messages).
3807 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3808 -- Analyzes the argument, and determines if it is a static string
3809 -- expression, returns True if so, False if non-static or not String.
3810 -- A special case is that a string literal returns True in Ada 83 mode
3811 -- (which has no such thing as static string expressions). Note that
3812 -- the call analyzes its argument, so this cannot be used for the case
3813 -- where an identifier might not be declared.
3815 procedure Pragma_Misplaced;
3816 pragma No_Return (Pragma_Misplaced);
3817 -- Issue fatal error message for misplaced pragma
3819 procedure Process_Atomic_Independent_Shared_Volatile;
3820 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3821 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3822 -- and treated as being identical in effect to pragma Atomic.
3824 procedure Process_Compile_Time_Warning_Or_Error;
3825 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3827 procedure Process_Convention
3828 (C : out Convention_Id;
3829 Ent : out Entity_Id);
3830 -- Common processing for Convention, Interface, Import and Export.
3831 -- Checks first two arguments of pragma, and sets the appropriate
3832 -- convention value in the specified entity or entities. On return
3833 -- C is the convention, Ent is the referenced entity.
3835 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3836 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3837 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3839 procedure Process_Extended_Import_Export_Object_Pragma
3840 (Arg_Internal : Node_Id;
3841 Arg_External : Node_Id;
3842 Arg_Size : Node_Id);
3843 -- Common processing for the pragmas Import/Export_Object. The three
3844 -- arguments correspond to the three named parameters of the pragmas. An
3845 -- argument is empty if the corresponding parameter is not present in
3848 procedure Process_Extended_Import_Export_Internal_Arg
3849 (Arg_Internal : Node_Id := Empty);
3850 -- Common processing for all extended Import and Export pragmas. The
3851 -- argument is the pragma parameter for the Internal argument. If
3852 -- Arg_Internal is empty or inappropriate, an error message is posted.
3853 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3854 -- set to identify the referenced entity.
3856 procedure Process_Extended_Import_Export_Subprogram_Pragma
3857 (Arg_Internal : Node_Id;
3858 Arg_External : Node_Id;
3859 Arg_Parameter_Types : Node_Id;
3860 Arg_Result_Type : Node_Id := Empty;
3861 Arg_Mechanism : Node_Id;
3862 Arg_Result_Mechanism : Node_Id := Empty);
3863 -- Common processing for all extended Import and Export pragmas applying
3864 -- to subprograms. The caller omits any arguments that do not apply to
3865 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3866 -- only in the Import_Function and Export_Function cases). The argument
3867 -- names correspond to the allowed pragma association identifiers.
3869 procedure Process_Generic_List;
3870 -- Common processing for Share_Generic and Inline_Generic
3872 procedure Process_Import_Or_Interface;
3873 -- Common processing for Import or Interface
3875 procedure Process_Import_Predefined_Type;
3876 -- Processing for completing a type with pragma Import. This is used
3877 -- to declare types that match predefined C types, especially for cases
3878 -- without corresponding Ada predefined type.
3880 type Inline_Status is (Suppressed, Disabled, Enabled);
3881 -- Inline status of a subprogram, indicated as follows:
3882 -- Suppressed: inlining is suppressed for the subprogram
3883 -- Disabled: no inlining is requested for the subprogram
3884 -- Enabled: inlining is requested/required for the subprogram
3886 procedure Process_Inline (Status : Inline_Status);
3887 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3888 -- indicates the inline status specified by the pragma.
3890 procedure Process_Interface_Name
3891 (Subprogram_Def : Entity_Id;
3893 Link_Arg : Node_Id);
3894 -- Given the last two arguments of pragma Import, pragma Export, or
3895 -- pragma Interface_Name, performs validity checks and sets the
3896 -- Interface_Name field of the given subprogram entity to the
3897 -- appropriate external or link name, depending on the arguments given.
3898 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3899 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3900 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3901 -- nor Link_Arg is present, the interface name is set to the default
3902 -- from the subprogram name.
3904 procedure Process_Interrupt_Or_Attach_Handler;
3905 -- Common processing for Interrupt and Attach_Handler pragmas
3907 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3908 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3909 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3910 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3911 -- is not set in the Restrictions case.
3913 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3914 -- Common processing for Suppress and Unsuppress. The boolean parameter
3915 -- Suppress_Case is True for the Suppress case, and False for the
3918 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3919 -- Subsidiary to the analysis of pragmas Independent[_Components].
3920 -- Record such a pragma N applied to entity E for future checks.
3922 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3923 -- This procedure sets the Is_Exported flag for the given entity,
3924 -- checking that the entity was not previously imported. Arg is
3925 -- the argument that specified the entity. A check is also made
3926 -- for exporting inappropriate entities.
3928 procedure Set_Extended_Import_Export_External_Name
3929 (Internal_Ent : Entity_Id;
3930 Arg_External : Node_Id);
3931 -- Common processing for all extended import export pragmas. The first
3932 -- argument, Internal_Ent, is the internal entity, which has already
3933 -- been checked for validity by the caller. Arg_External is from the
3934 -- Import or Export pragma, and may be null if no External parameter
3935 -- was present. If Arg_External is present and is a non-null string
3936 -- (a null string is treated as the default), then the Interface_Name
3937 -- field of Internal_Ent is set appropriately.
3939 procedure Set_Imported (E : Entity_Id);
3940 -- This procedure sets the Is_Imported flag for the given entity,
3941 -- checking that it is not previously exported or imported.
3943 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3944 -- Mech is a parameter passing mechanism (see Import_Function syntax
3945 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3946 -- has the right form, and if not issues an error message. If the
3947 -- argument has the right form then the Mechanism field of Ent is
3948 -- set appropriately.
3950 procedure Set_Rational_Profile;
3951 -- Activate the set of configuration pragmas and permissions that make
3952 -- up the Rational profile.
3954 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
3955 -- Activate the set of configuration pragmas and restrictions that make
3956 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3957 -- Ravenscar. N is the corresponding pragma node, which is used for
3958 -- error messages on any constructs violating the profile.
3960 ----------------------------------
3961 -- Acquire_Warning_Match_String --
3962 ----------------------------------
3964 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3966 String_To_Name_Buffer
3967 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3969 -- Add asterisk at start if not already there
3971 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3972 Name_Buffer (2 .. Name_Len + 1) :=
3973 Name_Buffer (1 .. Name_Len);
3974 Name_Buffer (1) := '*';
3975 Name_Len := Name_Len + 1;
3978 -- Add asterisk at end if not already there
3980 if Name_Buffer (Name_Len) /= '*' then
3981 Name_Len := Name_Len + 1;
3982 Name_Buffer (Name_Len) := '*';
3984 end Acquire_Warning_Match_String;
3986 ---------------------
3987 -- Ada_2005_Pragma --
3988 ---------------------
3990 procedure Ada_2005_Pragma is
3992 if Ada_Version <= Ada_95 then
3993 Check_Restriction (No_Implementation_Pragmas, N);
3995 end Ada_2005_Pragma;
3997 ---------------------
3998 -- Ada_2012_Pragma --
3999 ---------------------
4001 procedure Ada_2012_Pragma is
4003 if Ada_Version <= Ada_2005 then
4004 Check_Restriction (No_Implementation_Pragmas, N);
4006 end Ada_2012_Pragma;
4008 ----------------------------
4009 -- Analyze_Depends_Global --
4010 ----------------------------
4012 procedure Analyze_Depends_Global
4013 (Spec_Id : out Entity_Id;
4014 Subp_Decl : out Node_Id;
4015 Legal : out Boolean)
4018 -- Assume that the pragma is illegal
4025 Check_Arg_Count (1);
4027 -- Ensure the proper placement of the pragma. Depends/Global must be
4028 -- associated with a subprogram declaration or a body that acts as a
4031 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4035 if Nkind (Subp_Decl) = N_Entry_Declaration then
4038 -- Generic subprogram
4040 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4043 -- Object declaration of a single concurrent type
4045 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4050 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4053 -- Subprogram body acts as spec
4055 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4056 and then No (Corresponding_Spec (Subp_Decl))
4060 -- Subprogram body stub acts as spec
4062 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4063 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4067 -- Subprogram declaration
4069 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4074 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4082 -- If we get here, then the pragma is legal
4085 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4087 -- When the related context is an entry, the entry must belong to a
4088 -- protected unit (SPARK RM 6.1.4(6)).
4090 if Is_Entry_Declaration (Spec_Id)
4091 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4096 -- When the related context is an anonymous object created for a
4097 -- simple concurrent type, the type must be a task
4098 -- (SPARK RM 6.1.4(6)).
4100 elsif Is_Single_Concurrent_Object (Spec_Id)
4101 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4107 -- A pragma that applies to a Ghost entity becomes Ghost for the
4108 -- purposes of legality checks and removal of ignored Ghost code.
4110 Mark_Pragma_As_Ghost (N, Spec_Id);
4111 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4112 end Analyze_Depends_Global;
4114 ------------------------
4115 -- Analyze_If_Present --
4116 ------------------------
4118 procedure Analyze_If_Present (Id : Pragma_Id) is
4122 pragma Assert (Is_List_Member (N));
4124 -- Inspect the declarations or statements following pragma N looking
4125 -- for another pragma whose Id matches the caller's request. If it is
4126 -- available, analyze it.
4129 while Present (Stmt) loop
4130 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4131 Analyze_Pragma (Stmt);
4134 -- The first source declaration or statement immediately following
4135 -- N ends the region where a pragma may appear.
4137 elsif Comes_From_Source (Stmt) then
4143 end Analyze_If_Present;
4145 --------------------------------
4146 -- Analyze_Pre_Post_Condition --
4147 --------------------------------
4149 procedure Analyze_Pre_Post_Condition is
4150 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4151 Subp_Decl : Node_Id;
4152 Subp_Id : Entity_Id;
4154 Duplicates_OK : Boolean := False;
4155 -- Flag set when a pre/postcondition allows multiple pragmas of the
4158 In_Body_OK : Boolean := False;
4159 -- Flag set when a pre/postcondition is allowed to appear on a body
4160 -- even though the subprogram may have a spec.
4162 Is_Pre_Post : Boolean := False;
4163 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4167 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4168 -- offer uniformity among the various kinds of pre/postconditions by
4169 -- rewriting the pragma identifier. This allows the retrieval of the
4170 -- original pragma name by routine Original_Aspect_Pragma_Name.
4172 if Comes_From_Source (N) then
4173 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4174 Is_Pre_Post := True;
4175 Set_Class_Present (N, Pname = Name_Pre_Class);
4176 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4178 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4179 Is_Pre_Post := True;
4180 Set_Class_Present (N, Pname = Name_Post_Class);
4181 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4185 -- Determine the semantics with respect to duplicates and placement
4186 -- in a body. Pragmas Precondition and Postcondition were introduced
4187 -- before aspects and are not subject to the same aspect-like rules.
4189 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4190 Duplicates_OK := True;
4196 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4197 -- argument without an identifier.
4200 Check_Arg_Count (1);
4201 Check_No_Identifiers;
4203 -- Pragmas Precondition and Postcondition have complex argument
4207 Check_At_Least_N_Arguments (1);
4208 Check_At_Most_N_Arguments (2);
4209 Check_Optional_Identifier (Arg1, Name_Check);
4211 if Present (Arg2) then
4212 Check_Optional_Identifier (Arg2, Name_Message);
4213 Preanalyze_Spec_Expression
4214 (Get_Pragma_Arg (Arg2), Standard_String);
4218 -- For a pragma PPC in the extended main source unit, record enabled
4220 -- ??? nothing checks that the pragma is in the main source unit
4222 if Is_Checked (N) and then not Split_PPC (N) then
4223 Set_SCO_Pragma_Enabled (Loc);
4226 -- Ensure the proper placement of the pragma
4229 Find_Related_Declaration_Or_Body
4230 (N, Do_Checks => not Duplicates_OK);
4232 -- When a pre/postcondition pragma applies to an abstract subprogram,
4233 -- its original form must be an aspect with 'Class.
4235 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4236 if not From_Aspect_Specification (N) then
4238 ("pragma % cannot be applied to abstract subprogram");
4240 elsif not Class_Present (N) then
4242 ("aspect % requires ''Class for abstract subprogram");
4245 -- Entry declaration
4247 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4250 -- Generic subprogram declaration
4252 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4257 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4258 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4262 -- Subprogram body stub
4264 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4265 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4269 -- Subprogram declaration
4271 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4273 -- AI05-0230: When a pre/postcondition pragma applies to a null
4274 -- procedure, its original form must be an aspect with 'Class.
4276 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4277 and then Null_Present (Specification (Subp_Decl))
4278 and then From_Aspect_Specification (N)
4279 and then not Class_Present (N)
4281 Error_Pragma ("aspect % requires ''Class for null procedure");
4284 -- Otherwise the placement is illegal
4291 Subp_Id := Defining_Entity (Subp_Decl);
4293 -- Chain the pragma on the contract for further processing by
4294 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4296 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4298 -- A pragma that applies to a Ghost entity becomes Ghost for the
4299 -- purposes of legality checks and removal of ignored Ghost code.
4301 Mark_Pragma_As_Ghost (N, Subp_Id);
4303 -- Fully analyze the pragma when it appears inside an entry or
4304 -- subprogram body because it cannot benefit from forward references.
4306 if Nkind_In (Subp_Decl, N_Entry_Body,
4308 N_Subprogram_Body_Stub)
4310 -- The legality checks of pragmas Precondition and Postcondition
4311 -- are affected by the SPARK mode in effect and the volatility of
4312 -- the context. Analyze all pragmas in a specific order.
4314 Analyze_If_Present (Pragma_SPARK_Mode);
4315 Analyze_If_Present (Pragma_Volatile_Function);
4316 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4318 end Analyze_Pre_Post_Condition;
4320 -----------------------------------------
4321 -- Analyze_Refined_Depends_Global_Post --
4322 -----------------------------------------
4324 procedure Analyze_Refined_Depends_Global_Post
4325 (Spec_Id : out Entity_Id;
4326 Body_Id : out Entity_Id;
4327 Legal : out Boolean)
4329 Body_Decl : Node_Id;
4330 Spec_Decl : Node_Id;
4333 -- Assume that the pragma is illegal
4340 Check_Arg_Count (1);
4341 Check_No_Identifiers;
4343 -- Verify the placement of the pragma and check for duplicates. The
4344 -- pragma must apply to a subprogram body [stub].
4346 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4350 if Nkind (Body_Decl) = N_Entry_Body then
4355 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4358 -- Subprogram body stub
4360 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4365 elsif Nkind (Body_Decl) = N_Task_Body then
4373 Body_Id := Defining_Entity (Body_Decl);
4374 Spec_Id := Unique_Defining_Entity (Body_Decl);
4376 -- The pragma must apply to the second declaration of a subprogram.
4377 -- In other words, the body [stub] cannot acts as a spec.
4379 if No (Spec_Id) then
4380 Error_Pragma ("pragma % cannot apply to a stand alone body");
4383 -- Catch the case where the subprogram body is a subunit and acts as
4384 -- the third declaration of the subprogram.
4386 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4387 Error_Pragma ("pragma % cannot apply to a subunit");
4391 -- A refined pragma can only apply to the body [stub] of a subprogram
4392 -- declared in the visible part of a package. Retrieve the context of
4393 -- the subprogram declaration.
4395 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4397 -- When dealing with protected entries or protected subprograms, use
4398 -- the enclosing protected type as the proper context.
4400 if Ekind_In (Spec_Id, E_Entry,
4404 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4406 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4409 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4411 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4412 & "subprogram declared in a package specification"));
4416 -- If we get here, then the pragma is legal
4420 -- A pragma that applies to a Ghost entity becomes Ghost for the
4421 -- purposes of legality checks and removal of ignored Ghost code.
4423 Mark_Pragma_As_Ghost (N, Spec_Id);
4425 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4426 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4428 end Analyze_Refined_Depends_Global_Post;
4430 --------------------------
4431 -- Check_Ada_83_Warning --
4432 --------------------------
4434 procedure Check_Ada_83_Warning is
4436 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4437 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4439 end Check_Ada_83_Warning;
4441 ---------------------
4442 -- Check_Arg_Count --
4443 ---------------------
4445 procedure Check_Arg_Count (Required : Nat) is
4447 if Arg_Count /= Required then
4448 Error_Pragma ("wrong number of arguments for pragma%");
4450 end Check_Arg_Count;
4452 --------------------------------
4453 -- Check_Arg_Is_External_Name --
4454 --------------------------------
4456 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4457 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4460 if Nkind (Argx) = N_Identifier then
4464 Analyze_And_Resolve (Argx, Standard_String);
4466 if Is_OK_Static_Expression (Argx) then
4469 elsif Etype (Argx) = Any_Type then
4472 -- An interesting special case, if we have a string literal and
4473 -- we are in Ada 83 mode, then we allow it even though it will
4474 -- not be flagged as static. This allows expected Ada 83 mode
4475 -- use of external names which are string literals, even though
4476 -- technically these are not static in Ada 83.
4478 elsif Ada_Version = Ada_83
4479 and then Nkind (Argx) = N_String_Literal
4483 -- Static expression that raises Constraint_Error. This has
4484 -- already been flagged, so just exit from pragma processing.
4486 elsif Is_OK_Static_Expression (Argx) then
4489 -- Here we have a real error (non-static expression)
4492 Error_Msg_Name_1 := Pname;
4495 Msg : constant String :=
4496 "argument for pragma% must be a identifier or "
4497 & "static string expression!";
4499 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4504 end Check_Arg_Is_External_Name;
4506 -----------------------------
4507 -- Check_Arg_Is_Identifier --
4508 -----------------------------
4510 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4511 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4513 if Nkind (Argx) /= N_Identifier then
4515 ("argument for pragma% must be identifier", Argx);
4517 end Check_Arg_Is_Identifier;
4519 ----------------------------------
4520 -- Check_Arg_Is_Integer_Literal --
4521 ----------------------------------
4523 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4524 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4526 if Nkind (Argx) /= N_Integer_Literal then
4528 ("argument for pragma% must be integer literal", Argx);
4530 end Check_Arg_Is_Integer_Literal;
4532 -------------------------------------------
4533 -- Check_Arg_Is_Library_Level_Local_Name --
4534 -------------------------------------------
4538 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4539 -- | library_unit_NAME
4541 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4543 Check_Arg_Is_Local_Name (Arg);
4545 -- If it came from an aspect, we want to give the error just as if it
4546 -- came from source.
4548 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4549 and then (Comes_From_Source (N)
4550 or else Present (Corresponding_Aspect (Parent (Arg))))
4553 ("argument for pragma% must be library level entity", Arg);
4555 end Check_Arg_Is_Library_Level_Local_Name;
4557 -----------------------------
4558 -- Check_Arg_Is_Local_Name --
4559 -----------------------------
4563 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4564 -- | library_unit_NAME
4566 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4567 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4570 -- If this pragma came from an aspect specification, we don't want to
4571 -- check for this error, because that would cause spurious errors, in
4572 -- case a type is frozen in a scope more nested than the type. The
4573 -- aspect itself of course can't be anywhere but on the declaration
4576 if Nkind (Arg) = N_Pragma_Argument_Association then
4577 if From_Aspect_Specification (Parent (Arg)) then
4581 -- Arg is the Expression of an N_Pragma_Argument_Association
4584 if From_Aspect_Specification (Parent (Parent (Arg))) then
4591 if Nkind (Argx) not in N_Direct_Name
4592 and then (Nkind (Argx) /= N_Attribute_Reference
4593 or else Present (Expressions (Argx))
4594 or else Nkind (Prefix (Argx)) /= N_Identifier)
4595 and then (not Is_Entity_Name (Argx)
4596 or else not Is_Compilation_Unit (Entity (Argx)))
4598 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4601 -- No further check required if not an entity name
4603 if not Is_Entity_Name (Argx) then
4609 Ent : constant Entity_Id := Entity (Argx);
4610 Scop : constant Entity_Id := Scope (Ent);
4613 -- Case of a pragma applied to a compilation unit: pragma must
4614 -- occur immediately after the program unit in the compilation.
4616 if Is_Compilation_Unit (Ent) then
4618 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4621 -- Case of pragma placed immediately after spec
4623 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4626 -- Case of pragma placed immediately after body
4628 elsif Nkind (Decl) = N_Subprogram_Declaration
4629 and then Present (Corresponding_Body (Decl))
4633 (Parent (Unit_Declaration_Node
4634 (Corresponding_Body (Decl))));
4636 -- All other cases are illegal
4643 -- Special restricted placement rule from 10.2.1(11.8/2)
4645 elsif Is_Generic_Formal (Ent)
4646 and then Prag_Id = Pragma_Preelaborable_Initialization
4648 OK := List_Containing (N) =
4649 Generic_Formal_Declarations
4650 (Unit_Declaration_Node (Scop));
4652 -- If this is an aspect applied to a subprogram body, the
4653 -- pragma is inserted in its declarative part.
4655 elsif From_Aspect_Specification (N)
4656 and then Ent = Current_Scope
4658 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4662 -- If the aspect is a predicate (possibly others ???) and the
4663 -- context is a record type, this is a discriminant expression
4664 -- within a type declaration, that freezes the predicated
4667 elsif From_Aspect_Specification (N)
4668 and then Prag_Id = Pragma_Predicate
4669 and then Ekind (Current_Scope) = E_Record_Type
4670 and then Scop = Scope (Current_Scope)
4674 -- Default case, just check that the pragma occurs in the scope
4675 -- of the entity denoted by the name.
4678 OK := Current_Scope = Scop;
4683 ("pragma% argument must be in same declarative part", Arg);
4687 end Check_Arg_Is_Local_Name;
4689 ---------------------------------
4690 -- Check_Arg_Is_Locking_Policy --
4691 ---------------------------------
4693 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
4694 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4697 Check_Arg_Is_Identifier (Argx);
4699 if not Is_Locking_Policy_Name (Chars (Argx)) then
4700 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
4702 end Check_Arg_Is_Locking_Policy;
4704 -----------------------------------------------
4705 -- Check_Arg_Is_Partition_Elaboration_Policy --
4706 -----------------------------------------------
4708 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
4709 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4712 Check_Arg_Is_Identifier (Argx);
4714 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
4716 ("& is not a valid partition elaboration policy name", Argx);
4718 end Check_Arg_Is_Partition_Elaboration_Policy;
4720 -------------------------
4721 -- Check_Arg_Is_One_Of --
4722 -------------------------
4724 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4725 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4728 Check_Arg_Is_Identifier (Argx);
4730 if not Nam_In (Chars (Argx), N1, N2) then
4731 Error_Msg_Name_2 := N1;
4732 Error_Msg_Name_3 := N2;
4733 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
4735 end Check_Arg_Is_One_Of;
4737 procedure Check_Arg_Is_One_Of
4739 N1, N2, N3 : Name_Id)
4741 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4744 Check_Arg_Is_Identifier (Argx);
4746 if not Nam_In (Chars (Argx), N1, N2, N3) then
4747 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4749 end Check_Arg_Is_One_Of;
4751 procedure Check_Arg_Is_One_Of
4753 N1, N2, N3, N4 : Name_Id)
4755 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4758 Check_Arg_Is_Identifier (Argx);
4760 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
4761 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4763 end Check_Arg_Is_One_Of;
4765 procedure Check_Arg_Is_One_Of
4767 N1, N2, N3, N4, N5 : Name_Id)
4769 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4772 Check_Arg_Is_Identifier (Argx);
4774 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
4775 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4777 end Check_Arg_Is_One_Of;
4779 ---------------------------------
4780 -- Check_Arg_Is_Queuing_Policy --
4781 ---------------------------------
4783 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
4784 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4787 Check_Arg_Is_Identifier (Argx);
4789 if not Is_Queuing_Policy_Name (Chars (Argx)) then
4790 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
4792 end Check_Arg_Is_Queuing_Policy;
4794 ---------------------------------------
4795 -- Check_Arg_Is_OK_Static_Expression --
4796 ---------------------------------------
4798 procedure Check_Arg_Is_OK_Static_Expression
4800 Typ : Entity_Id := Empty)
4803 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4804 end Check_Arg_Is_OK_Static_Expression;
4806 ------------------------------------------
4807 -- Check_Arg_Is_Task_Dispatching_Policy --
4808 ------------------------------------------
4810 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4811 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4814 Check_Arg_Is_Identifier (Argx);
4816 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4818 ("& is not an allowed task dispatching policy name", Argx);
4820 end Check_Arg_Is_Task_Dispatching_Policy;
4822 ---------------------
4823 -- Check_Arg_Order --
4824 ---------------------
4826 procedure Check_Arg_Order (Names : Name_List) is
4829 Highest_So_Far : Natural := 0;
4830 -- Highest index in Names seen do far
4834 for J in 1 .. Arg_Count loop
4835 if Chars (Arg) /= No_Name then
4836 for K in Names'Range loop
4837 if Chars (Arg) = Names (K) then
4838 if K < Highest_So_Far then
4839 Error_Msg_Name_1 := Pname;
4841 ("parameters out of order for pragma%", Arg);
4842 Error_Msg_Name_1 := Names (K);
4843 Error_Msg_Name_2 := Names (Highest_So_Far);
4844 Error_Msg_N ("\% must appear before %", Arg);
4848 Highest_So_Far := K;
4856 end Check_Arg_Order;
4858 --------------------------------
4859 -- Check_At_Least_N_Arguments --
4860 --------------------------------
4862 procedure Check_At_Least_N_Arguments (N : Nat) is
4864 if Arg_Count < N then
4865 Error_Pragma ("too few arguments for pragma%");
4867 end Check_At_Least_N_Arguments;
4869 -------------------------------
4870 -- Check_At_Most_N_Arguments --
4871 -------------------------------
4873 procedure Check_At_Most_N_Arguments (N : Nat) is
4876 if Arg_Count > N then
4878 for J in 1 .. N loop
4880 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4883 end Check_At_Most_N_Arguments;
4885 ---------------------
4886 -- Check_Component --
4887 ---------------------
4889 procedure Check_Component
4892 In_Variant_Part : Boolean := False)
4894 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4895 Sindic : constant Node_Id :=
4896 Subtype_Indication (Component_Definition (Comp));
4897 Typ : constant Entity_Id := Etype (Comp_Id);
4900 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4901 -- object constraint, then the component type shall be an Unchecked_
4904 if Nkind (Sindic) = N_Subtype_Indication
4905 and then Has_Per_Object_Constraint (Comp_Id)
4906 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4909 ("component subtype subject to per-object constraint "
4910 & "must be an Unchecked_Union", Comp);
4912 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4913 -- the body of a generic unit, or within the body of any of its
4914 -- descendant library units, no part of the type of a component
4915 -- declared in a variant_part of the unchecked union type shall be of
4916 -- a formal private type or formal private extension declared within
4917 -- the formal part of the generic unit.
4919 elsif Ada_Version >= Ada_2012
4920 and then In_Generic_Body (UU_Typ)
4921 and then In_Variant_Part
4922 and then Is_Private_Type (Typ)
4923 and then Is_Generic_Type (Typ)
4926 ("component of unchecked union cannot be of generic type", Comp);
4928 elsif Needs_Finalization (Typ) then
4930 ("component of unchecked union cannot be controlled", Comp);
4932 elsif Has_Task (Typ) then
4934 ("component of unchecked union cannot have tasks", Comp);
4936 end Check_Component;
4938 ----------------------------
4939 -- Check_Duplicate_Pragma --
4940 ----------------------------
4942 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4943 Id : Entity_Id := E;
4947 -- Nothing to do if this pragma comes from an aspect specification,
4948 -- since we could not be duplicating a pragma, and we dealt with the
4949 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4951 if From_Aspect_Specification (N) then
4955 -- Otherwise current pragma may duplicate previous pragma or a
4956 -- previously given aspect specification or attribute definition
4957 -- clause for the same pragma.
4959 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4963 -- If the entity is a type, then we have to make sure that the
4964 -- ostensible duplicate is not for a parent type from which this
4968 if Nkind (P) = N_Pragma then
4970 Args : constant List_Id :=
4971 Pragma_Argument_Associations (P);
4974 and then Is_Entity_Name (Expression (First (Args)))
4975 and then Is_Type (Entity (Expression (First (Args))))
4976 and then Entity (Expression (First (Args))) /= E
4982 elsif Nkind (P) = N_Aspect_Specification
4983 and then Is_Type (Entity (P))
4984 and then Entity (P) /= E
4990 -- Here we have a definite duplicate
4992 Error_Msg_Name_1 := Pragma_Name (N);
4993 Error_Msg_Sloc := Sloc (P);
4995 -- For a single protected or a single task object, the error is
4996 -- issued on the original entity.
4998 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4999 Id := Defining_Identifier (Original_Node (Parent (Id)));
5002 if Nkind (P) = N_Aspect_Specification
5003 or else From_Aspect_Specification (P)
5005 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5007 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5012 end Check_Duplicate_Pragma;
5014 ----------------------------------
5015 -- Check_Duplicated_Export_Name --
5016 ----------------------------------
5018 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5019 String_Val : constant String_Id := Strval (Nam);
5022 -- We are only interested in the export case, and in the case of
5023 -- generics, it is the instance, not the template, that is the
5024 -- problem (the template will generate a warning in any case).
5026 if not Inside_A_Generic
5027 and then (Prag_Id = Pragma_Export
5029 Prag_Id = Pragma_Export_Procedure
5031 Prag_Id = Pragma_Export_Valued_Procedure
5033 Prag_Id = Pragma_Export_Function)
5035 for J in Externals.First .. Externals.Last loop
5036 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5037 Error_Msg_Sloc := Sloc (Externals.Table (J));
5038 Error_Msg_N ("external name duplicates name given#", Nam);
5043 Externals.Append (Nam);
5045 end Check_Duplicated_Export_Name;
5047 ----------------------------------------
5048 -- Check_Expr_Is_OK_Static_Expression --
5049 ----------------------------------------
5051 procedure Check_Expr_Is_OK_Static_Expression
5053 Typ : Entity_Id := Empty)
5056 if Present (Typ) then
5057 Analyze_And_Resolve (Expr, Typ);
5059 Analyze_And_Resolve (Expr);
5062 if Is_OK_Static_Expression (Expr) then
5065 elsif Etype (Expr) = Any_Type then
5068 -- An interesting special case, if we have a string literal and we
5069 -- are in Ada 83 mode, then we allow it even though it will not be
5070 -- flagged as static. This allows the use of Ada 95 pragmas like
5071 -- Import in Ada 83 mode. They will of course be flagged with
5072 -- warnings as usual, but will not cause errors.
5074 elsif Ada_Version = Ada_83
5075 and then Nkind (Expr) = N_String_Literal
5079 -- Static expression that raises Constraint_Error. This has already
5080 -- been flagged, so just exit from pragma processing.
5082 elsif Is_OK_Static_Expression (Expr) then
5085 -- Finally, we have a real error
5088 Error_Msg_Name_1 := Pname;
5089 Flag_Non_Static_Expr
5090 (Fix_Error ("argument for pragma% must be a static expression!"),
5094 end Check_Expr_Is_OK_Static_Expression;
5096 -------------------------
5097 -- Check_First_Subtype --
5098 -------------------------
5100 procedure Check_First_Subtype (Arg : Node_Id) is
5101 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5102 Ent : constant Entity_Id := Entity (Argx);
5105 if Is_First_Subtype (Ent) then
5108 elsif Is_Type (Ent) then
5110 ("pragma% cannot apply to subtype", Argx);
5112 elsif Is_Object (Ent) then
5114 ("pragma% cannot apply to object, requires a type", Argx);
5118 ("pragma% cannot apply to&, requires a type", Argx);
5120 end Check_First_Subtype;
5122 ----------------------
5123 -- Check_Identifier --
5124 ----------------------
5126 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5129 and then Nkind (Arg) = N_Pragma_Argument_Association
5131 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5132 Error_Msg_Name_1 := Pname;
5133 Error_Msg_Name_2 := Id;
5134 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5138 end Check_Identifier;
5140 --------------------------------
5141 -- Check_Identifier_Is_One_Of --
5142 --------------------------------
5144 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5147 and then Nkind (Arg) = N_Pragma_Argument_Association
5149 if Chars (Arg) = No_Name then
5150 Error_Msg_Name_1 := Pname;
5151 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5154 elsif Chars (Arg) /= N1
5155 and then Chars (Arg) /= N2
5157 Error_Msg_Name_1 := Pname;
5158 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5162 end Check_Identifier_Is_One_Of;
5164 ---------------------------
5165 -- Check_In_Main_Program --
5166 ---------------------------
5168 procedure Check_In_Main_Program is
5169 P : constant Node_Id := Parent (N);
5172 -- Must be in subprogram body
5174 if Nkind (P) /= N_Subprogram_Body then
5175 Error_Pragma ("% pragma allowed only in subprogram");
5177 -- Otherwise warn if obviously not main program
5179 elsif Present (Parameter_Specifications (Specification (P)))
5180 or else not Is_Compilation_Unit (Defining_Entity (P))
5182 Error_Msg_Name_1 := Pname;
5184 ("??pragma% is only effective in main program", N);
5186 end Check_In_Main_Program;
5188 ---------------------------------------
5189 -- Check_Interrupt_Or_Attach_Handler --
5190 ---------------------------------------
5192 procedure Check_Interrupt_Or_Attach_Handler is
5193 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5194 Handler_Proc, Proc_Scope : Entity_Id;
5199 if Prag_Id = Pragma_Interrupt_Handler then
5200 Check_Restriction (No_Dynamic_Attachment, N);
5203 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5204 Proc_Scope := Scope (Handler_Proc);
5206 if Ekind (Proc_Scope) /= E_Protected_Type then
5208 ("argument of pragma% must be protected procedure", Arg1);
5211 -- For pragma case (as opposed to access case), check placement.
5212 -- We don't need to do that for aspects, because we have the
5213 -- check that they aspect applies an appropriate procedure.
5215 if not From_Aspect_Specification (N)
5216 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5218 Error_Pragma ("pragma% must be in protected definition");
5221 if not Is_Library_Level_Entity (Proc_Scope) then
5223 ("argument for pragma% must be library level entity", Arg1);
5226 -- AI05-0033: A pragma cannot appear within a generic body, because
5227 -- instance can be in a nested scope. The check that protected type
5228 -- is itself a library-level declaration is done elsewhere.
5230 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5231 -- handle code prior to AI-0033. Analysis tools typically are not
5232 -- interested in this pragma in any case, so no need to worry too
5233 -- much about its placement.
5235 if Inside_A_Generic then
5236 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5237 and then In_Package_Body (Scope (Current_Scope))
5238 and then not Relaxed_RM_Semantics
5240 Error_Pragma ("pragma% cannot be used inside a generic");
5243 end Check_Interrupt_Or_Attach_Handler;
5245 ---------------------------------
5246 -- Check_Loop_Pragma_Placement --
5247 ---------------------------------
5249 procedure Check_Loop_Pragma_Placement is
5250 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5251 -- Verify whether the current pragma is properly grouped with other
5252 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5253 -- related loop where the pragma appears.
5255 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5256 -- Determine whether an arbitrary statement Stmt denotes pragma
5257 -- Loop_Invariant or Loop_Variant.
5259 procedure Placement_Error (Constr : Node_Id);
5260 pragma No_Return (Placement_Error);
5261 -- Node Constr denotes the last loop restricted construct before we
5262 -- encountered an illegal relation between enclosing constructs. Emit
5263 -- an error depending on what Constr was.
5265 --------------------------------
5266 -- Check_Loop_Pragma_Grouping --
5267 --------------------------------
5269 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5270 Stop_Search : exception;
5271 -- This exception is used to terminate the recursive descent of
5272 -- routine Check_Grouping.
5274 procedure Check_Grouping (L : List_Id);
5275 -- Find the first group of pragmas in list L and if successful,
5276 -- ensure that the current pragma is part of that group. The
5277 -- routine raises Stop_Search once such a check is performed to
5278 -- halt the recursive descent.
5280 procedure Grouping_Error (Prag : Node_Id);
5281 pragma No_Return (Grouping_Error);
5282 -- Emit an error concerning the current pragma indicating that it
5283 -- should be placed after pragma Prag.
5285 --------------------
5286 -- Check_Grouping --
5287 --------------------
5289 procedure Check_Grouping (L : List_Id) is
5295 -- Inspect the list of declarations or statements looking for
5296 -- the first grouping of pragmas:
5299 -- pragma Loop_Invariant ...;
5300 -- pragma Loop_Variant ...;
5302 -- pragma Loop_Variant ...; -- current pragma
5304 -- If the current pragma is not in the grouping, then it must
5305 -- either appear in a different declarative or statement list
5306 -- or the construct at (1) is separating the pragma from the
5310 while Present (Stmt) loop
5312 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5313 -- inside a loop or a block housed inside a loop. Inspect
5314 -- the declarations and statements of the block as they may
5315 -- contain the first grouping.
5317 if Nkind (Stmt) = N_Block_Statement then
5318 HSS := Handled_Statement_Sequence (Stmt);
5320 Check_Grouping (Declarations (Stmt));
5322 if Present (HSS) then
5323 Check_Grouping (Statements (HSS));
5326 -- First pragma of the first topmost grouping has been found
5328 elsif Is_Loop_Pragma (Stmt) then
5330 -- The group and the current pragma are not in the same
5331 -- declarative or statement list.
5333 if List_Containing (Stmt) /= List_Containing (N) then
5334 Grouping_Error (Stmt);
5336 -- Try to reach the current pragma from the first pragma
5337 -- of the grouping while skipping other members:
5339 -- pragma Loop_Invariant ...; -- first pragma
5340 -- pragma Loop_Variant ...; -- member
5342 -- pragma Loop_Variant ...; -- current pragma
5345 while Present (Stmt) loop
5347 -- The current pragma is either the first pragma
5348 -- of the group or is a member of the group. Stop
5349 -- the search as the placement is legal.
5354 -- Skip group members, but keep track of the last
5355 -- pragma in the group.
5357 elsif Is_Loop_Pragma (Stmt) then
5360 -- Skip declarations and statements generated by
5361 -- the compiler during expansion.
5363 elsif not Comes_From_Source (Stmt) then
5366 -- A non-pragma is separating the group from the
5367 -- current pragma, the placement is illegal.
5370 Grouping_Error (Prag);
5376 -- If the traversal did not reach the current pragma,
5377 -- then the list must be malformed.
5379 raise Program_Error;
5387 --------------------
5388 -- Grouping_Error --
5389 --------------------
5391 procedure Grouping_Error (Prag : Node_Id) is
5393 Error_Msg_Sloc := Sloc (Prag);
5394 Error_Pragma ("pragma% must appear next to pragma#");
5397 -- Start of processing for Check_Loop_Pragma_Grouping
5400 -- Inspect the statements of the loop or nested blocks housed
5401 -- within to determine whether the current pragma is part of the
5402 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5404 Check_Grouping (Statements (Loop_Stmt));
5407 when Stop_Search => null;
5408 end Check_Loop_Pragma_Grouping;
5410 --------------------
5411 -- Is_Loop_Pragma --
5412 --------------------
5414 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5416 -- Inspect the original node as Loop_Invariant and Loop_Variant
5417 -- pragmas are rewritten to null when assertions are disabled.
5419 if Nkind (Original_Node (Stmt)) = N_Pragma then
5421 Nam_In (Pragma_Name (Original_Node (Stmt)),
5422 Name_Loop_Invariant,
5429 ---------------------
5430 -- Placement_Error --
5431 ---------------------
5433 procedure Placement_Error (Constr : Node_Id) is
5434 LA : constant String := " with Loop_Entry";
5437 if Prag_Id = Pragma_Assert then
5438 Error_Msg_String (1 .. LA'Length) := LA;
5439 Error_Msg_Strlen := LA'Length;
5441 Error_Msg_Strlen := 0;
5444 if Nkind (Constr) = N_Pragma then
5446 ("pragma %~ must appear immediately within the statements "
5450 ("block containing pragma %~ must appear immediately within "
5451 & "the statements of a loop", Constr);
5453 end Placement_Error;
5455 -- Local declarations
5460 -- Start of processing for Check_Loop_Pragma_Placement
5463 -- Check that pragma appears immediately within a loop statement,
5464 -- ignoring intervening block statements.
5468 while Present (Stmt) loop
5470 -- The pragma or previous block must appear immediately within the
5471 -- current block's declarative or statement part.
5473 if Nkind (Stmt) = N_Block_Statement then
5474 if (No (Declarations (Stmt))
5475 or else List_Containing (Prev) /= Declarations (Stmt))
5477 List_Containing (Prev) /=
5478 Statements (Handled_Statement_Sequence (Stmt))
5480 Placement_Error (Prev);
5483 -- Keep inspecting the parents because we are now within a
5484 -- chain of nested blocks.
5488 Stmt := Parent (Stmt);
5491 -- The pragma or previous block must appear immediately within the
5492 -- statements of the loop.
5494 elsif Nkind (Stmt) = N_Loop_Statement then
5495 if List_Containing (Prev) /= Statements (Stmt) then
5496 Placement_Error (Prev);
5499 -- Stop the traversal because we reached the innermost loop
5500 -- regardless of whether we encountered an error or not.
5504 -- Ignore a handled statement sequence. Note that this node may
5505 -- be related to a subprogram body in which case we will emit an
5506 -- error on the next iteration of the search.
5508 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5509 Stmt := Parent (Stmt);
5511 -- Any other statement breaks the chain from the pragma to the
5515 Placement_Error (Prev);
5520 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5521 -- grouped together with other such pragmas.
5523 if Is_Loop_Pragma (N) then
5525 -- The previous check should have located the related loop
5527 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5528 Check_Loop_Pragma_Grouping (Stmt);
5530 end Check_Loop_Pragma_Placement;
5532 -------------------------------------------
5533 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5534 -------------------------------------------
5536 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5545 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5548 elsif Nkind_In (P, N_Package_Specification,
5553 -- Note: the following tests seem a little peculiar, because
5554 -- they test for bodies, but if we were in the statement part
5555 -- of the body, we would already have hit the handled statement
5556 -- sequence, so the only way we get here is by being in the
5557 -- declarative part of the body.
5559 elsif Nkind_In (P, N_Subprogram_Body,
5570 Error_Pragma ("pragma% is not in declarative part or package spec");
5571 end Check_Is_In_Decl_Part_Or_Package_Spec;
5573 -------------------------
5574 -- Check_No_Identifier --
5575 -------------------------
5577 procedure Check_No_Identifier (Arg : Node_Id) is
5579 if Nkind (Arg) = N_Pragma_Argument_Association
5580 and then Chars (Arg) /= No_Name
5582 Error_Pragma_Arg_Ident
5583 ("pragma% does not permit identifier& here", Arg);
5585 end Check_No_Identifier;
5587 --------------------------
5588 -- Check_No_Identifiers --
5589 --------------------------
5591 procedure Check_No_Identifiers is
5595 for J in 1 .. Arg_Count loop
5596 Check_No_Identifier (Arg_Node);
5599 end Check_No_Identifiers;
5601 ------------------------
5602 -- Check_No_Link_Name --
5603 ------------------------
5605 procedure Check_No_Link_Name is
5607 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5611 if Present (Arg4) then
5613 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5615 end Check_No_Link_Name;
5617 -------------------------------
5618 -- Check_Optional_Identifier --
5619 -------------------------------
5621 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5624 and then Nkind (Arg) = N_Pragma_Argument_Association
5625 and then Chars (Arg) /= No_Name
5627 if Chars (Arg) /= Id then
5628 Error_Msg_Name_1 := Pname;
5629 Error_Msg_Name_2 := Id;
5630 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5634 end Check_Optional_Identifier;
5636 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5638 Name_Buffer (1 .. Id'Length) := Id;
5639 Name_Len := Id'Length;
5640 Check_Optional_Identifier (Arg, Name_Find);
5641 end Check_Optional_Identifier;
5643 -------------------------------------
5644 -- Check_Static_Boolean_Expression --
5645 -------------------------------------
5647 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5649 if Present (Expr) then
5650 Analyze_And_Resolve (Expr, Standard_Boolean);
5652 if not Is_OK_Static_Expression (Expr) then
5654 ("expression of pragma % must be static", Expr);
5657 end Check_Static_Boolean_Expression;
5659 -----------------------------
5660 -- Check_Static_Constraint --
5661 -----------------------------
5663 -- Note: for convenience in writing this procedure, in addition to
5664 -- the officially (i.e. by spec) allowed argument which is always a
5665 -- constraint, it also allows ranges and discriminant associations.
5666 -- Above is not clear ???
5668 procedure Check_Static_Constraint (Constr : Node_Id) is
5670 procedure Require_Static (E : Node_Id);
5671 -- Require given expression to be static expression
5673 --------------------
5674 -- Require_Static --
5675 --------------------
5677 procedure Require_Static (E : Node_Id) is
5679 if not Is_OK_Static_Expression (E) then
5680 Flag_Non_Static_Expr
5681 ("non-static constraint not allowed in Unchecked_Union!", E);
5686 -- Start of processing for Check_Static_Constraint
5689 case Nkind (Constr) is
5690 when N_Discriminant_Association =>
5691 Require_Static (Expression (Constr));
5694 Require_Static (Low_Bound (Constr));
5695 Require_Static (High_Bound (Constr));
5697 when N_Attribute_Reference =>
5698 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5699 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5701 when N_Range_Constraint =>
5702 Check_Static_Constraint (Range_Expression (Constr));
5704 when N_Index_Or_Discriminant_Constraint =>
5708 IDC := First (Constraints (Constr));
5709 while Present (IDC) loop
5710 Check_Static_Constraint (IDC);
5718 end Check_Static_Constraint;
5720 --------------------------------------
5721 -- Check_Valid_Configuration_Pragma --
5722 --------------------------------------
5724 -- A configuration pragma must appear in the context clause of a
5725 -- compilation unit, and only other pragmas may precede it. Note that
5726 -- the test also allows use in a configuration pragma file.
5728 procedure Check_Valid_Configuration_Pragma is
5730 if not Is_Configuration_Pragma then
5731 Error_Pragma ("incorrect placement for configuration pragma%");
5733 end Check_Valid_Configuration_Pragma;
5735 -------------------------------------
5736 -- Check_Valid_Library_Unit_Pragma --
5737 -------------------------------------
5739 procedure Check_Valid_Library_Unit_Pragma is
5741 Parent_Node : Node_Id;
5742 Unit_Name : Entity_Id;
5743 Unit_Kind : Node_Kind;
5744 Unit_Node : Node_Id;
5745 Sindex : Source_File_Index;
5748 if not Is_List_Member (N) then
5752 Plist := List_Containing (N);
5753 Parent_Node := Parent (Plist);
5755 if Parent_Node = Empty then
5758 -- Case of pragma appearing after a compilation unit. In this case
5759 -- it must have an argument with the corresponding name and must
5760 -- be part of the following pragmas of its parent.
5762 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5763 if Plist /= Pragmas_After (Parent_Node) then
5766 elsif Arg_Count = 0 then
5768 ("argument required if outside compilation unit");
5771 Check_No_Identifiers;
5772 Check_Arg_Count (1);
5773 Unit_Node := Unit (Parent (Parent_Node));
5774 Unit_Kind := Nkind (Unit_Node);
5776 Analyze (Get_Pragma_Arg (Arg1));
5778 if Unit_Kind = N_Generic_Subprogram_Declaration
5779 or else Unit_Kind = N_Subprogram_Declaration
5781 Unit_Name := Defining_Entity (Unit_Node);
5783 elsif Unit_Kind in N_Generic_Instantiation then
5784 Unit_Name := Defining_Entity (Unit_Node);
5787 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5790 if Chars (Unit_Name) /=
5791 Chars (Entity (Get_Pragma_Arg (Arg1)))
5794 ("pragma% argument is not current unit name", Arg1);
5797 if Ekind (Unit_Name) = E_Package
5798 and then Present (Renamed_Entity (Unit_Name))
5800 Error_Pragma ("pragma% not allowed for renamed package");
5804 -- Pragma appears other than after a compilation unit
5807 -- Here we check for the generic instantiation case and also
5808 -- for the case of processing a generic formal package. We
5809 -- detect these cases by noting that the Sloc on the node
5810 -- does not belong to the current compilation unit.
5812 Sindex := Source_Index (Current_Sem_Unit);
5814 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5815 Rewrite (N, Make_Null_Statement (Loc));
5818 -- If before first declaration, the pragma applies to the
5819 -- enclosing unit, and the name if present must be this name.
5821 elsif Is_Before_First_Decl (N, Plist) then
5822 Unit_Node := Unit_Declaration_Node (Current_Scope);
5823 Unit_Kind := Nkind (Unit_Node);
5825 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5828 elsif Unit_Kind = N_Subprogram_Body
5829 and then not Acts_As_Spec (Unit_Node)
5833 elsif Nkind (Parent_Node) = N_Package_Body then
5836 elsif Nkind (Parent_Node) = N_Package_Specification
5837 and then Plist = Private_Declarations (Parent_Node)
5841 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5842 or else Nkind (Parent_Node) =
5843 N_Generic_Subprogram_Declaration)
5844 and then Plist = Generic_Formal_Declarations (Parent_Node)
5848 elsif Arg_Count > 0 then
5849 Analyze (Get_Pragma_Arg (Arg1));
5851 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5853 ("name in pragma% must be enclosing unit", Arg1);
5856 -- It is legal to have no argument in this context
5862 -- Error if not before first declaration. This is because a
5863 -- library unit pragma argument must be the name of a library
5864 -- unit (RM 10.1.5(7)), but the only names permitted in this
5865 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5866 -- generic subprogram declarations or generic instantiations.
5870 ("pragma% misplaced, must be before first declaration");
5874 end Check_Valid_Library_Unit_Pragma;
5880 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5881 Clist : constant Node_Id := Component_List (Variant);
5885 Comp := First (Component_Items (Clist));
5886 while Present (Comp) loop
5887 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5892 ---------------------------
5893 -- Ensure_Aggregate_Form --
5894 ---------------------------
5896 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5897 CFSD : constant Boolean := Get_Comes_From_Source_Default;
5898 Expr : constant Node_Id := Expression (Arg);
5899 Loc : constant Source_Ptr := Sloc (Expr);
5900 Comps : List_Id := No_List;
5901 Exprs : List_Id := No_List;
5902 Nam : Name_Id := No_Name;
5903 Nam_Loc : Source_Ptr;
5906 -- The pragma argument is in positional form:
5908 -- pragma Depends (Nam => ...)
5912 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5913 -- argument association.
5915 if Nkind (Arg) = N_Pragma_Argument_Association then
5917 Nam_Loc := Sloc (Arg);
5919 -- Remove the pragma argument name as this will be captured in the
5922 Set_Chars (Arg, No_Name);
5925 -- The argument is already in aggregate form, but the presence of a
5926 -- name causes this to be interpreted as named association which in
5927 -- turn must be converted into an aggregate.
5929 -- pragma Global (In_Out => (A, B, C))
5933 -- pragma Global ((In_Out => (A, B, C)))
5935 -- aggregate aggregate
5937 if Nkind (Expr) = N_Aggregate then
5938 if Nam = No_Name then
5942 -- Do not transform a null argument into an aggregate as N_Null has
5943 -- special meaning in formal verification pragmas.
5945 elsif Nkind (Expr) = N_Null then
5949 -- Everything comes from source if the original comes from source
5951 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
5953 -- Positional argument is transformed into an aggregate with an
5954 -- Expressions list.
5956 if Nam = No_Name then
5957 Exprs := New_List (Relocate_Node (Expr));
5959 -- An associative argument is transformed into an aggregate with
5960 -- Component_Associations.
5964 Make_Component_Association (Loc,
5965 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
5966 Expression => Relocate_Node (Expr)));
5969 Set_Expression (Arg,
5970 Make_Aggregate (Loc,
5971 Component_Associations => Comps,
5972 Expressions => Exprs));
5974 -- Restore Comes_From_Source default
5976 Set_Comes_From_Source_Default (CFSD);
5977 end Ensure_Aggregate_Form;
5983 procedure Error_Pragma (Msg : String) is
5985 Error_Msg_Name_1 := Pname;
5986 Error_Msg_N (Fix_Error (Msg), N);
5990 ----------------------
5991 -- Error_Pragma_Arg --
5992 ----------------------
5994 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5996 Error_Msg_Name_1 := Pname;
5997 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5999 end Error_Pragma_Arg;
6001 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6003 Error_Msg_Name_1 := Pname;
6004 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6005 Error_Pragma_Arg (Msg2, Arg);
6006 end Error_Pragma_Arg;
6008 ----------------------------
6009 -- Error_Pragma_Arg_Ident --
6010 ----------------------------
6012 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6014 Error_Msg_Name_1 := Pname;
6015 Error_Msg_N (Fix_Error (Msg), Arg);
6017 end Error_Pragma_Arg_Ident;
6019 ----------------------
6020 -- Error_Pragma_Ref --
6021 ----------------------
6023 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6025 Error_Msg_Name_1 := Pname;
6026 Error_Msg_Sloc := Sloc (Ref);
6027 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6029 end Error_Pragma_Ref;
6031 ------------------------
6032 -- Find_Lib_Unit_Name --
6033 ------------------------
6035 function Find_Lib_Unit_Name return Entity_Id is
6037 -- Return inner compilation unit entity, for case of nested
6038 -- categorization pragmas. This happens in generic unit.
6040 if Nkind (Parent (N)) = N_Package_Specification
6041 and then Defining_Entity (Parent (N)) /= Current_Scope
6043 return Defining_Entity (Parent (N));
6045 return Current_Scope;
6047 end Find_Lib_Unit_Name;
6049 ----------------------------
6050 -- Find_Program_Unit_Name --
6051 ----------------------------
6053 procedure Find_Program_Unit_Name (Id : Node_Id) is
6054 Unit_Name : Entity_Id;
6055 Unit_Kind : Node_Kind;
6056 P : constant Node_Id := Parent (N);
6059 if Nkind (P) = N_Compilation_Unit then
6060 Unit_Kind := Nkind (Unit (P));
6062 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6063 N_Package_Declaration)
6064 or else Unit_Kind in N_Generic_Declaration
6066 Unit_Name := Defining_Entity (Unit (P));
6068 if Chars (Id) = Chars (Unit_Name) then
6069 Set_Entity (Id, Unit_Name);
6070 Set_Etype (Id, Etype (Unit_Name));
6072 Set_Etype (Id, Any_Type);
6074 ("cannot find program unit referenced by pragma%");
6078 Set_Etype (Id, Any_Type);
6079 Error_Pragma ("pragma% inapplicable to this unit");
6085 end Find_Program_Unit_Name;
6087 -----------------------------------------
6088 -- Find_Unique_Parameterless_Procedure --
6089 -----------------------------------------
6091 function Find_Unique_Parameterless_Procedure
6093 Arg : Node_Id) return Entity_Id
6095 Proc : Entity_Id := Empty;
6098 -- The body of this procedure needs some comments ???
6100 if not Is_Entity_Name (Name) then
6102 ("argument of pragma% must be entity name", Arg);
6104 elsif not Is_Overloaded (Name) then
6105 Proc := Entity (Name);
6107 if Ekind (Proc) /= E_Procedure
6108 or else Present (First_Formal (Proc))
6111 ("argument of pragma% must be parameterless procedure", Arg);
6116 Found : Boolean := False;
6118 Index : Interp_Index;
6121 Get_First_Interp (Name, Index, It);
6122 while Present (It.Nam) loop
6125 if Ekind (Proc) = E_Procedure
6126 and then No (First_Formal (Proc))
6130 Set_Entity (Name, Proc);
6131 Set_Is_Overloaded (Name, False);
6134 ("ambiguous handler name for pragma% ", Arg);
6138 Get_Next_Interp (Index, It);
6143 ("argument of pragma% must be parameterless procedure",
6146 Proc := Entity (Name);
6152 end Find_Unique_Parameterless_Procedure;
6158 function Fix_Error (Msg : String) return String is
6159 Res : String (Msg'Range) := Msg;
6160 Res_Last : Natural := Msg'Last;
6164 -- If we have a rewriting of another pragma, go to that pragma
6166 if Is_Rewrite_Substitution (N)
6167 and then Nkind (Original_Node (N)) = N_Pragma
6169 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6172 -- Case where pragma comes from an aspect specification
6174 if From_Aspect_Specification (N) then
6176 -- Change appearence of "pragma" in message to "aspect"
6179 while J <= Res_Last - 5 loop
6180 if Res (J .. J + 5) = "pragma" then
6181 Res (J .. J + 5) := "aspect";
6189 -- Change "argument of" at start of message to "entity for"
6192 and then Res (Res'First .. Res'First + 10) = "argument of"
6194 Res (Res'First .. Res'First + 9) := "entity for";
6195 Res (Res'First + 10 .. Res_Last - 1) :=
6196 Res (Res'First + 11 .. Res_Last);
6197 Res_Last := Res_Last - 1;
6200 -- Change "argument" at start of message to "entity"
6203 and then Res (Res'First .. Res'First + 7) = "argument"
6205 Res (Res'First .. Res'First + 5) := "entity";
6206 Res (Res'First + 6 .. Res_Last - 2) :=
6207 Res (Res'First + 8 .. Res_Last);
6208 Res_Last := Res_Last - 2;
6211 -- Get name from corresponding aspect
6213 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6216 -- Return possibly modified message
6218 return Res (Res'First .. Res_Last);
6221 -------------------------
6222 -- Gather_Associations --
6223 -------------------------
6225 procedure Gather_Associations
6227 Args : out Args_List)
6232 -- Initialize all parameters to Empty
6234 for J in Args'Range loop
6238 -- That's all we have to do if there are no argument associations
6240 if No (Pragma_Argument_Associations (N)) then
6244 -- Otherwise first deal with any positional parameters present
6246 Arg := First (Pragma_Argument_Associations (N));
6247 for Index in Args'Range loop
6248 exit when No (Arg) or else Chars (Arg) /= No_Name;
6249 Args (Index) := Get_Pragma_Arg (Arg);
6253 -- Positional parameters all processed, if any left, then we
6254 -- have too many positional parameters.
6256 if Present (Arg) and then Chars (Arg) = No_Name then
6258 ("too many positional associations for pragma%", Arg);
6261 -- Process named parameters if any are present
6263 while Present (Arg) loop
6264 if Chars (Arg) = No_Name then
6266 ("positional association cannot follow named association",
6270 for Index in Names'Range loop
6271 if Names (Index) = Chars (Arg) then
6272 if Present (Args (Index)) then
6274 ("duplicate argument association for pragma%", Arg);
6276 Args (Index) := Get_Pragma_Arg (Arg);
6281 if Index = Names'Last then
6282 Error_Msg_Name_1 := Pname;
6283 Error_Msg_N ("pragma% does not allow & argument", Arg);
6285 -- Check for possible misspelling
6287 for Index1 in Names'Range loop
6288 if Is_Bad_Spelling_Of
6289 (Chars (Arg), Names (Index1))
6291 Error_Msg_Name_1 := Names (Index1);
6292 Error_Msg_N -- CODEFIX
6293 ("\possible misspelling of%", Arg);
6305 end Gather_Associations;
6311 procedure GNAT_Pragma is
6313 -- We need to check the No_Implementation_Pragmas restriction for
6314 -- the case of a pragma from source. Note that the case of aspects
6315 -- generating corresponding pragmas marks these pragmas as not being
6316 -- from source, so this test also catches that case.
6318 if Comes_From_Source (N) then
6319 Check_Restriction (No_Implementation_Pragmas, N);
6323 --------------------------
6324 -- Is_Before_First_Decl --
6325 --------------------------
6327 function Is_Before_First_Decl
6328 (Pragma_Node : Node_Id;
6329 Decls : List_Id) return Boolean
6331 Item : Node_Id := First (Decls);
6334 -- Only other pragmas can come before this pragma
6337 if No (Item) or else Nkind (Item) /= N_Pragma then
6340 elsif Item = Pragma_Node then
6346 end Is_Before_First_Decl;
6348 -----------------------------
6349 -- Is_Configuration_Pragma --
6350 -----------------------------
6352 -- A configuration pragma must appear in the context clause of a
6353 -- compilation unit, and only other pragmas may precede it. Note that
6354 -- the test below also permits use in a configuration pragma file.
6356 function Is_Configuration_Pragma return Boolean is
6357 Lis : constant List_Id := List_Containing (N);
6358 Par : constant Node_Id := Parent (N);
6362 -- If no parent, then we are in the configuration pragma file,
6363 -- so the placement is definitely appropriate.
6368 -- Otherwise we must be in the context clause of a compilation unit
6369 -- and the only thing allowed before us in the context list is more
6370 -- configuration pragmas.
6372 elsif Nkind (Par) = N_Compilation_Unit
6373 and then Context_Items (Par) = Lis
6380 elsif Nkind (Prg) /= N_Pragma then
6390 end Is_Configuration_Pragma;
6392 --------------------------
6393 -- Is_In_Context_Clause --
6394 --------------------------
6396 function Is_In_Context_Clause return Boolean is
6398 Parent_Node : Node_Id;
6401 if not Is_List_Member (N) then
6405 Plist := List_Containing (N);
6406 Parent_Node := Parent (Plist);
6408 if Parent_Node = Empty
6409 or else Nkind (Parent_Node) /= N_Compilation_Unit
6410 or else Context_Items (Parent_Node) /= Plist
6417 end Is_In_Context_Clause;
6419 ---------------------------------
6420 -- Is_Static_String_Expression --
6421 ---------------------------------
6423 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6424 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6425 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6428 Analyze_And_Resolve (Argx);
6430 -- Special case Ada 83, where the expression will never be static,
6431 -- but we will return true if we had a string literal to start with.
6433 if Ada_Version = Ada_83 then
6436 -- Normal case, true only if we end up with a string literal that
6437 -- is marked as being the result of evaluating a static expression.
6440 return Is_OK_Static_Expression (Argx)
6441 and then Nkind (Argx) = N_String_Literal;
6444 end Is_Static_String_Expression;
6446 ----------------------
6447 -- Pragma_Misplaced --
6448 ----------------------
6450 procedure Pragma_Misplaced is
6452 Error_Pragma ("incorrect placement of pragma%");
6453 end Pragma_Misplaced;
6455 ------------------------------------------------
6456 -- Process_Atomic_Independent_Shared_Volatile --
6457 ------------------------------------------------
6459 procedure Process_Atomic_Independent_Shared_Volatile is
6460 procedure Set_Atomic_VFA (E : Entity_Id);
6461 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6462 -- no explicit alignment was given, set alignment to unknown, since
6463 -- back end knows what the alignment requirements are for atomic and
6464 -- full access arrays. Note: this is necessary for derived types.
6466 --------------------
6467 -- Set_Atomic_VFA --
6468 --------------------
6470 procedure Set_Atomic_VFA (E : Entity_Id) is
6472 if Prag_Id = Pragma_Volatile_Full_Access then
6473 Set_Is_Volatile_Full_Access (E);
6478 if not Has_Alignment_Clause (E) then
6479 Set_Alignment (E, Uint_0);
6489 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6492 Check_Ada_83_Warning;
6493 Check_No_Identifiers;
6494 Check_Arg_Count (1);
6495 Check_Arg_Is_Local_Name (Arg1);
6496 E_Arg := Get_Pragma_Arg (Arg1);
6498 if Etype (E_Arg) = Any_Type then
6502 E := Entity (E_Arg);
6503 Decl := Declaration_Node (E);
6505 -- A pragma that applies to a Ghost entity becomes Ghost for the
6506 -- purposes of legality checks and removal of ignored Ghost code.
6508 Mark_Pragma_As_Ghost (N, E);
6510 -- Check duplicate before we chain ourselves
6512 Check_Duplicate_Pragma (E);
6514 -- Check Atomic and VFA used together
6516 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6517 or else (Is_Volatile_Full_Access (E)
6518 and then (Prag_Id = Pragma_Atomic
6520 Prag_Id = Pragma_Shared))
6523 ("cannot have Volatile_Full_Access and Atomic for same entity");
6526 -- Check for applying VFA to an entity which has aliased component
6528 if Prag_Id = Pragma_Volatile_Full_Access then
6531 Aliased_Comp : Boolean := False;
6532 -- Set True if aliased component present
6535 if Is_Array_Type (Etype (E)) then
6536 Aliased_Comp := Has_Aliased_Components (Etype (E));
6538 -- Record case, too bad Has_Aliased_Components is not also
6539 -- set for records, should it be ???
6541 elsif Is_Record_Type (Etype (E)) then
6542 Comp := First_Component_Or_Discriminant (Etype (E));
6543 while Present (Comp) loop
6544 if Is_Aliased (Comp)
6545 or else Is_Aliased (Etype (Comp))
6547 Aliased_Comp := True;
6551 Next_Component_Or_Discriminant (Comp);
6555 if Aliased_Comp then
6557 ("cannot apply Volatile_Full_Access (aliased component "
6563 -- Now check appropriateness of the entity
6566 if Rep_Item_Too_Early (E, N)
6568 Rep_Item_Too_Late (E, N)
6572 Check_First_Subtype (Arg1);
6575 -- Attribute belongs on the base type. If the view of the type is
6576 -- currently private, it also belongs on the underlying type.
6578 if Prag_Id = Pragma_Atomic
6580 Prag_Id = Pragma_Shared
6582 Prag_Id = Pragma_Volatile_Full_Access
6585 Set_Atomic_VFA (Base_Type (E));
6586 Set_Atomic_VFA (Underlying_Type (E));
6589 -- Atomic/Shared/Volatile_Full_Access imply Independent
6591 if Prag_Id /= Pragma_Volatile then
6592 Set_Is_Independent (E);
6593 Set_Is_Independent (Base_Type (E));
6594 Set_Is_Independent (Underlying_Type (E));
6596 if Prag_Id = Pragma_Independent then
6597 Record_Independence_Check (N, Base_Type (E));
6601 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6603 if Prag_Id /= Pragma_Independent then
6604 Set_Is_Volatile (E);
6605 Set_Is_Volatile (Base_Type (E));
6606 Set_Is_Volatile (Underlying_Type (E));
6608 Set_Treat_As_Volatile (E);
6609 Set_Treat_As_Volatile (Underlying_Type (E));
6612 elsif Nkind (Decl) = N_Object_Declaration
6613 or else (Nkind (Decl) = N_Component_Declaration
6614 and then Original_Record_Component (E) = E)
6616 if Rep_Item_Too_Late (E, N) then
6620 if Prag_Id = Pragma_Atomic
6622 Prag_Id = Pragma_Shared
6624 Prag_Id = Pragma_Volatile_Full_Access
6626 if Prag_Id = Pragma_Volatile_Full_Access then
6627 Set_Is_Volatile_Full_Access (E);
6632 -- If the object declaration has an explicit initialization, a
6633 -- temporary may have to be created to hold the expression, to
6634 -- ensure that access to the object remain atomic.
6636 if Nkind (Parent (E)) = N_Object_Declaration
6637 and then Present (Expression (Parent (E)))
6639 Set_Has_Delayed_Freeze (E);
6643 -- Atomic/Shared/Volatile_Full_Access imply Independent
6645 if Prag_Id /= Pragma_Volatile then
6646 Set_Is_Independent (E);
6648 if Prag_Id = Pragma_Independent then
6649 Record_Independence_Check (N, E);
6653 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6655 if Prag_Id /= Pragma_Independent then
6656 Set_Is_Volatile (E);
6657 Set_Treat_As_Volatile (E);
6661 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6664 -- The following check is only relevant when SPARK_Mode is on as
6665 -- this is not a standard Ada legality rule. Pragma Volatile can
6666 -- only apply to a full type declaration or an object declaration
6667 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6668 -- untagged derived types that are rewritten as subtypes of their
6669 -- respective root types.
6672 and then Prag_Id = Pragma_Volatile
6674 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6675 N_Object_Declaration)
6678 ("argument of pragma % must denote a full type or object "
6679 & "declaration", Arg1);
6681 end Process_Atomic_Independent_Shared_Volatile;
6683 -------------------------------------------
6684 -- Process_Compile_Time_Warning_Or_Error --
6685 -------------------------------------------
6687 procedure Process_Compile_Time_Warning_Or_Error is
6688 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6691 Check_Arg_Count (2);
6692 Check_No_Identifiers;
6693 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6694 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6696 if Compile_Time_Known_Value (Arg1x) then
6697 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6699 Str : constant String_Id :=
6700 Strval (Get_Pragma_Arg (Arg2));
6701 Len : constant Nat := String_Length (Str);
6706 Cent : constant Entity_Id :=
6707 Cunit_Entity (Current_Sem_Unit);
6709 Force : constant Boolean :=
6710 Prag_Id = Pragma_Compile_Time_Warning
6712 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6713 and then (Ekind (Cent) /= E_Package
6714 or else not In_Private_Part (Cent));
6715 -- Set True if this is the warning case, and we are in the
6716 -- visible part of a package spec, or in a subprogram spec,
6717 -- in which case we want to force the client to see the
6718 -- warning, even though it is not in the main unit.
6721 -- Loop through segments of message separated by line feeds.
6722 -- We output these segments as separate messages with
6723 -- continuation marks for all but the first.
6728 Error_Msg_Strlen := 0;
6730 -- Loop to copy characters from argument to error message
6734 exit when Ptr > Len;
6735 CC := Get_String_Char (Str, Ptr);
6738 -- Ignore wide chars ??? else store character
6740 if In_Character_Range (CC) then
6741 C := Get_Character (CC);
6742 exit when C = ASCII.LF;
6743 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6744 Error_Msg_String (Error_Msg_Strlen) := C;
6748 -- Here with one line ready to go
6750 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6752 -- If this is a warning in a spec, then we want clients
6753 -- to see the warning, so mark the message with the
6754 -- special sequence !! to force the warning. In the case
6755 -- of a package spec, we do not force this if we are in
6756 -- the private part of the spec.
6759 if Cont = False then
6760 Error_Msg_N ("<<~!!", Arg1);
6763 Error_Msg_N ("\<<~!!", Arg1);
6766 -- Error, rather than warning, or in a body, so we do not
6767 -- need to force visibility for client (error will be
6768 -- output in any case, and this is the situation in which
6769 -- we do not want a client to get a warning, since the
6770 -- warning is in the body or the spec private part).
6773 if Cont = False then
6774 Error_Msg_N ("<<~", Arg1);
6777 Error_Msg_N ("\<<~", Arg1);
6781 exit when Ptr > Len;
6786 end Process_Compile_Time_Warning_Or_Error;
6788 ------------------------
6789 -- Process_Convention --
6790 ------------------------
6792 procedure Process_Convention
6793 (C : out Convention_Id;
6794 Ent : out Entity_Id)
6798 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6799 -- Called if we have more than one Export/Import/Convention pragma.
6800 -- This is generally illegal, but we have a special case of allowing
6801 -- Import and Interface to coexist if they specify the convention in
6802 -- a consistent manner. We are allowed to do this, since Interface is
6803 -- an implementation defined pragma, and we choose to do it since we
6804 -- know Rational allows this combination. S is the entity id of the
6805 -- subprogram in question. This procedure also sets the special flag
6806 -- Import_Interface_Present in both pragmas in the case where we do
6807 -- have matching Import and Interface pragmas.
6809 procedure Set_Convention_From_Pragma (E : Entity_Id);
6810 -- Set convention in entity E, and also flag that the entity has a
6811 -- convention pragma. If entity is for a private or incomplete type,
6812 -- also set convention and flag on underlying type. This procedure
6813 -- also deals with the special case of C_Pass_By_Copy convention,
6814 -- and error checks for inappropriate convention specification.
6816 -------------------------------
6817 -- Diagnose_Multiple_Pragmas --
6818 -------------------------------
6820 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6821 Pdec : constant Node_Id := Declaration_Node (S);
6825 function Same_Convention (Decl : Node_Id) return Boolean;
6826 -- Decl is a pragma node. This function returns True if this
6827 -- pragma has a first argument that is an identifier with a
6828 -- Chars field corresponding to the Convention_Id C.
6830 function Same_Name (Decl : Node_Id) return Boolean;
6831 -- Decl is a pragma node. This function returns True if this
6832 -- pragma has a second argument that is an identifier with a
6833 -- Chars field that matches the Chars of the current subprogram.
6835 ---------------------
6836 -- Same_Convention --
6837 ---------------------
6839 function Same_Convention (Decl : Node_Id) return Boolean is
6840 Arg1 : constant Node_Id :=
6841 First (Pragma_Argument_Associations (Decl));
6844 if Present (Arg1) then
6846 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6848 if Nkind (Arg) = N_Identifier
6849 and then Is_Convention_Name (Chars (Arg))
6850 and then Get_Convention_Id (Chars (Arg)) = C
6858 end Same_Convention;
6864 function Same_Name (Decl : Node_Id) return Boolean is
6865 Arg1 : constant Node_Id :=
6866 First (Pragma_Argument_Associations (Decl));
6874 Arg2 := Next (Arg1);
6881 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6883 if Nkind (Arg) = N_Identifier
6884 and then Chars (Arg) = Chars (S)
6893 -- Start of processing for Diagnose_Multiple_Pragmas
6898 -- Definitely give message if we have Convention/Export here
6900 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6903 -- If we have an Import or Export, scan back from pragma to
6904 -- find any previous pragma applying to the same procedure.
6905 -- The scan will be terminated by the start of the list, or
6906 -- hitting the subprogram declaration. This won't allow one
6907 -- pragma to appear in the public part and one in the private
6908 -- part, but that seems very unlikely in practice.
6912 while Present (Decl) and then Decl /= Pdec loop
6914 -- Look for pragma with same name as us
6916 if Nkind (Decl) = N_Pragma
6917 and then Same_Name (Decl)
6919 -- Give error if same as our pragma or Export/Convention
6921 if Nam_In (Pragma_Name (Decl), Name_Export,
6927 -- Case of Import/Interface or the other way round
6929 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6932 -- Here we know that we have Import and Interface. It
6933 -- doesn't matter which way round they are. See if
6934 -- they specify the same convention. If so, all OK,
6935 -- and set special flags to stop other messages
6937 if Same_Convention (Decl) then
6938 Set_Import_Interface_Present (N);
6939 Set_Import_Interface_Present (Decl);
6942 -- If different conventions, special message
6945 Error_Msg_Sloc := Sloc (Decl);
6947 ("convention differs from that given#", Arg1);
6957 -- Give message if needed if we fall through those tests
6958 -- except on Relaxed_RM_Semantics where we let go: either this
6959 -- is a case accepted/ignored by other Ada compilers (e.g.
6960 -- a mix of Convention and Import), or another error will be
6961 -- generated later (e.g. using both Import and Export).
6963 if Err and not Relaxed_RM_Semantics then
6965 ("at most one Convention/Export/Import pragma is allowed",
6968 end Diagnose_Multiple_Pragmas;
6970 --------------------------------
6971 -- Set_Convention_From_Pragma --
6972 --------------------------------
6974 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6976 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6977 -- for an overridden dispatching operation. Technically this is
6978 -- an amendment and should only be done in Ada 2005 mode. However,
6979 -- this is clearly a mistake, since the problem that is addressed
6980 -- by this AI is that there is a clear gap in the RM.
6982 if Is_Dispatching_Operation (E)
6983 and then Present (Overridden_Operation (E))
6984 and then C /= Convention (Overridden_Operation (E))
6987 ("cannot change convention for overridden dispatching "
6988 & "operation", Arg1);
6991 -- Special checks for Convention_Stdcall
6993 if C = Convention_Stdcall then
6995 -- A dispatching call is not allowed. A dispatching subprogram
6996 -- cannot be used to interface to the Win32 API, so in fact
6997 -- this check does not impose any effective restriction.
6999 if Is_Dispatching_Operation (E) then
7000 Error_Msg_Sloc := Sloc (E);
7002 -- Note: make this unconditional so that if there is more
7003 -- than one call to which the pragma applies, we get a
7004 -- message for each call. Also don't use Error_Pragma,
7005 -- so that we get multiple messages.
7008 ("dispatching subprogram# cannot use Stdcall convention!",
7011 -- Subprograms are not allowed
7013 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7017 and then Ekind (E) /= E_Variable
7019 -- An access to subprogram is also allowed
7023 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7025 -- Allow internal call to set convention of subprogram type
7027 and then not (Ekind (E) = E_Subprogram_Type)
7030 ("second argument of pragma% must be subprogram (type)",
7035 -- Set the convention
7037 Set_Convention (E, C);
7038 Set_Has_Convention_Pragma (E);
7040 -- For the case of a record base type, also set the convention of
7041 -- any anonymous access types declared in the record which do not
7042 -- currently have a specified convention.
7044 if Is_Record_Type (E) and then Is_Base_Type (E) then
7049 Comp := First_Component (E);
7050 while Present (Comp) loop
7051 if Present (Etype (Comp))
7052 and then Ekind_In (Etype (Comp),
7053 E_Anonymous_Access_Type,
7054 E_Anonymous_Access_Subprogram_Type)
7055 and then not Has_Convention_Pragma (Comp)
7057 Set_Convention (Comp, C);
7060 Next_Component (Comp);
7065 -- Deal with incomplete/private type case, where underlying type
7066 -- is available, so set convention of that underlying type.
7068 if Is_Incomplete_Or_Private_Type (E)
7069 and then Present (Underlying_Type (E))
7071 Set_Convention (Underlying_Type (E), C);
7072 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7075 -- A class-wide type should inherit the convention of the specific
7076 -- root type (although this isn't specified clearly by the RM).
7078 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7079 Set_Convention (Class_Wide_Type (E), C);
7082 -- If the entity is a record type, then check for special case of
7083 -- C_Pass_By_Copy, which is treated the same as C except that the
7084 -- special record flag is set. This convention is only permitted
7085 -- on record types (see AI95-00131).
7087 if Cname = Name_C_Pass_By_Copy then
7088 if Is_Record_Type (E) then
7089 Set_C_Pass_By_Copy (Base_Type (E));
7090 elsif Is_Incomplete_Or_Private_Type (E)
7091 and then Is_Record_Type (Underlying_Type (E))
7093 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7096 ("C_Pass_By_Copy convention allowed only for record type",
7101 -- If the entity is a derived boolean type, check for the special
7102 -- case of convention C, C++, or Fortran, where we consider any
7103 -- nonzero value to represent true.
7105 if Is_Discrete_Type (E)
7106 and then Root_Type (Etype (E)) = Standard_Boolean
7112 C = Convention_Fortran)
7114 Set_Nonzero_Is_True (Base_Type (E));
7116 end Set_Convention_From_Pragma;
7120 Comp_Unit : Unit_Number_Type;
7125 -- Start of processing for Process_Convention
7128 Check_At_Least_N_Arguments (2);
7129 Check_Optional_Identifier (Arg1, Name_Convention);
7130 Check_Arg_Is_Identifier (Arg1);
7131 Cname := Chars (Get_Pragma_Arg (Arg1));
7133 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7134 -- tested again below to set the critical flag).
7136 if Cname = Name_C_Pass_By_Copy then
7139 -- Otherwise we must have something in the standard convention list
7141 elsif Is_Convention_Name (Cname) then
7142 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7144 -- Otherwise warn on unrecognized convention
7147 if Warn_On_Export_Import then
7149 ("??unrecognized convention name, C assumed",
7150 Get_Pragma_Arg (Arg1));
7156 Check_Optional_Identifier (Arg2, Name_Entity);
7157 Check_Arg_Is_Local_Name (Arg2);
7159 Id := Get_Pragma_Arg (Arg2);
7162 if not Is_Entity_Name (Id) then
7163 Error_Pragma_Arg ("entity name required", Arg2);
7168 -- Set entity to return
7172 -- Ada_Pass_By_Copy special checking
7174 if C = Convention_Ada_Pass_By_Copy then
7175 if not Is_First_Subtype (E) then
7177 ("convention `Ada_Pass_By_Copy` only allowed for types",
7181 if Is_By_Reference_Type (E) then
7183 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7187 -- Ada_Pass_By_Reference special checking
7189 elsif C = Convention_Ada_Pass_By_Reference then
7190 if not Is_First_Subtype (E) then
7192 ("convention `Ada_Pass_By_Reference` only allowed for types",
7196 if Is_By_Copy_Type (E) then
7198 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7203 -- Go to renamed subprogram if present, since convention applies to
7204 -- the actual renamed entity, not to the renaming entity. If the
7205 -- subprogram is inherited, go to parent subprogram.
7207 if Is_Subprogram (E)
7208 and then Present (Alias (E))
7210 if Nkind (Parent (Declaration_Node (E))) =
7211 N_Subprogram_Renaming_Declaration
7213 if Scope (E) /= Scope (Alias (E)) then
7215 ("cannot apply pragma% to non-local entity&#", E);
7220 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7221 N_Private_Extension_Declaration)
7222 and then Scope (E) = Scope (Alias (E))
7226 -- Return the parent subprogram the entity was inherited from
7232 -- Check that we are not applying this to a specless body. Relax this
7233 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7235 if Is_Subprogram (E)
7236 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7237 and then not Relaxed_RM_Semantics
7240 ("pragma% requires separate spec and must come before body");
7243 -- Check that we are not applying this to a named constant
7245 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7246 Error_Msg_Name_1 := Pname;
7248 ("cannot apply pragma% to named constant!",
7249 Get_Pragma_Arg (Arg2));
7251 ("\supply appropriate type for&!", Arg2);
7254 if Ekind (E) = E_Enumeration_Literal then
7255 Error_Pragma ("enumeration literal not allowed for pragma%");
7258 -- Check for rep item appearing too early or too late
7260 if Etype (E) = Any_Type
7261 or else Rep_Item_Too_Early (E, N)
7265 elsif Present (Underlying_Type (E)) then
7266 E := Underlying_Type (E);
7269 if Rep_Item_Too_Late (E, N) then
7273 if Has_Convention_Pragma (E) then
7274 Diagnose_Multiple_Pragmas (E);
7276 elsif Convention (E) = Convention_Protected
7277 or else Ekind (Scope (E)) = E_Protected_Type
7280 ("a protected operation cannot be given a different convention",
7284 -- For Intrinsic, a subprogram is required
7286 if C = Convention_Intrinsic
7287 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7289 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7291 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7293 ("second argument of pragma% must be a subprogram", Arg2);
7297 -- Deal with non-subprogram cases
7299 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7300 Set_Convention_From_Pragma (E);
7304 -- The pragma must apply to a first subtype, but it can also
7305 -- apply to a generic type in a generic formal part, in which
7306 -- case it will also appear in the corresponding instance.
7308 if Is_Generic_Type (E) or else In_Instance then
7311 Check_First_Subtype (Arg2);
7314 Set_Convention_From_Pragma (Base_Type (E));
7316 -- For access subprograms, we must set the convention on the
7317 -- internally generated directly designated type as well.
7319 if Ekind (E) = E_Access_Subprogram_Type then
7320 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7324 -- For the subprogram case, set proper convention for all homonyms
7325 -- in same scope and the same declarative part, i.e. the same
7326 -- compilation unit.
7329 Comp_Unit := Get_Source_Unit (E);
7330 Set_Convention_From_Pragma (E);
7332 -- Treat a pragma Import as an implicit body, and pragma import
7333 -- as implicit reference (for navigation in GPS).
7335 if Prag_Id = Pragma_Import then
7336 Generate_Reference (E, Id, 'b');
7338 -- For exported entities we restrict the generation of references
7339 -- to entities exported to foreign languages since entities
7340 -- exported to Ada do not provide further information to GPS and
7341 -- add undesired references to the output of the gnatxref tool.
7343 elsif Prag_Id = Pragma_Export
7344 and then Convention (E) /= Convention_Ada
7346 Generate_Reference (E, Id, 'i');
7349 -- If the pragma comes from an aspect, it only applies to the
7350 -- given entity, not its homonyms.
7352 if From_Aspect_Specification (N) then
7356 -- Otherwise Loop through the homonyms of the pragma argument's
7357 -- entity, an apply convention to those in the current scope.
7363 exit when No (E1) or else Scope (E1) /= Current_Scope;
7365 -- Ignore entry for which convention is already set
7367 if Has_Convention_Pragma (E1) then
7371 -- Do not set the pragma on inherited operations or on formal
7374 if Comes_From_Source (E1)
7375 and then Comp_Unit = Get_Source_Unit (E1)
7376 and then not Is_Formal_Subprogram (E1)
7377 and then Nkind (Original_Node (Parent (E1))) /=
7378 N_Full_Type_Declaration
7380 if Present (Alias (E1))
7381 and then Scope (E1) /= Scope (Alias (E1))
7384 ("cannot apply pragma% to non-local entity& declared#",
7388 Set_Convention_From_Pragma (E1);
7390 if Prag_Id = Pragma_Import then
7391 Generate_Reference (E1, Id, 'b');
7399 end Process_Convention;
7401 ----------------------------------------
7402 -- Process_Disable_Enable_Atomic_Sync --
7403 ----------------------------------------
7405 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7407 Check_No_Identifiers;
7408 Check_At_Most_N_Arguments (1);
7410 -- Modeled internally as
7411 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7415 Pragma_Identifier =>
7416 Make_Identifier (Loc, Nam),
7417 Pragma_Argument_Associations => New_List (
7418 Make_Pragma_Argument_Association (Loc,
7420 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7422 if Present (Arg1) then
7423 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7427 end Process_Disable_Enable_Atomic_Sync;
7429 -------------------------------------------------
7430 -- Process_Extended_Import_Export_Internal_Arg --
7431 -------------------------------------------------
7433 procedure Process_Extended_Import_Export_Internal_Arg
7434 (Arg_Internal : Node_Id := Empty)
7437 if No (Arg_Internal) then
7438 Error_Pragma ("Internal parameter required for pragma%");
7441 if Nkind (Arg_Internal) = N_Identifier then
7444 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7445 and then (Prag_Id = Pragma_Import_Function
7447 Prag_Id = Pragma_Export_Function)
7453 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7456 Check_Arg_Is_Local_Name (Arg_Internal);
7457 end Process_Extended_Import_Export_Internal_Arg;
7459 --------------------------------------------------
7460 -- Process_Extended_Import_Export_Object_Pragma --
7461 --------------------------------------------------
7463 procedure Process_Extended_Import_Export_Object_Pragma
7464 (Arg_Internal : Node_Id;
7465 Arg_External : Node_Id;
7471 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7472 Def_Id := Entity (Arg_Internal);
7474 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7476 ("pragma% must designate an object", Arg_Internal);
7479 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7481 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7484 ("previous Common/Psect_Object applies, pragma % not permitted",
7488 if Rep_Item_Too_Late (Def_Id, N) then
7492 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7494 if Present (Arg_Size) then
7495 Check_Arg_Is_External_Name (Arg_Size);
7498 -- Export_Object case
7500 if Prag_Id = Pragma_Export_Object then
7501 if not Is_Library_Level_Entity (Def_Id) then
7503 ("argument for pragma% must be library level entity",
7507 if Ekind (Current_Scope) = E_Generic_Package then
7508 Error_Pragma ("pragma& cannot appear in a generic unit");
7511 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7513 ("exported object must have compile time known size",
7517 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7518 Error_Msg_N ("??duplicate Export_Object pragma", N);
7520 Set_Exported (Def_Id, Arg_Internal);
7523 -- Import_Object case
7526 if Is_Concurrent_Type (Etype (Def_Id)) then
7528 ("cannot use pragma% for task/protected object",
7532 if Ekind (Def_Id) = E_Constant then
7534 ("cannot import a constant", Arg_Internal);
7537 if Warn_On_Export_Import
7538 and then Has_Discriminants (Etype (Def_Id))
7541 ("imported value must be initialized??", Arg_Internal);
7544 if Warn_On_Export_Import
7545 and then Is_Access_Type (Etype (Def_Id))
7548 ("cannot import object of an access type??", Arg_Internal);
7551 if Warn_On_Export_Import
7552 and then Is_Imported (Def_Id)
7554 Error_Msg_N ("??duplicate Import_Object pragma", N);
7556 -- Check for explicit initialization present. Note that an
7557 -- initialization generated by the code generator, e.g. for an
7558 -- access type, does not count here.
7560 elsif Present (Expression (Parent (Def_Id)))
7563 (Original_Node (Expression (Parent (Def_Id))))
7565 Error_Msg_Sloc := Sloc (Def_Id);
7567 ("imported entities cannot be initialized (RM B.1(24))",
7568 "\no initialization allowed for & declared#", Arg1);
7570 Set_Imported (Def_Id);
7571 Note_Possible_Modification (Arg_Internal, Sure => False);
7574 end Process_Extended_Import_Export_Object_Pragma;
7576 ------------------------------------------------------
7577 -- Process_Extended_Import_Export_Subprogram_Pragma --
7578 ------------------------------------------------------
7580 procedure Process_Extended_Import_Export_Subprogram_Pragma
7581 (Arg_Internal : Node_Id;
7582 Arg_External : Node_Id;
7583 Arg_Parameter_Types : Node_Id;
7584 Arg_Result_Type : Node_Id := Empty;
7585 Arg_Mechanism : Node_Id;
7586 Arg_Result_Mechanism : Node_Id := Empty)
7592 Ambiguous : Boolean;
7595 function Same_Base_Type
7597 Formal : Entity_Id) return Boolean;
7598 -- Determines if Ptype references the type of Formal. Note that only
7599 -- the base types need to match according to the spec. Ptype here is
7600 -- the argument from the pragma, which is either a type name, or an
7601 -- access attribute.
7603 --------------------
7604 -- Same_Base_Type --
7605 --------------------
7607 function Same_Base_Type
7609 Formal : Entity_Id) return Boolean
7611 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7615 -- Case where pragma argument is typ'Access
7617 if Nkind (Ptype) = N_Attribute_Reference
7618 and then Attribute_Name (Ptype) = Name_Access
7620 Pref := Prefix (Ptype);
7623 if not Is_Entity_Name (Pref)
7624 or else Entity (Pref) = Any_Type
7629 -- We have a match if the corresponding argument is of an
7630 -- anonymous access type, and its designated type matches the
7631 -- type of the prefix of the access attribute
7633 return Ekind (Ftyp) = E_Anonymous_Access_Type
7634 and then Base_Type (Entity (Pref)) =
7635 Base_Type (Etype (Designated_Type (Ftyp)));
7637 -- Case where pragma argument is a type name
7642 if not Is_Entity_Name (Ptype)
7643 or else Entity (Ptype) = Any_Type
7648 -- We have a match if the corresponding argument is of the type
7649 -- given in the pragma (comparing base types)
7651 return Base_Type (Entity (Ptype)) = Ftyp;
7655 -- Start of processing for
7656 -- Process_Extended_Import_Export_Subprogram_Pragma
7659 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7663 -- Loop through homonyms (overloadings) of the entity
7665 Hom_Id := Entity (Arg_Internal);
7666 while Present (Hom_Id) loop
7667 Def_Id := Get_Base_Subprogram (Hom_Id);
7669 -- We need a subprogram in the current scope
7671 if not Is_Subprogram (Def_Id)
7672 or else Scope (Def_Id) /= Current_Scope
7679 -- Pragma cannot apply to subprogram body
7681 if Is_Subprogram (Def_Id)
7682 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7686 ("pragma% requires separate spec"
7687 & " and must come before body");
7690 -- Test result type if given, note that the result type
7691 -- parameter can only be present for the function cases.
7693 if Present (Arg_Result_Type)
7694 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7698 elsif Etype (Def_Id) /= Standard_Void_Type
7700 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7704 -- Test parameter types if given. Note that this parameter
7705 -- has not been analyzed (and must not be, since it is
7706 -- semantic nonsense), so we get it as the parser left it.
7708 elsif Present (Arg_Parameter_Types) then
7709 Check_Matching_Types : declare
7714 Formal := First_Formal (Def_Id);
7716 if Nkind (Arg_Parameter_Types) = N_Null then
7717 if Present (Formal) then
7721 -- A list of one type, e.g. (List) is parsed as
7722 -- a parenthesized expression.
7724 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7725 and then Paren_Count (Arg_Parameter_Types) = 1
7728 or else Present (Next_Formal (Formal))
7733 Same_Base_Type (Arg_Parameter_Types, Formal);
7736 -- A list of more than one type is parsed as a aggregate
7738 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7739 and then Paren_Count (Arg_Parameter_Types) = 0
7741 Ptype := First (Expressions (Arg_Parameter_Types));
7742 while Present (Ptype) or else Present (Formal) loop
7745 or else not Same_Base_Type (Ptype, Formal)
7750 Next_Formal (Formal);
7755 -- Anything else is of the wrong form
7759 ("wrong form for Parameter_Types parameter",
7760 Arg_Parameter_Types);
7762 end Check_Matching_Types;
7765 -- Match is now False if the entry we found did not match
7766 -- either a supplied Parameter_Types or Result_Types argument
7772 -- Ambiguous case, the flag Ambiguous shows if we already
7773 -- detected this and output the initial messages.
7776 if not Ambiguous then
7778 Error_Msg_Name_1 := Pname;
7780 ("pragma% does not uniquely identify subprogram!",
7782 Error_Msg_Sloc := Sloc (Ent);
7783 Error_Msg_N ("matching subprogram #!", N);
7787 Error_Msg_Sloc := Sloc (Def_Id);
7788 Error_Msg_N ("matching subprogram #!", N);
7793 Hom_Id := Homonym (Hom_Id);
7796 -- See if we found an entry
7799 if not Ambiguous then
7800 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7802 ("pragma% cannot be given for generic subprogram");
7805 ("pragma% does not identify local subprogram");
7812 -- Import pragmas must be for imported entities
7814 if Prag_Id = Pragma_Import_Function
7816 Prag_Id = Pragma_Import_Procedure
7818 Prag_Id = Pragma_Import_Valued_Procedure
7820 if not Is_Imported (Ent) then
7822 ("pragma Import or Interface must precede pragma%");
7825 -- Here we have the Export case which can set the entity as exported
7827 -- But does not do so if the specified external name is null, since
7828 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7829 -- compatible) to request no external name.
7831 elsif Nkind (Arg_External) = N_String_Literal
7832 and then String_Length (Strval (Arg_External)) = 0
7836 -- In all other cases, set entity as exported
7839 Set_Exported (Ent, Arg_Internal);
7842 -- Special processing for Valued_Procedure cases
7844 if Prag_Id = Pragma_Import_Valued_Procedure
7846 Prag_Id = Pragma_Export_Valued_Procedure
7848 Formal := First_Formal (Ent);
7851 Error_Pragma ("at least one parameter required for pragma%");
7853 elsif Ekind (Formal) /= E_Out_Parameter then
7854 Error_Pragma ("first parameter must have mode out for pragma%");
7857 Set_Is_Valued_Procedure (Ent);
7861 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7863 -- Process Result_Mechanism argument if present. We have already
7864 -- checked that this is only allowed for the function case.
7866 if Present (Arg_Result_Mechanism) then
7867 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7870 -- Process Mechanism parameter if present. Note that this parameter
7871 -- is not analyzed, and must not be analyzed since it is semantic
7872 -- nonsense, so we get it in exactly as the parser left it.
7874 if Present (Arg_Mechanism) then
7882 -- A single mechanism association without a formal parameter
7883 -- name is parsed as a parenthesized expression. All other
7884 -- cases are parsed as aggregates, so we rewrite the single
7885 -- parameter case as an aggregate for consistency.
7887 if Nkind (Arg_Mechanism) /= N_Aggregate
7888 and then Paren_Count (Arg_Mechanism) = 1
7890 Rewrite (Arg_Mechanism,
7891 Make_Aggregate (Sloc (Arg_Mechanism),
7892 Expressions => New_List (
7893 Relocate_Node (Arg_Mechanism))));
7896 -- Case of only mechanism name given, applies to all formals
7898 if Nkind (Arg_Mechanism) /= N_Aggregate then
7899 Formal := First_Formal (Ent);
7900 while Present (Formal) loop
7901 Set_Mechanism_Value (Formal, Arg_Mechanism);
7902 Next_Formal (Formal);
7905 -- Case of list of mechanism associations given
7908 if Null_Record_Present (Arg_Mechanism) then
7910 ("inappropriate form for Mechanism parameter",
7914 -- Deal with positional ones first
7916 Formal := First_Formal (Ent);
7918 if Present (Expressions (Arg_Mechanism)) then
7919 Mname := First (Expressions (Arg_Mechanism));
7920 while Present (Mname) loop
7923 ("too many mechanism associations", Mname);
7926 Set_Mechanism_Value (Formal, Mname);
7927 Next_Formal (Formal);
7932 -- Deal with named entries
7934 if Present (Component_Associations (Arg_Mechanism)) then
7935 Massoc := First (Component_Associations (Arg_Mechanism));
7936 while Present (Massoc) loop
7937 Choice := First (Choices (Massoc));
7939 if Nkind (Choice) /= N_Identifier
7940 or else Present (Next (Choice))
7943 ("incorrect form for mechanism association",
7947 Formal := First_Formal (Ent);
7951 ("parameter name & not present", Choice);
7954 if Chars (Choice) = Chars (Formal) then
7956 (Formal, Expression (Massoc));
7958 -- Set entity on identifier (needed by ASIS)
7960 Set_Entity (Choice, Formal);
7965 Next_Formal (Formal);
7974 end Process_Extended_Import_Export_Subprogram_Pragma;
7976 --------------------------
7977 -- Process_Generic_List --
7978 --------------------------
7980 procedure Process_Generic_List is
7985 Check_No_Identifiers;
7986 Check_At_Least_N_Arguments (1);
7988 -- Check all arguments are names of generic units or instances
7991 while Present (Arg) loop
7992 Exp := Get_Pragma_Arg (Arg);
7995 if not Is_Entity_Name (Exp)
7997 (not Is_Generic_Instance (Entity (Exp))
7999 not Is_Generic_Unit (Entity (Exp)))
8002 ("pragma% argument must be name of generic unit/instance",
8008 end Process_Generic_List;
8010 ------------------------------------
8011 -- Process_Import_Predefined_Type --
8012 ------------------------------------
8014 procedure Process_Import_Predefined_Type is
8015 Loc : constant Source_Ptr := Sloc (N);
8017 Ftyp : Node_Id := Empty;
8023 String_To_Name_Buffer (Strval (Expression (Arg3)));
8026 Elmt := First_Elmt (Predefined_Float_Types);
8027 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8031 Ftyp := Node (Elmt);
8033 if Present (Ftyp) then
8035 -- Don't build a derived type declaration, because predefined C
8036 -- types have no declaration anywhere, so cannot really be named.
8037 -- Instead build a full type declaration, starting with an
8038 -- appropriate type definition is built
8040 if Is_Floating_Point_Type (Ftyp) then
8041 Def := Make_Floating_Point_Definition (Loc,
8042 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8043 Make_Real_Range_Specification (Loc,
8044 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8045 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8047 -- Should never have a predefined type we cannot handle
8050 raise Program_Error;
8053 -- Build and insert a Full_Type_Declaration, which will be
8054 -- analyzed as soon as this list entry has been analyzed.
8056 Decl := Make_Full_Type_Declaration (Loc,
8057 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8058 Type_Definition => Def);
8060 Insert_After (N, Decl);
8061 Mark_Rewrite_Insertion (Decl);
8064 Error_Pragma_Arg ("no matching type found for pragma%",
8067 end Process_Import_Predefined_Type;
8069 ---------------------------------
8070 -- Process_Import_Or_Interface --
8071 ---------------------------------
8073 procedure Process_Import_Or_Interface is
8079 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8080 -- pragma Import (Entity, "external name");
8082 if Relaxed_RM_Semantics
8083 and then Arg_Count = 2
8084 and then Prag_Id = Pragma_Import
8085 and then Nkind (Expression (Arg2)) = N_String_Literal
8088 Def_Id := Get_Pragma_Arg (Arg1);
8091 if not Is_Entity_Name (Def_Id) then
8092 Error_Pragma_Arg ("entity name required", Arg1);
8095 Def_Id := Entity (Def_Id);
8096 Kill_Size_Check_Code (Def_Id);
8097 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8100 Process_Convention (C, Def_Id);
8102 -- A pragma that applies to a Ghost entity becomes Ghost for the
8103 -- purposes of legality checks and removal of ignored Ghost code.
8105 Mark_Pragma_As_Ghost (N, Def_Id);
8106 Kill_Size_Check_Code (Def_Id);
8107 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8110 -- Various error checks
8112 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8114 -- We do not permit Import to apply to a renaming declaration
8116 if Present (Renamed_Object (Def_Id)) then
8118 ("pragma% not allowed for object renaming", Arg2);
8120 -- User initialization is not allowed for imported object, but
8121 -- the object declaration may contain a default initialization,
8122 -- that will be discarded. Note that an explicit initialization
8123 -- only counts if it comes from source, otherwise it is simply
8124 -- the code generator making an implicit initialization explicit.
8126 elsif Present (Expression (Parent (Def_Id)))
8127 and then Comes_From_Source
8128 (Original_Node (Expression (Parent (Def_Id))))
8130 -- Set imported flag to prevent cascaded errors
8132 Set_Is_Imported (Def_Id);
8134 Error_Msg_Sloc := Sloc (Def_Id);
8136 ("no initialization allowed for declaration of& #",
8137 "\imported entities cannot be initialized (RM B.1(24))",
8141 -- If the pragma comes from an aspect specification the
8142 -- Is_Imported flag has already been set.
8144 if not From_Aspect_Specification (N) then
8145 Set_Imported (Def_Id);
8148 Process_Interface_Name (Def_Id, Arg3, Arg4);
8150 -- Note that we do not set Is_Public here. That's because we
8151 -- only want to set it if there is no address clause, and we
8152 -- don't know that yet, so we delay that processing till
8155 -- pragma Import completes deferred constants
8157 if Ekind (Def_Id) = E_Constant then
8158 Set_Has_Completion (Def_Id);
8161 -- It is not possible to import a constant of an unconstrained
8162 -- array type (e.g. string) because there is no simple way to
8163 -- write a meaningful subtype for it.
8165 if Is_Array_Type (Etype (Def_Id))
8166 and then not Is_Constrained (Etype (Def_Id))
8169 ("imported constant& must have a constrained subtype",
8174 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8176 -- If the name is overloaded, pragma applies to all of the denoted
8177 -- entities in the same declarative part, unless the pragma comes
8178 -- from an aspect specification or was generated by the compiler
8179 -- (such as for pragma Provide_Shift_Operators).
8182 while Present (Hom_Id) loop
8184 Def_Id := Get_Base_Subprogram (Hom_Id);
8186 -- Ignore inherited subprograms because the pragma will apply
8187 -- to the parent operation, which is the one called.
8189 if Is_Overloadable (Def_Id)
8190 and then Present (Alias (Def_Id))
8194 -- If it is not a subprogram, it must be in an outer scope and
8195 -- pragma does not apply.
8197 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8200 -- The pragma does not apply to primitives of interfaces
8202 elsif Is_Dispatching_Operation (Def_Id)
8203 and then Present (Find_Dispatching_Type (Def_Id))
8204 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8208 -- Verify that the homonym is in the same declarative part (not
8209 -- just the same scope). If the pragma comes from an aspect
8210 -- specification we know that it is part of the declaration.
8212 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8213 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8214 and then not From_Aspect_Specification (N)
8219 -- If the pragma comes from an aspect specification the
8220 -- Is_Imported flag has already been set.
8222 if not From_Aspect_Specification (N) then
8223 Set_Imported (Def_Id);
8226 -- Reject an Import applied to an abstract subprogram
8228 if Is_Subprogram (Def_Id)
8229 and then Is_Abstract_Subprogram (Def_Id)
8231 Error_Msg_Sloc := Sloc (Def_Id);
8233 ("cannot import abstract subprogram& declared#",
8237 -- Special processing for Convention_Intrinsic
8239 if C = Convention_Intrinsic then
8241 -- Link_Name argument not allowed for intrinsic
8245 Set_Is_Intrinsic_Subprogram (Def_Id);
8247 -- If no external name is present, then check that this
8248 -- is a valid intrinsic subprogram. If an external name
8249 -- is present, then this is handled by the back end.
8252 Check_Intrinsic_Subprogram
8253 (Def_Id, Get_Pragma_Arg (Arg2));
8257 -- Verify that the subprogram does not have a completion
8258 -- through a renaming declaration. For other completions the
8259 -- pragma appears as a too late representation.
8262 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8266 and then Nkind (Decl) = N_Subprogram_Declaration
8267 and then Present (Corresponding_Body (Decl))
8268 and then Nkind (Unit_Declaration_Node
8269 (Corresponding_Body (Decl))) =
8270 N_Subprogram_Renaming_Declaration
8272 Error_Msg_Sloc := Sloc (Def_Id);
8274 ("cannot import&, renaming already provided for "
8275 & "declaration #", N, Def_Id);
8279 -- If the pragma comes from an aspect specification, there
8280 -- must be an Import aspect specified as well. In the rare
8281 -- case where Import is set to False, the suprogram needs to
8282 -- have a local completion.
8285 Imp_Aspect : constant Node_Id :=
8286 Find_Aspect (Def_Id, Aspect_Import);
8290 if Present (Imp_Aspect)
8291 and then Present (Expression (Imp_Aspect))
8293 Expr := Expression (Imp_Aspect);
8294 Analyze_And_Resolve (Expr, Standard_Boolean);
8296 if Is_Entity_Name (Expr)
8297 and then Entity (Expr) = Standard_True
8299 Set_Has_Completion (Def_Id);
8302 -- If there is no expression, the default is True, as for
8303 -- all boolean aspects. Same for the older pragma.
8306 Set_Has_Completion (Def_Id);
8310 Process_Interface_Name (Def_Id, Arg3, Arg4);
8313 if Is_Compilation_Unit (Hom_Id) then
8315 -- Its possible homonyms are not affected by the pragma.
8316 -- Such homonyms might be present in the context of other
8317 -- units being compiled.
8321 elsif From_Aspect_Specification (N) then
8324 -- If the pragma was created by the compiler, then we don't
8325 -- want it to apply to other homonyms. This kind of case can
8326 -- occur when using pragma Provide_Shift_Operators, which
8327 -- generates implicit shift and rotate operators with Import
8328 -- pragmas that might apply to earlier explicit or implicit
8329 -- declarations marked with Import (for example, coming from
8330 -- an earlier pragma Provide_Shift_Operators for another type),
8331 -- and we don't generally want other homonyms being treated
8332 -- as imported or the pragma flagged as an illegal duplicate.
8334 elsif not Comes_From_Source (N) then
8338 Hom_Id := Homonym (Hom_Id);
8342 -- Import a CPP class
8344 elsif C = Convention_CPP
8345 and then (Is_Record_Type (Def_Id)
8346 or else Ekind (Def_Id) = E_Incomplete_Type)
8348 if Ekind (Def_Id) = E_Incomplete_Type then
8349 if Present (Full_View (Def_Id)) then
8350 Def_Id := Full_View (Def_Id);
8354 ("cannot import 'C'P'P type before full declaration seen",
8355 Get_Pragma_Arg (Arg2));
8357 -- Although we have reported the error we decorate it as
8358 -- CPP_Class to avoid reporting spurious errors
8360 Set_Is_CPP_Class (Def_Id);
8365 -- Types treated as CPP classes must be declared limited (note:
8366 -- this used to be a warning but there is no real benefit to it
8367 -- since we did effectively intend to treat the type as limited
8370 if not Is_Limited_Type (Def_Id) then
8372 ("imported 'C'P'P type must be limited",
8373 Get_Pragma_Arg (Arg2));
8376 if Etype (Def_Id) /= Def_Id
8377 and then not Is_CPP_Class (Root_Type (Def_Id))
8379 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8382 Set_Is_CPP_Class (Def_Id);
8384 -- Imported CPP types must not have discriminants (because C++
8385 -- classes do not have discriminants).
8387 if Has_Discriminants (Def_Id) then
8389 ("imported 'C'P'P type cannot have discriminants",
8390 First (Discriminant_Specifications
8391 (Declaration_Node (Def_Id))));
8394 -- Check that components of imported CPP types do not have default
8395 -- expressions. For private types this check is performed when the
8396 -- full view is analyzed (see Process_Full_View).
8398 if not Is_Private_Type (Def_Id) then
8399 Check_CPP_Type_Has_No_Defaults (Def_Id);
8402 -- Import a CPP exception
8404 elsif C = Convention_CPP
8405 and then Ekind (Def_Id) = E_Exception
8409 ("'External_'Name arguments is required for 'Cpp exception",
8412 -- As only a string is allowed, Check_Arg_Is_External_Name
8415 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8418 if Present (Arg4) then
8420 ("Link_Name argument not allowed for imported Cpp exception",
8424 -- Do not call Set_Interface_Name as the name of the exception
8425 -- shouldn't be modified (and in particular it shouldn't be
8426 -- the External_Name). For exceptions, the External_Name is the
8427 -- name of the RTTI structure.
8429 -- ??? Emit an error if pragma Import/Export_Exception is present
8431 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8433 Check_Arg_Count (3);
8434 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8436 Process_Import_Predefined_Type;
8440 ("second argument of pragma% must be object, subprogram "
8441 & "or incomplete type",
8445 -- If this pragma applies to a compilation unit, then the unit, which
8446 -- is a subprogram, does not require (or allow) a body. We also do
8447 -- not need to elaborate imported procedures.
8449 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8451 Cunit : constant Node_Id := Parent (Parent (N));
8453 Set_Body_Required (Cunit, False);
8456 end Process_Import_Or_Interface;
8458 --------------------
8459 -- Process_Inline --
8460 --------------------
8462 procedure Process_Inline (Status : Inline_Status) is
8469 Ghost_Error_Posted : Boolean := False;
8470 -- Flag set when an error concerning the illegal mix of Ghost and
8471 -- non-Ghost subprograms is emitted.
8473 Ghost_Id : Entity_Id := Empty;
8474 -- The entity of the first Ghost subprogram encountered while
8475 -- processing the arguments of the pragma.
8477 procedure Make_Inline (Subp : Entity_Id);
8478 -- Subp is the defining unit name of the subprogram declaration. Set
8479 -- the flag, as well as the flag in the corresponding body, if there
8482 procedure Set_Inline_Flags (Subp : Entity_Id);
8483 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8484 -- Has_Pragma_Inline_Always for the Inline_Always case.
8486 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8487 -- Returns True if it can be determined at this stage that inlining
8488 -- is not possible, for example if the body is available and contains
8489 -- exception handlers, we prevent inlining, since otherwise we can
8490 -- get undefined symbols at link time. This function also emits a
8491 -- warning if front-end inlining is enabled and the pragma appears
8494 -- ??? is business with link symbols still valid, or does it relate
8495 -- to front end ZCX which is being phased out ???
8497 ---------------------------
8498 -- Inlining_Not_Possible --
8499 ---------------------------
8501 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8502 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8506 if Nkind (Decl) = N_Subprogram_Body then
8507 Stats := Handled_Statement_Sequence (Decl);
8508 return Present (Exception_Handlers (Stats))
8509 or else Present (At_End_Proc (Stats));
8511 elsif Nkind (Decl) = N_Subprogram_Declaration
8512 and then Present (Corresponding_Body (Decl))
8514 if Front_End_Inlining
8515 and then Analyzed (Corresponding_Body (Decl))
8517 Error_Msg_N ("pragma appears too late, ignored??", N);
8520 -- If the subprogram is a renaming as body, the body is just a
8521 -- call to the renamed subprogram, and inlining is trivially
8525 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8526 N_Subprogram_Renaming_Declaration
8532 Handled_Statement_Sequence
8533 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8536 Present (Exception_Handlers (Stats))
8537 or else Present (At_End_Proc (Stats));
8541 -- If body is not available, assume the best, the check is
8542 -- performed again when compiling enclosing package bodies.
8546 end Inlining_Not_Possible;
8552 procedure Make_Inline (Subp : Entity_Id) is
8553 Kind : constant Entity_Kind := Ekind (Subp);
8554 Inner_Subp : Entity_Id := Subp;
8557 -- Ignore if bad type, avoid cascaded error
8559 if Etype (Subp) = Any_Type then
8563 -- If inlining is not possible, for now do not treat as an error
8565 elsif Status /= Suppressed
8566 and then Inlining_Not_Possible (Subp)
8571 -- Here we have a candidate for inlining, but we must exclude
8572 -- derived operations. Otherwise we would end up trying to inline
8573 -- a phantom declaration, and the result would be to drag in a
8574 -- body which has no direct inlining associated with it. That
8575 -- would not only be inefficient but would also result in the
8576 -- backend doing cross-unit inlining in cases where it was
8577 -- definitely inappropriate to do so.
8579 -- However, a simple Comes_From_Source test is insufficient, since
8580 -- we do want to allow inlining of generic instances which also do
8581 -- not come from source. We also need to recognize specs generated
8582 -- by the front-end for bodies that carry the pragma. Finally,
8583 -- predefined operators do not come from source but are not
8584 -- inlineable either.
8586 elsif Is_Generic_Instance (Subp)
8587 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8591 elsif not Comes_From_Source (Subp)
8592 and then Scope (Subp) /= Standard_Standard
8598 -- The referenced entity must either be the enclosing entity, or
8599 -- an entity declared within the current open scope.
8601 if Present (Scope (Subp))
8602 and then Scope (Subp) /= Current_Scope
8603 and then Subp /= Current_Scope
8606 ("argument of% must be entity in current scope", Assoc);
8610 -- Processing for procedure, operator or function. If subprogram
8611 -- is aliased (as for an instance) indicate that the renamed
8612 -- entity (if declared in the same unit) is inlined.
8613 -- If this is the anonymous subprogram created for a subprogram
8614 -- instance, the inlining applies to it directly. Otherwise we
8615 -- retrieve it as the alias of the visible subprogram instance.
8617 if Is_Subprogram (Subp) then
8618 if Is_Wrapper_Package (Scope (Subp)) then
8621 Inner_Subp := Ultimate_Alias (Inner_Subp);
8624 if In_Same_Source_Unit (Subp, Inner_Subp) then
8625 Set_Inline_Flags (Inner_Subp);
8627 Decl := Parent (Parent (Inner_Subp));
8629 if Nkind (Decl) = N_Subprogram_Declaration
8630 and then Present (Corresponding_Body (Decl))
8632 Set_Inline_Flags (Corresponding_Body (Decl));
8634 elsif Is_Generic_Instance (Subp)
8635 and then Comes_From_Source (Subp)
8637 -- Indicate that the body needs to be created for
8638 -- inlining subsequent calls. The instantiation node
8639 -- follows the declaration of the wrapper package
8640 -- created for it. The subprogram that requires the
8641 -- body is the anonymous one in the wrapper package.
8643 if Scope (Subp) /= Standard_Standard
8645 Need_Subprogram_Instance_Body
8646 (Next (Unit_Declaration_Node
8647 (Scope (Alias (Subp)))), Subp)
8652 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8653 -- appear in a formal part to apply to a formal subprogram.
8654 -- Do not apply check within an instance or a formal package
8655 -- the test will have been applied to the original generic.
8657 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8658 and then List_Containing (Decl) = List_Containing (N)
8659 and then not In_Instance
8662 ("Inline cannot apply to a formal subprogram", N);
8664 -- If Subp is a renaming, it is the renamed entity that
8665 -- will appear in any call, and be inlined. However, for
8666 -- ASIS uses it is convenient to indicate that the renaming
8667 -- itself is an inlined subprogram, so that some gnatcheck
8668 -- rules can be applied in the absence of expansion.
8670 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8671 Set_Inline_Flags (Subp);
8677 -- For a generic subprogram set flag as well, for use at the point
8678 -- of instantiation, to determine whether the body should be
8681 elsif Is_Generic_Subprogram (Subp) then
8682 Set_Inline_Flags (Subp);
8685 -- Literals are by definition inlined
8687 elsif Kind = E_Enumeration_Literal then
8690 -- Anything else is an error
8694 ("expect subprogram name for pragma%", Assoc);
8698 ----------------------
8699 -- Set_Inline_Flags --
8700 ----------------------
8702 procedure Set_Inline_Flags (Subp : Entity_Id) is
8704 -- First set the Has_Pragma_XXX flags and issue the appropriate
8705 -- errors and warnings for suspicious combinations.
8707 if Prag_Id = Pragma_No_Inline then
8708 if Has_Pragma_Inline_Always (Subp) then
8710 ("Inline_Always and No_Inline are mutually exclusive", N);
8711 elsif Has_Pragma_Inline (Subp) then
8713 ("Inline and No_Inline both specified for& ??",
8714 N, Entity (Subp_Id));
8717 Set_Has_Pragma_No_Inline (Subp);
8719 if Prag_Id = Pragma_Inline_Always then
8720 if Has_Pragma_No_Inline (Subp) then
8722 ("Inline_Always and No_Inline are mutually exclusive",
8726 Set_Has_Pragma_Inline_Always (Subp);
8728 if Has_Pragma_No_Inline (Subp) then
8730 ("Inline and No_Inline both specified for& ??",
8731 N, Entity (Subp_Id));
8735 if not Has_Pragma_Inline (Subp) then
8736 Set_Has_Pragma_Inline (Subp);
8740 -- Then adjust the Is_Inlined flag. It can never be set if the
8741 -- subprogram is subject to pragma No_Inline.
8745 Set_Is_Inlined (Subp, False);
8749 if not Has_Pragma_No_Inline (Subp) then
8750 Set_Is_Inlined (Subp, True);
8754 -- A pragma that applies to a Ghost entity becomes Ghost for the
8755 -- purposes of legality checks and removal of ignored Ghost code.
8757 Mark_Pragma_As_Ghost (N, Subp);
8759 -- Capture the entity of the first Ghost subprogram being
8760 -- processed for error detection purposes.
8762 if Is_Ghost_Entity (Subp) then
8763 if No (Ghost_Id) then
8767 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8768 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8770 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
8771 Ghost_Error_Posted := True;
8773 Error_Msg_Name_1 := Pname;
8775 ("pragma % cannot mention ghost and non-ghost subprograms",
8778 Error_Msg_Sloc := Sloc (Ghost_Id);
8779 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
8781 Error_Msg_Sloc := Sloc (Subp);
8782 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
8784 end Set_Inline_Flags;
8786 -- Start of processing for Process_Inline
8789 Check_No_Identifiers;
8790 Check_At_Least_N_Arguments (1);
8792 if Status = Enabled then
8793 Inline_Processing_Required := True;
8797 while Present (Assoc) loop
8798 Subp_Id := Get_Pragma_Arg (Assoc);
8802 if Is_Entity_Name (Subp_Id) then
8803 Subp := Entity (Subp_Id);
8805 if Subp = Any_Id then
8807 -- If previous error, avoid cascaded errors
8809 Check_Error_Detected;
8815 -- For the pragma case, climb homonym chain. This is
8816 -- what implements allowing the pragma in the renaming
8817 -- case, with the result applying to the ancestors, and
8818 -- also allows Inline to apply to all previous homonyms.
8820 if not From_Aspect_Specification (N) then
8821 while Present (Homonym (Subp))
8822 and then Scope (Homonym (Subp)) = Current_Scope
8824 Make_Inline (Homonym (Subp));
8825 Subp := Homonym (Subp);
8832 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
8839 ----------------------------
8840 -- Process_Interface_Name --
8841 ----------------------------
8843 procedure Process_Interface_Name
8844 (Subprogram_Def : Entity_Id;
8850 String_Val : String_Id;
8852 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
8853 -- SN is a string literal node for an interface name. This routine
8854 -- performs some minimal checks that the name is reasonable. In
8855 -- particular that no spaces or other obviously incorrect characters
8856 -- appear. This is only a warning, since any characters are allowed.
8858 ----------------------------------
8859 -- Check_Form_Of_Interface_Name --
8860 ----------------------------------
8862 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
8863 S : constant String_Id := Strval (Expr_Value_S (SN));
8864 SL : constant Nat := String_Length (S);
8869 Error_Msg_N ("interface name cannot be null string", SN);
8872 for J in 1 .. SL loop
8873 C := Get_String_Char (S, J);
8875 -- Look for dubious character and issue unconditional warning.
8876 -- Definitely dubious if not in character range.
8878 if not In_Character_Range (C)
8880 -- Commas, spaces and (back)slashes are dubious
8882 or else Get_Character (C) = ','
8883 or else Get_Character (C) = '\'
8884 or else Get_Character (C) = ' '
8885 or else Get_Character (C) = '/'
8888 ("??interface name contains illegal character",
8889 Sloc (SN) + Source_Ptr (J));
8892 end Check_Form_Of_Interface_Name;
8894 -- Start of processing for Process_Interface_Name
8897 if No (Link_Arg) then
8898 if No (Ext_Arg) then
8901 elsif Chars (Ext_Arg) = Name_Link_Name then
8903 Link_Nam := Expression (Ext_Arg);
8906 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8907 Ext_Nam := Expression (Ext_Arg);
8912 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8913 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8914 Ext_Nam := Expression (Ext_Arg);
8915 Link_Nam := Expression (Link_Arg);
8918 -- Check expressions for external name and link name are static
8920 if Present (Ext_Nam) then
8921 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8922 Check_Form_Of_Interface_Name (Ext_Nam);
8924 -- Verify that external name is not the name of a local entity,
8925 -- which would hide the imported one and could lead to run-time
8926 -- surprises. The problem can only arise for entities declared in
8927 -- a package body (otherwise the external name is fully qualified
8928 -- and will not conflict).
8936 if Prag_Id = Pragma_Import then
8937 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8939 E := Entity_Id (Get_Name_Table_Int (Nam));
8941 if Nam /= Chars (Subprogram_Def)
8942 and then Present (E)
8943 and then not Is_Overloadable (E)
8944 and then Is_Immediately_Visible (E)
8945 and then not Is_Imported (E)
8946 and then Ekind (Scope (E)) = E_Package
8949 while Present (Par) loop
8950 if Nkind (Par) = N_Package_Body then
8951 Error_Msg_Sloc := Sloc (E);
8953 ("imported entity is hidden by & declared#",
8958 Par := Parent (Par);
8965 if Present (Link_Nam) then
8966 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8967 Check_Form_Of_Interface_Name (Link_Nam);
8970 -- If there is no link name, just set the external name
8972 if No (Link_Nam) then
8973 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8975 -- For the Link_Name case, the given literal is preceded by an
8976 -- asterisk, which indicates to GCC that the given name should be
8977 -- taken literally, and in particular that no prepending of
8978 -- underlines should occur, even in systems where this is the
8983 Store_String_Char (Get_Char_Code ('*'));
8984 String_Val := Strval (Expr_Value_S (Link_Nam));
8985 Store_String_Chars (String_Val);
8987 Make_String_Literal (Sloc (Link_Nam),
8988 Strval => End_String);
8991 -- Set the interface name. If the entity is a generic instance, use
8992 -- its alias, which is the callable entity.
8994 if Is_Generic_Instance (Subprogram_Def) then
8995 Set_Encoded_Interface_Name
8996 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8998 Set_Encoded_Interface_Name
8999 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9002 Check_Duplicated_Export_Name (Link_Nam);
9003 end Process_Interface_Name;
9005 -----------------------------------------
9006 -- Process_Interrupt_Or_Attach_Handler --
9007 -----------------------------------------
9009 procedure Process_Interrupt_Or_Attach_Handler is
9010 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9011 Prot_Typ : constant Entity_Id := Scope (Handler);
9014 -- A pragma that applies to a Ghost entity becomes Ghost for the
9015 -- purposes of legality checks and removal of ignored Ghost code.
9017 Mark_Pragma_As_Ghost (N, Handler);
9018 Set_Is_Interrupt_Handler (Handler);
9020 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9022 Record_Rep_Item (Prot_Typ, N);
9024 -- Chain the pragma on the contract for completeness
9026 Add_Contract_Item (N, Handler);
9027 end Process_Interrupt_Or_Attach_Handler;
9029 --------------------------------------------------
9030 -- Process_Restrictions_Or_Restriction_Warnings --
9031 --------------------------------------------------
9033 -- Note: some of the simple identifier cases were handled in par-prag,
9034 -- but it is harmless (and more straightforward) to simply handle all
9035 -- cases here, even if it means we repeat a bit of work in some cases.
9037 procedure Process_Restrictions_Or_Restriction_Warnings
9041 R_Id : Restriction_Id;
9047 -- Ignore all Restrictions pragmas in CodePeer mode
9049 if CodePeer_Mode then
9053 Check_Ada_83_Warning;
9054 Check_At_Least_N_Arguments (1);
9055 Check_Valid_Configuration_Pragma;
9058 while Present (Arg) loop
9060 Expr := Get_Pragma_Arg (Arg);
9062 -- Case of no restriction identifier present
9064 if Id = No_Name then
9065 if Nkind (Expr) /= N_Identifier then
9067 ("invalid form for restriction", Arg);
9072 (Process_Restriction_Synonyms (Expr));
9074 if R_Id not in All_Boolean_Restrictions then
9075 Error_Msg_Name_1 := Pname;
9077 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9079 -- Check for possible misspelling
9081 for J in Restriction_Id loop
9083 Rnm : constant String := Restriction_Id'Image (J);
9086 Name_Buffer (1 .. Rnm'Length) := Rnm;
9087 Name_Len := Rnm'Length;
9088 Set_Casing (All_Lower_Case);
9090 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9092 (Identifier_Casing (Current_Source_File));
9093 Error_Msg_String (1 .. Rnm'Length) :=
9094 Name_Buffer (1 .. Name_Len);
9095 Error_Msg_Strlen := Rnm'Length;
9096 Error_Msg_N -- CODEFIX
9097 ("\possible misspelling of ""~""",
9098 Get_Pragma_Arg (Arg));
9107 if Implementation_Restriction (R_Id) then
9108 Check_Restriction (No_Implementation_Restrictions, Arg);
9111 -- Special processing for No_Elaboration_Code restriction
9113 if R_Id = No_Elaboration_Code then
9115 -- Restriction is only recognized within a configuration
9116 -- pragma file, or within a unit of the main extended
9117 -- program. Note: the test for Main_Unit is needed to
9118 -- properly include the case of configuration pragma files.
9120 if not (Current_Sem_Unit = Main_Unit
9121 or else In_Extended_Main_Source_Unit (N))
9125 -- Don't allow in a subunit unless already specified in
9128 elsif Nkind (Parent (N)) = N_Compilation_Unit
9129 and then Nkind (Unit (Parent (N))) = N_Subunit
9130 and then not Restriction_Active (No_Elaboration_Code)
9133 ("invalid specification of ""No_Elaboration_Code""",
9136 ("\restriction cannot be specified in a subunit", N);
9138 ("\unless also specified in body or spec", N);
9141 -- If we accept a No_Elaboration_Code restriction, then it
9142 -- needs to be added to the configuration restriction set so
9143 -- that we get proper application to other units in the main
9144 -- extended source as required.
9147 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9151 -- If this is a warning, then set the warning unless we already
9152 -- have a real restriction active (we never want a warning to
9153 -- override a real restriction).
9156 if not Restriction_Active (R_Id) then
9157 Set_Restriction (R_Id, N);
9158 Restriction_Warnings (R_Id) := True;
9161 -- If real restriction case, then set it and make sure that the
9162 -- restriction warning flag is off, since a real restriction
9163 -- always overrides a warning.
9166 Set_Restriction (R_Id, N);
9167 Restriction_Warnings (R_Id) := False;
9170 -- Check for obsolescent restrictions in Ada 2005 mode
9173 and then Ada_Version >= Ada_2005
9174 and then (R_Id = No_Asynchronous_Control
9176 R_Id = No_Unchecked_Deallocation
9178 R_Id = No_Unchecked_Conversion)
9180 Check_Restriction (No_Obsolescent_Features, N);
9183 -- A very special case that must be processed here: pragma
9184 -- Restrictions (No_Exceptions) turns off all run-time
9185 -- checking. This is a bit dubious in terms of the formal
9186 -- language definition, but it is what is intended by RM
9187 -- H.4(12). Restriction_Warnings never affects generated code
9188 -- so this is done only in the real restriction case.
9190 -- Atomic_Synchronization is not a real check, so it is not
9191 -- affected by this processing).
9193 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9194 -- run-time checks in CodePeer and GNATprove modes: we want to
9195 -- generate checks for analysis purposes, as set respectively
9196 -- by -gnatC and -gnatd.F
9199 and then not (CodePeer_Mode or GNATprove_Mode)
9200 and then R_Id = No_Exceptions
9202 for J in Scope_Suppress.Suppress'Range loop
9203 if J /= Atomic_Synchronization then
9204 Scope_Suppress.Suppress (J) := True;
9209 -- Case of No_Dependence => unit-name. Note that the parser
9210 -- already made the necessary entry in the No_Dependence table.
9212 elsif Id = Name_No_Dependence then
9213 if not OK_No_Dependence_Unit_Name (Expr) then
9217 -- Case of No_Specification_Of_Aspect => aspect-identifier
9219 elsif Id = Name_No_Specification_Of_Aspect then
9224 if Nkind (Expr) /= N_Identifier then
9227 A_Id := Get_Aspect_Id (Chars (Expr));
9230 if A_Id = No_Aspect then
9231 Error_Pragma_Arg ("invalid restriction name", Arg);
9233 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9237 -- Case of No_Use_Of_Attribute => attribute-identifier
9239 elsif Id = Name_No_Use_Of_Attribute then
9240 if Nkind (Expr) /= N_Identifier
9241 or else not Is_Attribute_Name (Chars (Expr))
9243 Error_Msg_N ("unknown attribute name??", Expr);
9246 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9249 -- Case of No_Use_Of_Entity => fully-qualified-name
9251 elsif Id = Name_No_Use_Of_Entity then
9253 -- Restriction is only recognized within a configuration
9254 -- pragma file, or within a unit of the main extended
9255 -- program. Note: the test for Main_Unit is needed to
9256 -- properly include the case of configuration pragma files.
9258 if Current_Sem_Unit = Main_Unit
9259 or else In_Extended_Main_Source_Unit (N)
9261 if not OK_No_Dependence_Unit_Name (Expr) then
9262 Error_Msg_N ("wrong form for entity name", Expr);
9264 Set_Restriction_No_Use_Of_Entity
9265 (Expr, Warn, No_Profile);
9269 -- Case of No_Use_Of_Pragma => pragma-identifier
9271 elsif Id = Name_No_Use_Of_Pragma then
9272 if Nkind (Expr) /= N_Identifier
9273 or else not Is_Pragma_Name (Chars (Expr))
9275 Error_Msg_N ("unknown pragma name??", Expr);
9277 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9280 -- All other cases of restriction identifier present
9283 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9284 Analyze_And_Resolve (Expr, Any_Integer);
9286 if R_Id not in All_Parameter_Restrictions then
9288 ("invalid restriction parameter identifier", Arg);
9290 elsif not Is_OK_Static_Expression (Expr) then
9291 Flag_Non_Static_Expr
9292 ("value must be static expression!", Expr);
9295 elsif not Is_Integer_Type (Etype (Expr))
9296 or else Expr_Value (Expr) < 0
9299 ("value must be non-negative integer", Arg);
9302 -- Restriction pragma is active
9304 Val := Expr_Value (Expr);
9306 if not UI_Is_In_Int_Range (Val) then
9308 ("pragma ignored, value too large??", Arg);
9311 -- Warning case. If the real restriction is active, then we
9312 -- ignore the request, since warning never overrides a real
9313 -- restriction. Otherwise we set the proper warning. Note that
9314 -- this circuit sets the warning again if it is already set,
9315 -- which is what we want, since the constant may have changed.
9318 if not Restriction_Active (R_Id) then
9320 (R_Id, N, Integer (UI_To_Int (Val)));
9321 Restriction_Warnings (R_Id) := True;
9324 -- Real restriction case, set restriction and make sure warning
9325 -- flag is off since real restriction always overrides warning.
9328 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9329 Restriction_Warnings (R_Id) := False;
9335 end Process_Restrictions_Or_Restriction_Warnings;
9337 ---------------------------------
9338 -- Process_Suppress_Unsuppress --
9339 ---------------------------------
9341 -- Note: this procedure makes entries in the check suppress data
9342 -- structures managed by Sem. See spec of package Sem for full
9343 -- details on how we handle recording of check suppression.
9345 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9350 In_Package_Spec : constant Boolean :=
9351 Is_Package_Or_Generic_Package (Current_Scope)
9352 and then not In_Package_Body (Current_Scope);
9354 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9355 -- Used to suppress a single check on the given entity
9357 --------------------------------
9358 -- Suppress_Unsuppress_Echeck --
9359 --------------------------------
9361 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9363 -- Check for error of trying to set atomic synchronization for
9364 -- a non-atomic variable.
9366 if C = Atomic_Synchronization
9367 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9370 ("pragma & requires atomic type or variable",
9371 Pragma_Identifier (Original_Node (N)));
9374 Set_Checks_May_Be_Suppressed (E);
9376 if In_Package_Spec then
9377 Push_Global_Suppress_Stack_Entry
9380 Suppress => Suppress_Case);
9382 Push_Local_Suppress_Stack_Entry
9385 Suppress => Suppress_Case);
9388 -- If this is a first subtype, and the base type is distinct,
9389 -- then also set the suppress flags on the base type.
9391 if Is_First_Subtype (E) and then Etype (E) /= E then
9392 Suppress_Unsuppress_Echeck (Etype (E), C);
9394 end Suppress_Unsuppress_Echeck;
9396 -- Start of processing for Process_Suppress_Unsuppress
9399 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9400 -- on user code: we want to generate checks for analysis purposes, as
9401 -- set respectively by -gnatC and -gnatd.F
9403 if Comes_From_Source (N)
9404 and then (CodePeer_Mode or GNATprove_Mode)
9409 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9410 -- declarative part or a package spec (RM 11.5(5)).
9412 if not Is_Configuration_Pragma then
9413 Check_Is_In_Decl_Part_Or_Package_Spec;
9416 Check_At_Least_N_Arguments (1);
9417 Check_At_Most_N_Arguments (2);
9418 Check_No_Identifier (Arg1);
9419 Check_Arg_Is_Identifier (Arg1);
9421 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9423 if C = No_Check_Id then
9425 ("argument of pragma% is not valid check name", Arg1);
9428 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9430 if C = Elaboration_Check and then SPARK_Mode = On then
9432 ("Suppress of Elaboration_Check ignored in SPARK??",
9433 "\elaboration checking rules are statically enforced "
9434 & "(SPARK RM 7.7)", Arg1);
9437 -- One-argument case
9439 if Arg_Count = 1 then
9441 -- Make an entry in the local scope suppress table. This is the
9442 -- table that directly shows the current value of the scope
9443 -- suppress check for any check id value.
9445 if C = All_Checks then
9447 -- For All_Checks, we set all specific predefined checks with
9448 -- the exception of Elaboration_Check, which is handled
9449 -- specially because of not wanting All_Checks to have the
9450 -- effect of deactivating static elaboration order processing.
9451 -- Atomic_Synchronization is also not affected, since this is
9452 -- not a real check.
9454 for J in Scope_Suppress.Suppress'Range loop
9455 if J /= Elaboration_Check
9457 J /= Atomic_Synchronization
9459 Scope_Suppress.Suppress (J) := Suppress_Case;
9463 -- If not All_Checks, and predefined check, then set appropriate
9464 -- scope entry. Note that we will set Elaboration_Check if this
9465 -- is explicitly specified. Atomic_Synchronization is allowed
9466 -- only if internally generated and entity is atomic.
9468 elsif C in Predefined_Check_Id
9469 and then (not Comes_From_Source (N)
9470 or else C /= Atomic_Synchronization)
9472 Scope_Suppress.Suppress (C) := Suppress_Case;
9475 -- Also make an entry in the Local_Entity_Suppress table
9477 Push_Local_Suppress_Stack_Entry
9480 Suppress => Suppress_Case);
9482 -- Case of two arguments present, where the check is suppressed for
9483 -- a specified entity (given as the second argument of the pragma)
9486 -- This is obsolescent in Ada 2005 mode
9488 if Ada_Version >= Ada_2005 then
9489 Check_Restriction (No_Obsolescent_Features, Arg2);
9492 Check_Optional_Identifier (Arg2, Name_On);
9493 E_Id := Get_Pragma_Arg (Arg2);
9496 if not Is_Entity_Name (E_Id) then
9498 ("second argument of pragma% must be entity name", Arg2);
9507 -- A pragma that applies to a Ghost entity becomes Ghost for the
9508 -- purposes of legality checks and removal of ignored Ghost code.
9510 Mark_Pragma_As_Ghost (N, E);
9512 -- Enforce RM 11.5(7) which requires that for a pragma that
9513 -- appears within a package spec, the named entity must be
9514 -- within the package spec. We allow the package name itself
9515 -- to be mentioned since that makes sense, although it is not
9516 -- strictly allowed by 11.5(7).
9519 and then E /= Current_Scope
9520 and then Scope (E) /= Current_Scope
9523 ("entity in pragma% is not in package spec (RM 11.5(7))",
9527 -- Loop through homonyms. As noted below, in the case of a package
9528 -- spec, only homonyms within the package spec are considered.
9531 Suppress_Unsuppress_Echeck (E, C);
9533 if Is_Generic_Instance (E)
9534 and then Is_Subprogram (E)
9535 and then Present (Alias (E))
9537 Suppress_Unsuppress_Echeck (Alias (E), C);
9540 -- Move to next homonym if not aspect spec case
9542 exit when From_Aspect_Specification (N);
9546 -- If we are within a package specification, the pragma only
9547 -- applies to homonyms in the same scope.
9549 exit when In_Package_Spec
9550 and then Scope (E) /= Current_Scope;
9553 end Process_Suppress_Unsuppress;
9555 -------------------------------
9556 -- Record_Independence_Check --
9557 -------------------------------
9559 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9561 -- For GCC back ends the validation is done a priori
9563 if not AAMP_On_Target then
9567 Independence_Checks.Append ((N, E));
9568 end Record_Independence_Check;
9574 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9576 if Is_Imported (E) then
9578 ("cannot export entity& that was previously imported", Arg);
9580 elsif Present (Address_Clause (E))
9581 and then not Relaxed_RM_Semantics
9584 ("cannot export entity& that has an address clause", Arg);
9587 Set_Is_Exported (E);
9589 -- Generate a reference for entity explicitly, because the
9590 -- identifier may be overloaded and name resolution will not
9593 Generate_Reference (E, Arg);
9595 -- Deal with exporting non-library level entity
9597 if not Is_Library_Level_Entity (E) then
9599 -- Not allowed at all for subprograms
9601 if Is_Subprogram (E) then
9602 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9604 -- Otherwise set public and statically allocated
9608 Set_Is_Statically_Allocated (E);
9610 -- Warn if the corresponding W flag is set
9612 if Warn_On_Export_Import
9614 -- Only do this for something that was in the source. Not
9615 -- clear if this can be False now (there used for sure to be
9616 -- cases on some systems where it was False), but anyway the
9617 -- test is harmless if not needed, so it is retained.
9619 and then Comes_From_Source (Arg)
9622 ("?x?& has been made static as a result of Export",
9625 ("\?x?this usage is non-standard and non-portable",
9631 if Warn_On_Export_Import and then Is_Type (E) then
9632 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9635 if Warn_On_Export_Import and Inside_A_Generic then
9637 ("all instances of& will have the same external name?x?",
9642 ----------------------------------------------
9643 -- Set_Extended_Import_Export_External_Name --
9644 ----------------------------------------------
9646 procedure Set_Extended_Import_Export_External_Name
9647 (Internal_Ent : Entity_Id;
9648 Arg_External : Node_Id)
9650 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9654 if No (Arg_External) then
9658 Check_Arg_Is_External_Name (Arg_External);
9660 if Nkind (Arg_External) = N_String_Literal then
9661 if String_Length (Strval (Arg_External)) = 0 then
9664 New_Name := Adjust_External_Name_Case (Arg_External);
9667 elsif Nkind (Arg_External) = N_Identifier then
9668 New_Name := Get_Default_External_Name (Arg_External);
9670 -- Check_Arg_Is_External_Name should let through only identifiers and
9671 -- string literals or static string expressions (which are folded to
9672 -- string literals).
9675 raise Program_Error;
9678 -- If we already have an external name set (by a prior normal Import
9679 -- or Export pragma), then the external names must match
9681 if Present (Interface_Name (Internal_Ent)) then
9683 -- Ignore mismatching names in CodePeer mode, to support some
9684 -- old compilers which would export the same procedure under
9685 -- different names, e.g:
9687 -- pragma Export_Procedure (P, "a");
9688 -- pragma Export_Procedure (P, "b");
9690 if CodePeer_Mode then
9694 Check_Matching_Internal_Names : declare
9695 S1 : constant String_Id := Strval (Old_Name);
9696 S2 : constant String_Id := Strval (New_Name);
9699 pragma No_Return (Mismatch);
9700 -- Called if names do not match
9706 procedure Mismatch is
9708 Error_Msg_Sloc := Sloc (Old_Name);
9710 ("external name does not match that given #",
9714 -- Start of processing for Check_Matching_Internal_Names
9717 if String_Length (S1) /= String_Length (S2) then
9721 for J in 1 .. String_Length (S1) loop
9722 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9727 end Check_Matching_Internal_Names;
9729 -- Otherwise set the given name
9732 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9733 Check_Duplicated_Export_Name (New_Name);
9735 end Set_Extended_Import_Export_External_Name;
9741 procedure Set_Imported (E : Entity_Id) is
9743 -- Error message if already imported or exported
9745 if Is_Exported (E) or else Is_Imported (E) then
9747 -- Error if being set Exported twice
9749 if Is_Exported (E) then
9750 Error_Msg_NE ("entity& was previously exported", N, E);
9752 -- Ignore error in CodePeer mode where we treat all imported
9753 -- subprograms as unknown.
9755 elsif CodePeer_Mode then
9758 -- OK if Import/Interface case
9760 elsif Import_Interface_Present (N) then
9763 -- Error if being set Imported twice
9766 Error_Msg_NE ("entity& was previously imported", N, E);
9769 Error_Msg_Name_1 := Pname;
9771 ("\(pragma% applies to all previous entities)", N);
9773 Error_Msg_Sloc := Sloc (E);
9774 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9776 -- Here if not previously imported or exported, OK to import
9779 Set_Is_Imported (E);
9781 -- For subprogram, set Import_Pragma field
9783 if Is_Subprogram (E) then
9784 Set_Import_Pragma (E, N);
9787 -- If the entity is an object that is not at the library level,
9788 -- then it is statically allocated. We do not worry about objects
9789 -- with address clauses in this context since they are not really
9790 -- imported in the linker sense.
9793 and then not Is_Library_Level_Entity (E)
9794 and then No (Address_Clause (E))
9796 Set_Is_Statically_Allocated (E);
9803 -------------------------
9804 -- Set_Mechanism_Value --
9805 -------------------------
9807 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9808 -- analyzed, since it is semantic nonsense), so we get it in the exact
9809 -- form created by the parser.
9811 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9812 procedure Bad_Mechanism;
9813 pragma No_Return (Bad_Mechanism);
9814 -- Signal bad mechanism name
9816 -------------------------
9817 -- Bad_Mechanism_Value --
9818 -------------------------
9820 procedure Bad_Mechanism is
9822 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9825 -- Start of processing for Set_Mechanism_Value
9828 if Mechanism (Ent) /= Default_Mechanism then
9830 ("mechanism for & has already been set", Mech_Name, Ent);
9833 -- MECHANISM_NAME ::= value | reference
9835 if Nkind (Mech_Name) = N_Identifier then
9836 if Chars (Mech_Name) = Name_Value then
9837 Set_Mechanism (Ent, By_Copy);
9840 elsif Chars (Mech_Name) = Name_Reference then
9841 Set_Mechanism (Ent, By_Reference);
9844 elsif Chars (Mech_Name) = Name_Copy then
9846 ("bad mechanism name, Value assumed", Mech_Name);
9855 end Set_Mechanism_Value;
9857 --------------------------
9858 -- Set_Rational_Profile --
9859 --------------------------
9861 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9862 -- extension to the semantics of renaming declarations.
9864 procedure Set_Rational_Profile is
9866 Implicit_Packing := True;
9867 Overriding_Renamings := True;
9868 Use_VADS_Size := True;
9869 end Set_Rational_Profile;
9871 ---------------------------
9872 -- Set_Ravenscar_Profile --
9873 ---------------------------
9875 -- The tasks to be done here are
9877 -- Set required policies
9879 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9880 -- pragma Locking_Policy (Ceiling_Locking)
9882 -- Set Detect_Blocking mode
9884 -- Set required restrictions (see System.Rident for detailed list)
9886 -- Set the No_Dependence rules
9887 -- No_Dependence => Ada.Asynchronous_Task_Control
9888 -- No_Dependence => Ada.Calendar
9889 -- No_Dependence => Ada.Execution_Time.Group_Budget
9890 -- No_Dependence => Ada.Execution_Time.Timers
9891 -- No_Dependence => Ada.Task_Attributes
9892 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9894 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
9895 procedure Set_Error_Msg_To_Profile_Name;
9896 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
9899 -----------------------------------
9900 -- Set_Error_Msg_To_Profile_Name --
9901 -----------------------------------
9903 procedure Set_Error_Msg_To_Profile_Name is
9904 Prof_Nam : constant Node_Id :=
9906 (First (Pragma_Argument_Associations (N)));
9909 Get_Name_String (Chars (Prof_Nam));
9910 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
9911 Error_Msg_Strlen := Name_Len;
9912 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
9913 end Set_Error_Msg_To_Profile_Name;
9922 -- Start of processing for Set_Ravenscar_Profile
9925 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9927 if Task_Dispatching_Policy /= ' '
9928 and then Task_Dispatching_Policy /= 'F'
9930 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9931 Set_Error_Msg_To_Profile_Name;
9932 Error_Pragma ("Profile (~) incompatible with policy#");
9934 -- Set the FIFO_Within_Priorities policy, but always preserve
9935 -- System_Location since we like the error message with the run time
9939 Task_Dispatching_Policy := 'F';
9941 if Task_Dispatching_Policy_Sloc /= System_Location then
9942 Task_Dispatching_Policy_Sloc := Loc;
9946 -- pragma Locking_Policy (Ceiling_Locking)
9948 if Locking_Policy /= ' '
9949 and then Locking_Policy /= 'C'
9951 Error_Msg_Sloc := Locking_Policy_Sloc;
9952 Set_Error_Msg_To_Profile_Name;
9953 Error_Pragma ("Profile (~) incompatible with policy#");
9955 -- Set the Ceiling_Locking policy, but preserve System_Location since
9956 -- we like the error message with the run time name.
9959 Locking_Policy := 'C';
9961 if Locking_Policy_Sloc /= System_Location then
9962 Locking_Policy_Sloc := Loc;
9966 -- pragma Detect_Blocking
9968 Detect_Blocking := True;
9970 -- Set the corresponding restrictions
9972 Set_Profile_Restrictions
9973 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
9975 -- Set the No_Dependence restrictions
9977 -- The following No_Dependence restrictions:
9978 -- No_Dependence => Ada.Asynchronous_Task_Control
9979 -- No_Dependence => Ada.Calendar
9980 -- No_Dependence => Ada.Task_Attributes
9981 -- are already set by previous call to Set_Profile_Restrictions.
9983 -- Set the following restrictions which were added to Ada 2005:
9984 -- No_Dependence => Ada.Execution_Time.Group_Budget
9985 -- No_Dependence => Ada.Execution_Time.Timers
9987 -- ??? The use of Name_Buffer here is suspicious. The names should
9988 -- be registered in snames.ads-tmpl and used to build the qualified
9991 if Ada_Version >= Ada_2005 then
9992 Name_Buffer (1 .. 3) := "ada";
9995 Pref_Id := Make_Identifier (Loc, Name_Find);
9997 Name_Buffer (1 .. 14) := "execution_time";
10000 Sel_Id := Make_Identifier (Loc, Name_Find);
10003 Make_Selected_Component
10006 Selector_Name => Sel_Id);
10008 Name_Buffer (1 .. 13) := "group_budgets";
10011 Sel_Id := Make_Identifier (Loc, Name_Find);
10014 Make_Selected_Component
10017 Selector_Name => Sel_Id);
10019 Set_Restriction_No_Dependence
10021 Warn => Treat_Restrictions_As_Warnings,
10022 Profile => Ravenscar);
10024 Name_Buffer (1 .. 6) := "timers";
10027 Sel_Id := Make_Identifier (Loc, Name_Find);
10030 Make_Selected_Component
10033 Selector_Name => Sel_Id);
10035 Set_Restriction_No_Dependence
10037 Warn => Treat_Restrictions_As_Warnings,
10038 Profile => Ravenscar);
10041 -- Set the following restriction which was added to Ada 2012 (see
10043 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10045 if Ada_Version >= Ada_2012 then
10046 Name_Buffer (1 .. 6) := "system";
10049 Pref_Id := Make_Identifier (Loc, Name_Find);
10051 Name_Buffer (1 .. 15) := "multiprocessors";
10054 Sel_Id := Make_Identifier (Loc, Name_Find);
10057 Make_Selected_Component
10060 Selector_Name => Sel_Id);
10062 Name_Buffer (1 .. 19) := "dispatching_domains";
10065 Sel_Id := Make_Identifier (Loc, Name_Find);
10068 Make_Selected_Component
10071 Selector_Name => Sel_Id);
10073 Set_Restriction_No_Dependence
10075 Warn => Treat_Restrictions_As_Warnings,
10076 Profile => Ravenscar);
10078 end Set_Ravenscar_Profile;
10080 -- Start of processing for Analyze_Pragma
10083 -- The following code is a defense against recursion. Not clear that
10084 -- this can happen legitimately, but perhaps some error situations can
10085 -- cause it, and we did see this recursion during testing.
10087 if Analyzed (N) then
10093 Check_Restriction_No_Use_Of_Pragma (N);
10095 -- Deal with unrecognized pragma
10097 Pname := Pragma_Name (N);
10099 if not Is_Pragma_Name (Pname) then
10100 if Warn_On_Unrecognized_Pragma then
10101 Error_Msg_Name_1 := Pname;
10102 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10104 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10105 if Is_Bad_Spelling_Of (Pname, PN) then
10106 Error_Msg_Name_1 := PN;
10107 Error_Msg_N -- CODEFIX
10108 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10117 -- Ignore pragma if Ignore_Pragma applies
10119 if Get_Name_Table_Boolean3 (Pname) then
10123 -- Here to start processing for recognized pragma
10125 Prag_Id := Get_Pragma_Id (Pname);
10126 Pname := Original_Aspect_Pragma_Name (N);
10128 -- Capture setting of Opt.Uneval_Old
10130 case Opt.Uneval_Old is
10132 Set_Uneval_Old_Accept (N);
10136 Set_Uneval_Old_Warn (N);
10138 raise Program_Error;
10141 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10142 -- is already set, indicating that we have already checked the policy
10143 -- at the right point. This happens for example in the case of a pragma
10144 -- that is derived from an Aspect.
10146 if Is_Ignored (N) or else Is_Checked (N) then
10149 -- For a pragma that is a rewriting of another pragma, copy the
10150 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10152 elsif Is_Rewrite_Substitution (N)
10153 and then Nkind (Original_Node (N)) = N_Pragma
10154 and then Original_Node (N) /= N
10156 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10157 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10159 -- Otherwise query the applicable policy at this point
10162 Check_Applicable_Policy (N);
10164 -- If pragma is disabled, rewrite as NULL and skip analysis
10166 if Is_Disabled (N) then
10167 Rewrite (N, Make_Null_Statement (Loc));
10173 -- Preset arguments
10181 if Present (Pragma_Argument_Associations (N)) then
10182 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10183 Arg1 := First (Pragma_Argument_Associations (N));
10185 if Present (Arg1) then
10186 Arg2 := Next (Arg1);
10188 if Present (Arg2) then
10189 Arg3 := Next (Arg2);
10191 if Present (Arg3) then
10192 Arg4 := Next (Arg3);
10198 -- An enumeration type defines the pragmas that are supported by the
10199 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10200 -- into the corresponding enumeration value for the following case.
10208 -- pragma Abort_Defer;
10210 when Pragma_Abort_Defer =>
10212 Check_Arg_Count (0);
10214 -- The only required semantic processing is to check the
10215 -- placement. This pragma must appear at the start of the
10216 -- statement sequence of a handled sequence of statements.
10218 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10219 or else N /= First (Statements (Parent (N)))
10224 --------------------
10225 -- Abstract_State --
10226 --------------------
10228 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10230 -- ABSTRACT_STATE_LIST ::=
10232 -- | STATE_NAME_WITH_OPTIONS
10233 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10235 -- STATE_NAME_WITH_OPTIONS ::=
10237 -- | (STATE_NAME with OPTION_LIST)
10239 -- OPTION_LIST ::= OPTION {, OPTION}
10243 -- | NAME_VALUE_OPTION
10245 -- SIMPLE_OPTION ::= Ghost | Synchronous
10247 -- NAME_VALUE_OPTION ::=
10248 -- Part_Of => ABSTRACT_STATE
10249 -- | External [=> EXTERNAL_PROPERTY_LIST]
10251 -- EXTERNAL_PROPERTY_LIST ::=
10252 -- EXTERNAL_PROPERTY
10253 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10255 -- EXTERNAL_PROPERTY ::=
10256 -- Async_Readers [=> boolean_EXPRESSION]
10257 -- | Async_Writers [=> boolean_EXPRESSION]
10258 -- | Effective_Reads [=> boolean_EXPRESSION]
10259 -- | Effective_Writes [=> boolean_EXPRESSION]
10260 -- others => boolean_EXPRESSION
10262 -- STATE_NAME ::= defining_identifier
10264 -- ABSTRACT_STATE ::= name
10266 -- Characteristics:
10268 -- * Analysis - The annotation is fully analyzed immediately upon
10269 -- elaboration as it cannot forward reference entities.
10271 -- * Expansion - None.
10273 -- * Template - The annotation utilizes the generic template of the
10274 -- related package declaration.
10276 -- * Globals - The annotation cannot reference global entities.
10278 -- * Instance - The annotation is instantiated automatically when
10279 -- the related generic package is instantiated.
10281 when Pragma_Abstract_State => Abstract_State : declare
10282 Missing_Parentheses : Boolean := False;
10283 -- Flag set when a state declaration with options is not properly
10286 -- Flags used to verify the consistency of states
10288 Non_Null_Seen : Boolean := False;
10289 Null_Seen : Boolean := False;
10291 procedure Analyze_Abstract_State
10293 Pack_Id : Entity_Id);
10294 -- Verify the legality of a single state declaration. Create and
10295 -- decorate a state abstraction entity and introduce it into the
10296 -- visibility chain. Pack_Id denotes the entity or the related
10297 -- package where pragma Abstract_State appears.
10299 procedure Malformed_State_Error (State : Node_Id);
10300 -- Emit an error concerning the illegal declaration of abstract
10301 -- state State. This routine diagnoses syntax errors that lead to
10302 -- a different parse tree. The error is issued regardless of the
10303 -- SPARK mode in effect.
10305 ----------------------------
10306 -- Analyze_Abstract_State --
10307 ----------------------------
10309 procedure Analyze_Abstract_State
10311 Pack_Id : Entity_Id)
10313 -- Flags used to verify the consistency of options
10315 AR_Seen : Boolean := False;
10316 AW_Seen : Boolean := False;
10317 ER_Seen : Boolean := False;
10318 EW_Seen : Boolean := False;
10319 External_Seen : Boolean := False;
10320 Ghost_Seen : Boolean := False;
10321 Others_Seen : Boolean := False;
10322 Part_Of_Seen : Boolean := False;
10323 Synchronous_Seen : Boolean := False;
10325 -- Flags used to store the static value of all external states'
10328 AR_Val : Boolean := False;
10329 AW_Val : Boolean := False;
10330 ER_Val : Boolean := False;
10331 EW_Val : Boolean := False;
10333 State_Id : Entity_Id := Empty;
10334 -- The entity to be generated for the current state declaration
10336 procedure Analyze_External_Option (Opt : Node_Id);
10337 -- Verify the legality of option External
10339 procedure Analyze_External_Property
10341 Expr : Node_Id := Empty);
10342 -- Verify the legailty of a single external property. Prop
10343 -- denotes the external property. Expr is the expression used
10344 -- to set the property.
10346 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10347 -- Verify the legality of option Part_Of
10349 procedure Check_Duplicate_Option
10351 Status : in out Boolean);
10352 -- Flag Status denotes whether a particular option has been
10353 -- seen while processing a state. This routine verifies that
10354 -- Opt is not a duplicate option and sets the flag Status
10355 -- (SPARK RM 7.1.4(1)).
10357 procedure Check_Duplicate_Property
10359 Status : in out Boolean);
10360 -- Flag Status denotes whether a particular property has been
10361 -- seen while processing option External. This routine verifies
10362 -- that Prop is not a duplicate property and sets flag Status.
10363 -- Opt is not a duplicate property and sets the flag Status.
10364 -- (SPARK RM 7.1.4(2))
10366 procedure Check_Ghost_Synchronous;
10367 -- Ensure that the abstract state is not subject to both Ghost
10368 -- and Synchronous simple options. Emit an error if this is the
10371 procedure Create_Abstract_State
10375 Is_Null : Boolean);
10376 -- Generate an abstract state entity with name Nam and enter it
10377 -- into visibility. Decl is the "declaration" of the state as
10378 -- it appears in pragma Abstract_State. Loc is the location of
10379 -- the related state "declaration". Flag Is_Null should be set
10380 -- when the associated Abstract_State pragma defines a null
10383 -----------------------------
10384 -- Analyze_External_Option --
10385 -----------------------------
10387 procedure Analyze_External_Option (Opt : Node_Id) is
10388 Errors : constant Nat := Serious_Errors_Detected;
10390 Props : Node_Id := Empty;
10393 if Nkind (Opt) = N_Component_Association then
10394 Props := Expression (Opt);
10397 -- External state with properties
10399 if Present (Props) then
10401 -- Multiple properties appear as an aggregate
10403 if Nkind (Props) = N_Aggregate then
10405 -- Simple property form
10407 Prop := First (Expressions (Props));
10408 while Present (Prop) loop
10409 Analyze_External_Property (Prop);
10413 -- Property with expression form
10415 Prop := First (Component_Associations (Props));
10416 while Present (Prop) loop
10417 Analyze_External_Property
10418 (Prop => First (Choices (Prop)),
10419 Expr => Expression (Prop));
10427 Analyze_External_Property (Props);
10430 -- An external state defined without any properties defaults
10431 -- all properties to True.
10440 -- Once all external properties have been processed, verify
10441 -- their mutual interaction. Do not perform the check when
10442 -- at least one of the properties is illegal as this will
10443 -- produce a bogus error.
10445 if Errors = Serious_Errors_Detected then
10446 Check_External_Properties
10447 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10449 end Analyze_External_Option;
10451 -------------------------------
10452 -- Analyze_External_Property --
10453 -------------------------------
10455 procedure Analyze_External_Property
10457 Expr : Node_Id := Empty)
10459 Expr_Val : Boolean;
10462 -- Check the placement of "others" (if available)
10464 if Nkind (Prop) = N_Others_Choice then
10465 if Others_Seen then
10467 ("only one others choice allowed in option External",
10470 Others_Seen := True;
10473 elsif Others_Seen then
10475 ("others must be the last property in option External",
10478 -- The only remaining legal options are the four predefined
10479 -- external properties.
10481 elsif Nkind (Prop) = N_Identifier
10482 and then Nam_In (Chars (Prop), Name_Async_Readers,
10483 Name_Async_Writers,
10484 Name_Effective_Reads,
10485 Name_Effective_Writes)
10489 -- Otherwise the construct is not a valid property
10492 SPARK_Msg_N ("invalid external state property", Prop);
10496 -- Ensure that the expression of the external state property
10497 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10499 if Present (Expr) then
10500 Analyze_And_Resolve (Expr, Standard_Boolean);
10502 if Is_OK_Static_Expression (Expr) then
10503 Expr_Val := Is_True (Expr_Value (Expr));
10506 ("expression of external state property must be "
10510 -- The lack of expression defaults the property to True
10516 -- Named properties
10518 if Nkind (Prop) = N_Identifier then
10519 if Chars (Prop) = Name_Async_Readers then
10520 Check_Duplicate_Property (Prop, AR_Seen);
10521 AR_Val := Expr_Val;
10523 elsif Chars (Prop) = Name_Async_Writers then
10524 Check_Duplicate_Property (Prop, AW_Seen);
10525 AW_Val := Expr_Val;
10527 elsif Chars (Prop) = Name_Effective_Reads then
10528 Check_Duplicate_Property (Prop, ER_Seen);
10529 ER_Val := Expr_Val;
10532 Check_Duplicate_Property (Prop, EW_Seen);
10533 EW_Val := Expr_Val;
10536 -- The handling of property "others" must take into account
10537 -- all other named properties that have been encountered so
10538 -- far. Only those that have not been seen are affected by
10542 if not AR_Seen then
10543 AR_Val := Expr_Val;
10546 if not AW_Seen then
10547 AW_Val := Expr_Val;
10550 if not ER_Seen then
10551 ER_Val := Expr_Val;
10554 if not EW_Seen then
10555 EW_Val := Expr_Val;
10558 end Analyze_External_Property;
10560 ----------------------------
10561 -- Analyze_Part_Of_Option --
10562 ----------------------------
10564 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10565 Encap : constant Node_Id := Expression (Opt);
10566 Constits : Elist_Id;
10567 Encap_Id : Entity_Id;
10571 Check_Duplicate_Option (Opt, Part_Of_Seen);
10574 (Indic => First (Choices (Opt)),
10575 Item_Id => State_Id,
10577 Encap_Id => Encap_Id,
10580 -- The Part_Of indicator transforms the abstract state into
10581 -- a constituent of the encapsulating state or single
10582 -- concurrent type.
10585 pragma Assert (Present (Encap_Id));
10586 Constits := Part_Of_Constituents (Encap_Id);
10588 if No (Constits) then
10589 Constits := New_Elmt_List;
10590 Set_Part_Of_Constituents (Encap_Id, Constits);
10593 Append_Elmt (State_Id, Constits);
10594 Set_Encapsulating_State (State_Id, Encap_Id);
10596 end Analyze_Part_Of_Option;
10598 ----------------------------
10599 -- Check_Duplicate_Option --
10600 ----------------------------
10602 procedure Check_Duplicate_Option
10604 Status : in out Boolean)
10608 SPARK_Msg_N ("duplicate state option", Opt);
10612 end Check_Duplicate_Option;
10614 ------------------------------
10615 -- Check_Duplicate_Property --
10616 ------------------------------
10618 procedure Check_Duplicate_Property
10620 Status : in out Boolean)
10624 SPARK_Msg_N ("duplicate external property", Prop);
10628 end Check_Duplicate_Property;
10630 -----------------------------
10631 -- Check_Ghost_Synchronous --
10632 -----------------------------
10634 procedure Check_Ghost_Synchronous is
10636 -- A synchronized abstract state cannot be Ghost and vice
10637 -- versa (SPARK RM 6.9(19)).
10639 if Ghost_Seen and Synchronous_Seen then
10640 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10642 end Check_Ghost_Synchronous;
10644 ---------------------------
10645 -- Create_Abstract_State --
10646 ---------------------------
10648 procedure Create_Abstract_State
10655 -- The abstract state may be semi-declared when the related
10656 -- package was withed through a limited with clause. In that
10657 -- case reuse the entity to fully declare the state.
10659 if Present (Decl) and then Present (Entity (Decl)) then
10660 State_Id := Entity (Decl);
10662 -- Otherwise the elaboration of pragma Abstract_State
10663 -- declares the state.
10666 State_Id := Make_Defining_Identifier (Loc, Nam);
10668 if Present (Decl) then
10669 Set_Entity (Decl, State_Id);
10673 -- Null states never come from source
10675 Set_Comes_From_Source (State_Id, not Is_Null);
10676 Set_Parent (State_Id, State);
10677 Set_Ekind (State_Id, E_Abstract_State);
10678 Set_Etype (State_Id, Standard_Void_Type);
10679 Set_Encapsulating_State (State_Id, Empty);
10681 -- An abstract state declared within a Ghost region becomes
10682 -- Ghost (SPARK RM 6.9(2)).
10684 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10685 Set_Is_Ghost_Entity (State_Id);
10688 -- Establish a link between the state declaration and the
10689 -- abstract state entity. Note that a null state remains as
10690 -- N_Null and does not carry any linkages.
10692 if not Is_Null then
10693 if Present (Decl) then
10694 Set_Entity (Decl, State_Id);
10695 Set_Etype (Decl, Standard_Void_Type);
10698 -- Every non-null state must be defined, nameable and
10701 Push_Scope (Pack_Id);
10702 Generate_Definition (State_Id);
10703 Enter_Name (State_Id);
10706 end Create_Abstract_State;
10713 -- Start of processing for Analyze_Abstract_State
10716 -- A package with a null abstract state is not allowed to
10717 -- declare additional states.
10721 ("package & has null abstract state", State, Pack_Id);
10723 -- Null states appear as internally generated entities
10725 elsif Nkind (State) = N_Null then
10726 Create_Abstract_State
10727 (Nam => New_Internal_Name ('S'),
10729 Loc => Sloc (State),
10733 -- Catch a case where a null state appears in a list of
10734 -- non-null states.
10736 if Non_Null_Seen then
10738 ("package & has non-null abstract state",
10742 -- Simple state declaration
10744 elsif Nkind (State) = N_Identifier then
10745 Create_Abstract_State
10746 (Nam => Chars (State),
10748 Loc => Sloc (State),
10750 Non_Null_Seen := True;
10752 -- State declaration with various options. This construct
10753 -- appears as an extension aggregate in the tree.
10755 elsif Nkind (State) = N_Extension_Aggregate then
10756 if Nkind (Ancestor_Part (State)) = N_Identifier then
10757 Create_Abstract_State
10758 (Nam => Chars (Ancestor_Part (State)),
10759 Decl => Ancestor_Part (State),
10760 Loc => Sloc (Ancestor_Part (State)),
10762 Non_Null_Seen := True;
10765 ("state name must be an identifier",
10766 Ancestor_Part (State));
10769 -- Options External, Ghost and Synchronous appear as
10772 Opt := First (Expressions (State));
10773 while Present (Opt) loop
10774 if Nkind (Opt) = N_Identifier then
10778 if Chars (Opt) = Name_External then
10779 Check_Duplicate_Option (Opt, External_Seen);
10780 Analyze_External_Option (Opt);
10784 elsif Chars (Opt) = Name_Ghost then
10785 Check_Duplicate_Option (Opt, Ghost_Seen);
10786 Check_Ghost_Synchronous;
10788 if Present (State_Id) then
10789 Set_Is_Ghost_Entity (State_Id);
10794 elsif Chars (Opt) = Name_Synchronous then
10795 Check_Duplicate_Option (Opt, Synchronous_Seen);
10796 Check_Ghost_Synchronous;
10798 -- Option Part_Of without an encapsulating state is
10799 -- illegal (SPARK RM 7.1.4(9)).
10801 elsif Chars (Opt) = Name_Part_Of then
10803 ("indicator Part_Of must denote abstract state, "
10804 & "single protected type or single task type",
10807 -- Do not emit an error message when a previous state
10808 -- declaration with options was not parenthesized as
10809 -- the option is actually another state declaration.
10811 -- with Abstract_State
10812 -- (State_1 with ..., -- missing parentheses
10813 -- (State_2 with ...),
10814 -- State_3) -- ok state declaration
10816 elsif Missing_Parentheses then
10819 -- Otherwise the option is not allowed. Note that it
10820 -- is not possible to distinguish between an option
10821 -- and a state declaration when a previous state with
10822 -- options not properly parentheses.
10824 -- with Abstract_State
10825 -- (State_1 with ..., -- missing parentheses
10826 -- State_2); -- could be an option
10830 ("simple option not allowed in state declaration",
10834 -- Catch a case where missing parentheses around a state
10835 -- declaration with options cause a subsequent state
10836 -- declaration with options to be treated as an option.
10838 -- with Abstract_State
10839 -- (State_1 with ..., -- missing parentheses
10840 -- (State_2 with ...))
10842 elsif Nkind (Opt) = N_Extension_Aggregate then
10843 Missing_Parentheses := True;
10845 ("state declaration must be parenthesized",
10846 Ancestor_Part (State));
10848 -- Otherwise the option is malformed
10851 SPARK_Msg_N ("malformed option", Opt);
10857 -- Options External and Part_Of appear as component
10860 Opt := First (Component_Associations (State));
10861 while Present (Opt) loop
10862 Opt_Nam := First (Choices (Opt));
10864 if Nkind (Opt_Nam) = N_Identifier then
10865 if Chars (Opt_Nam) = Name_External then
10866 Analyze_External_Option (Opt);
10868 elsif Chars (Opt_Nam) = Name_Part_Of then
10869 Analyze_Part_Of_Option (Opt);
10872 SPARK_Msg_N ("invalid state option", Opt);
10875 SPARK_Msg_N ("invalid state option", Opt);
10881 -- Any other attempt to declare a state is illegal
10884 Malformed_State_Error (State);
10888 -- Guard against a junk state. In such cases no entity is
10889 -- generated and the subsequent checks cannot be applied.
10891 if Present (State_Id) then
10893 -- Verify whether the state does not introduce an illegal
10894 -- hidden state within a package subject to a null abstract
10897 Check_No_Hidden_State (State_Id);
10899 -- Check whether the lack of option Part_Of agrees with the
10900 -- placement of the abstract state with respect to the state
10903 if not Part_Of_Seen then
10904 Check_Missing_Part_Of (State_Id);
10907 -- Associate the state with its related package
10909 if No (Abstract_States (Pack_Id)) then
10910 Set_Abstract_States (Pack_Id, New_Elmt_List);
10913 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10915 end Analyze_Abstract_State;
10917 ---------------------------
10918 -- Malformed_State_Error --
10919 ---------------------------
10921 procedure Malformed_State_Error (State : Node_Id) is
10923 Error_Msg_N ("malformed abstract state declaration", State);
10925 -- An abstract state with a simple option is being declared
10926 -- with "=>" rather than the legal "with". The state appears
10927 -- as a component association.
10929 if Nkind (State) = N_Component_Association then
10930 Error_Msg_N ("\use WITH to specify simple option", State);
10932 end Malformed_State_Error;
10936 Pack_Decl : Node_Id;
10937 Pack_Id : Entity_Id;
10941 -- Start of processing for Abstract_State
10945 Check_No_Identifiers;
10946 Check_Arg_Count (1);
10948 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
10950 -- Ensure the proper placement of the pragma. Abstract states must
10951 -- be associated with a package declaration.
10953 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
10954 N_Package_Declaration)
10958 -- Otherwise the pragma is associated with an illegal construct
10965 Pack_Id := Defining_Entity (Pack_Decl);
10967 -- Chain the pragma on the contract for completeness
10969 Add_Contract_Item (N, Pack_Id);
10971 -- The legality checks of pragmas Abstract_State, Initializes, and
10972 -- Initial_Condition are affected by the SPARK mode in effect. In
10973 -- addition, these three pragmas are subject to an inherent order:
10975 -- 1) Abstract_State
10977 -- 3) Initial_Condition
10979 -- Analyze all these pragmas in the order outlined above
10981 Analyze_If_Present (Pragma_SPARK_Mode);
10983 -- A pragma that applies to a Ghost entity becomes Ghost for the
10984 -- purposes of legality checks and removal of ignored Ghost code.
10986 Mark_Pragma_As_Ghost (N, Pack_Id);
10987 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
10989 States := Expression (Get_Argument (N, Pack_Id));
10991 -- Multiple non-null abstract states appear as an aggregate
10993 if Nkind (States) = N_Aggregate then
10994 State := First (Expressions (States));
10995 while Present (State) loop
10996 Analyze_Abstract_State (State, Pack_Id);
11000 -- An abstract state with a simple option is being illegaly
11001 -- declared with "=>" rather than "with". In this case the
11002 -- state declaration appears as a component association.
11004 if Present (Component_Associations (States)) then
11005 State := First (Component_Associations (States));
11006 while Present (State) loop
11007 Malformed_State_Error (State);
11012 -- Various forms of a single abstract state. Note that these may
11013 -- include malformed state declarations.
11016 Analyze_Abstract_State (States, Pack_Id);
11019 Analyze_If_Present (Pragma_Initializes);
11020 Analyze_If_Present (Pragma_Initial_Condition);
11021 end Abstract_State;
11029 -- Note: this pragma also has some specific processing in Par.Prag
11030 -- because we want to set the Ada version mode during parsing.
11032 when Pragma_Ada_83 =>
11034 Check_Arg_Count (0);
11036 -- We really should check unconditionally for proper configuration
11037 -- pragma placement, since we really don't want mixed Ada modes
11038 -- within a single unit, and the GNAT reference manual has always
11039 -- said this was a configuration pragma, but we did not check and
11040 -- are hesitant to add the check now.
11042 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11043 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11044 -- or Ada 2012 mode.
11046 if Ada_Version >= Ada_2005 then
11047 Check_Valid_Configuration_Pragma;
11050 -- Now set Ada 83 mode
11052 if not Latest_Ada_Only then
11053 Ada_Version := Ada_83;
11054 Ada_Version_Explicit := Ada_83;
11055 Ada_Version_Pragma := N;
11064 -- Note: this pragma also has some specific processing in Par.Prag
11065 -- because we want to set the Ada 83 version mode during parsing.
11067 when Pragma_Ada_95 =>
11069 Check_Arg_Count (0);
11071 -- We really should check unconditionally for proper configuration
11072 -- pragma placement, since we really don't want mixed Ada modes
11073 -- within a single unit, and the GNAT reference manual has always
11074 -- said this was a configuration pragma, but we did not check and
11075 -- are hesitant to add the check now.
11077 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11078 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11080 if Ada_Version >= Ada_2005 then
11081 Check_Valid_Configuration_Pragma;
11084 -- Now set Ada 95 mode
11086 if not Latest_Ada_Only then
11087 Ada_Version := Ada_95;
11088 Ada_Version_Explicit := Ada_95;
11089 Ada_Version_Pragma := N;
11092 ---------------------
11093 -- Ada_05/Ada_2005 --
11094 ---------------------
11097 -- pragma Ada_05 (LOCAL_NAME);
11099 -- pragma Ada_2005;
11100 -- pragma Ada_2005 (LOCAL_NAME):
11102 -- Note: these pragmas also have some specific processing in Par.Prag
11103 -- because we want to set the Ada 2005 version mode during parsing.
11105 -- The one argument form is used for managing the transition from
11106 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11107 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11108 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11109 -- mode, a preference rule is established which does not choose
11110 -- such an entity unless it is unambiguously specified. This avoids
11111 -- extra subprograms marked this way from generating ambiguities in
11112 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11113 -- intended for exclusive use in the GNAT run-time library.
11115 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11121 if Arg_Count = 1 then
11122 Check_Arg_Is_Local_Name (Arg1);
11123 E_Id := Get_Pragma_Arg (Arg1);
11125 if Etype (E_Id) = Any_Type then
11129 Set_Is_Ada_2005_Only (Entity (E_Id));
11130 Record_Rep_Item (Entity (E_Id), N);
11133 Check_Arg_Count (0);
11135 -- For Ada_2005 we unconditionally enforce the documented
11136 -- configuration pragma placement, since we do not want to
11137 -- tolerate mixed modes in a unit involving Ada 2005. That
11138 -- would cause real difficulties for those cases where there
11139 -- are incompatibilities between Ada 95 and Ada 2005.
11141 Check_Valid_Configuration_Pragma;
11143 -- Now set appropriate Ada mode
11145 if not Latest_Ada_Only then
11146 Ada_Version := Ada_2005;
11147 Ada_Version_Explicit := Ada_2005;
11148 Ada_Version_Pragma := N;
11153 ---------------------
11154 -- Ada_12/Ada_2012 --
11155 ---------------------
11158 -- pragma Ada_12 (LOCAL_NAME);
11160 -- pragma Ada_2012;
11161 -- pragma Ada_2012 (LOCAL_NAME):
11163 -- Note: these pragmas also have some specific processing in Par.Prag
11164 -- because we want to set the Ada 2012 version mode during parsing.
11166 -- The one argument form is used for managing the transition from Ada
11167 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11168 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11169 -- mode will generate a warning. In addition, in any pre-Ada_2012
11170 -- mode, a preference rule is established which does not choose
11171 -- such an entity unless it is unambiguously specified. This avoids
11172 -- extra subprograms marked this way from generating ambiguities in
11173 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11174 -- intended for exclusive use in the GNAT run-time library.
11176 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11182 if Arg_Count = 1 then
11183 Check_Arg_Is_Local_Name (Arg1);
11184 E_Id := Get_Pragma_Arg (Arg1);
11186 if Etype (E_Id) = Any_Type then
11190 Set_Is_Ada_2012_Only (Entity (E_Id));
11191 Record_Rep_Item (Entity (E_Id), N);
11194 Check_Arg_Count (0);
11196 -- For Ada_2012 we unconditionally enforce the documented
11197 -- configuration pragma placement, since we do not want to
11198 -- tolerate mixed modes in a unit involving Ada 2012. That
11199 -- would cause real difficulties for those cases where there
11200 -- are incompatibilities between Ada 95 and Ada 2012. We could
11201 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11203 Check_Valid_Configuration_Pragma;
11205 -- Now set appropriate Ada mode
11207 Ada_Version := Ada_2012;
11208 Ada_Version_Explicit := Ada_2012;
11209 Ada_Version_Pragma := N;
11213 ----------------------
11214 -- All_Calls_Remote --
11215 ----------------------
11217 -- pragma All_Calls_Remote [(library_package_NAME)];
11219 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11220 Lib_Entity : Entity_Id;
11223 Check_Ada_83_Warning;
11224 Check_Valid_Library_Unit_Pragma;
11226 if Nkind (N) = N_Null_Statement then
11230 Lib_Entity := Find_Lib_Unit_Name;
11232 -- A pragma that applies to a Ghost entity becomes Ghost for the
11233 -- purposes of legality checks and removal of ignored Ghost code.
11235 Mark_Pragma_As_Ghost (N, Lib_Entity);
11237 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11239 if Present (Lib_Entity) and then not Debug_Flag_U then
11240 if not Is_Remote_Call_Interface (Lib_Entity) then
11241 Error_Pragma ("pragma% only apply to rci unit");
11243 -- Set flag for entity of the library unit
11246 Set_Has_All_Calls_Remote (Lib_Entity);
11249 end All_Calls_Remote;
11251 ---------------------------
11252 -- Allow_Integer_Address --
11253 ---------------------------
11255 -- pragma Allow_Integer_Address;
11257 when Pragma_Allow_Integer_Address =>
11259 Check_Valid_Configuration_Pragma;
11260 Check_Arg_Count (0);
11262 -- If Address is a private type, then set the flag to allow
11263 -- integer address values. If Address is not private, then this
11264 -- pragma has no purpose, so it is simply ignored. Not clear if
11265 -- there are any such targets now.
11267 if Opt.Address_Is_Private then
11268 Opt.Allow_Integer_Address := True;
11276 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11277 -- ARG ::= NAME | EXPRESSION
11279 -- The first two arguments are by convention intended to refer to an
11280 -- external tool and a tool-specific function. These arguments are
11283 when Pragma_Annotate => Annotate : declare
11290 Check_At_Least_N_Arguments (1);
11292 Nam_Arg := Last (Pragma_Argument_Associations (N));
11294 -- Determine whether the last argument is "Entity => local_NAME"
11295 -- and if it is, perform the required semantic checks. Remove the
11296 -- argument from further processing.
11298 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11299 and then Chars (Nam_Arg) = Name_Entity
11301 Check_Arg_Is_Local_Name (Nam_Arg);
11302 Arg_Count := Arg_Count - 1;
11304 -- A pragma that applies to a Ghost entity becomes Ghost for
11305 -- the purposes of legality checks and removal of ignored Ghost
11308 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11309 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11311 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11314 -- Not allowed in compiler units (bootstrap issues)
11316 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11319 -- Continue the processing with last argument removed for now
11321 Check_Arg_Is_Identifier (Arg1);
11322 Check_No_Identifiers;
11325 -- The second parameter is optional, it is never analyzed
11330 -- Otherwise there is a second parameter
11333 -- The second parameter must be an identifier
11335 Check_Arg_Is_Identifier (Arg2);
11337 -- Process the remaining parameters (if any)
11339 Arg := Next (Arg2);
11340 while Present (Arg) loop
11341 Expr := Get_Pragma_Arg (Arg);
11344 if Is_Entity_Name (Expr) then
11347 -- For string literals, we assume Standard_String as the
11348 -- type, unless the string contains wide or wide_wide
11351 elsif Nkind (Expr) = N_String_Literal then
11352 if Has_Wide_Wide_Character (Expr) then
11353 Resolve (Expr, Standard_Wide_Wide_String);
11354 elsif Has_Wide_Character (Expr) then
11355 Resolve (Expr, Standard_Wide_String);
11357 Resolve (Expr, Standard_String);
11360 elsif Is_Overloaded (Expr) then
11361 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11372 -------------------------------------------------
11373 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11374 -------------------------------------------------
11377 -- ( [Check => ] Boolean_EXPRESSION
11378 -- [, [Message =>] Static_String_EXPRESSION]);
11380 -- pragma Assert_And_Cut
11381 -- ( [Check => ] Boolean_EXPRESSION
11382 -- [, [Message =>] Static_String_EXPRESSION]);
11385 -- ( [Check => ] Boolean_EXPRESSION
11386 -- [, [Message =>] Static_String_EXPRESSION]);
11388 -- pragma Loop_Invariant
11389 -- ( [Check => ] Boolean_EXPRESSION
11390 -- [, [Message =>] Static_String_EXPRESSION]);
11392 when Pragma_Assert |
11393 Pragma_Assert_And_Cut |
11395 Pragma_Loop_Invariant =>
11397 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11398 -- Determine whether expression Expr contains a Loop_Entry
11399 -- attribute reference.
11401 -------------------------
11402 -- Contains_Loop_Entry --
11403 -------------------------
11405 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11406 Has_Loop_Entry : Boolean := False;
11408 function Process (N : Node_Id) return Traverse_Result;
11409 -- Process function for traversal to look for Loop_Entry
11415 function Process (N : Node_Id) return Traverse_Result is
11417 if Nkind (N) = N_Attribute_Reference
11418 and then Attribute_Name (N) = Name_Loop_Entry
11420 Has_Loop_Entry := True;
11427 procedure Traverse is new Traverse_Proc (Process);
11429 -- Start of processing for Contains_Loop_Entry
11433 return Has_Loop_Entry;
11434 end Contains_Loop_Entry;
11439 New_Args : List_Id;
11441 -- Start of processing for Assert
11444 -- Assert is an Ada 2005 RM-defined pragma
11446 if Prag_Id = Pragma_Assert then
11449 -- The remaining ones are GNAT pragmas
11455 Check_At_Least_N_Arguments (1);
11456 Check_At_Most_N_Arguments (2);
11457 Check_Arg_Order ((Name_Check, Name_Message));
11458 Check_Optional_Identifier (Arg1, Name_Check);
11459 Expr := Get_Pragma_Arg (Arg1);
11461 -- Special processing for Loop_Invariant, Loop_Variant or for
11462 -- other cases where a Loop_Entry attribute is present. If the
11463 -- assertion pragma contains attribute Loop_Entry, ensure that
11464 -- the related pragma is within a loop.
11466 if Prag_Id = Pragma_Loop_Invariant
11467 or else Prag_Id = Pragma_Loop_Variant
11468 or else Contains_Loop_Entry (Expr)
11470 Check_Loop_Pragma_Placement;
11472 -- Perform preanalysis to deal with embedded Loop_Entry
11475 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11478 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11479 -- a corresponding Check pragma:
11481 -- pragma Check (name, condition [, msg]);
11483 -- Where name is the identifier matching the pragma name. So
11484 -- rewrite pragma in this manner, transfer the message argument
11485 -- if present, and analyze the result
11487 -- Note: When dealing with a semantically analyzed tree, the
11488 -- information that a Check node N corresponds to a source Assert,
11489 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11490 -- pragma kind of Original_Node(N).
11492 New_Args := New_List (
11493 Make_Pragma_Argument_Association (Loc,
11494 Expression => Make_Identifier (Loc, Pname)),
11495 Make_Pragma_Argument_Association (Sloc (Expr),
11496 Expression => Expr));
11498 if Arg_Count > 1 then
11499 Check_Optional_Identifier (Arg2, Name_Message);
11501 -- Provide semantic annnotations for optional argument, for
11502 -- ASIS use, before rewriting.
11504 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11505 Append_To (New_Args, New_Copy_Tree (Arg2));
11508 -- Rewrite as Check pragma
11512 Chars => Name_Check,
11513 Pragma_Argument_Associations => New_Args));
11518 ----------------------
11519 -- Assertion_Policy --
11520 ----------------------
11522 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11524 -- The following form is Ada 2012 only, but we allow it in all modes
11526 -- Pragma Assertion_Policy (
11527 -- ASSERTION_KIND => POLICY_IDENTIFIER
11528 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11530 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11532 -- RM_ASSERTION_KIND ::= Assert |
11533 -- Static_Predicate |
11534 -- Dynamic_Predicate |
11539 -- Type_Invariant |
11540 -- Type_Invariant'Class
11542 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11544 -- Contract_Cases |
11546 -- Default_Initial_Condition |
11548 -- Initial_Condition |
11549 -- Loop_Invariant |
11555 -- Statement_Assertions
11557 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11558 -- ID_ASSERTION_KIND list contains implementation-defined additions
11559 -- recognized by GNAT. The effect is to control the behavior of
11560 -- identically named aspects and pragmas, depending on the specified
11561 -- policy identifier:
11563 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11565 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11566 -- implementation-defined addition that results in totally ignoring
11567 -- the corresponding assertion. If Disable is specified, then the
11568 -- argument of the assertion is not even analyzed. This is useful
11569 -- when the aspect/pragma argument references entities in a with'ed
11570 -- package that is replaced by a dummy package in the final build.
11572 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11573 -- and Type_Invariant'Class were recognized by the parser and
11574 -- transformed into references to the special internal identifiers
11575 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11576 -- processing is required here.
11578 when Pragma_Assertion_Policy => Assertion_Policy : declare
11587 -- This can always appear as a configuration pragma
11589 if Is_Configuration_Pragma then
11592 -- It can also appear in a declarative part or package spec in Ada
11593 -- 2012 mode. We allow this in other modes, but in that case we
11594 -- consider that we have an Ada 2012 pragma on our hands.
11597 Check_Is_In_Decl_Part_Or_Package_Spec;
11601 -- One argument case with no identifier (first form above)
11604 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11605 or else Chars (Arg1) = No_Name)
11607 Check_Arg_Is_One_Of
11608 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11610 -- Treat one argument Assertion_Policy as equivalent to:
11612 -- pragma Check_Policy (Assertion, policy)
11614 -- So rewrite pragma in that manner and link on to the chain
11615 -- of Check_Policy pragmas, marking the pragma as analyzed.
11617 Policy := Get_Pragma_Arg (Arg1);
11621 Chars => Name_Check_Policy,
11622 Pragma_Argument_Associations => New_List (
11623 Make_Pragma_Argument_Association (Loc,
11624 Expression => Make_Identifier (Loc, Name_Assertion)),
11626 Make_Pragma_Argument_Association (Loc,
11628 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11631 -- Here if we have two or more arguments
11634 Check_At_Least_N_Arguments (1);
11637 -- Loop through arguments
11640 while Present (Arg) loop
11641 LocP := Sloc (Arg);
11643 -- Kind must be specified
11645 if Nkind (Arg) /= N_Pragma_Argument_Association
11646 or else Chars (Arg) = No_Name
11649 ("missing assertion kind for pragma%", Arg);
11652 -- Check Kind and Policy have allowed forms
11654 Kind := Chars (Arg);
11655 Policy := Get_Pragma_Arg (Arg);
11657 if not Is_Valid_Assertion_Kind (Kind) then
11659 ("invalid assertion kind for pragma%", Arg);
11662 Check_Arg_Is_One_Of
11663 (Arg, Name_Check, Name_Disable, Name_Ignore);
11665 if Kind = Name_Ghost then
11667 -- The Ghost policy must be either Check or Ignore
11668 -- (SPARK RM 6.9(6)).
11670 if not Nam_In (Chars (Policy), Name_Check,
11674 ("argument of pragma % Ghost must be Check or "
11675 & "Ignore", Policy);
11678 -- Pragma Assertion_Policy specifying a Ghost policy
11679 -- cannot occur within a Ghost subprogram or package
11680 -- (SPARK RM 6.9(14)).
11682 if Ghost_Mode > None then
11684 ("pragma % cannot appear within ghost subprogram or "
11689 -- Rewrite the Assertion_Policy pragma as a series of
11690 -- Check_Policy pragmas of the form:
11692 -- Check_Policy (Kind, Policy);
11694 -- Note: the insertion of the pragmas cannot be done with
11695 -- Insert_Action because in the configuration case, there
11696 -- are no scopes on the scope stack and the mechanism will
11699 Insert_Before_And_Analyze (N,
11701 Chars => Name_Check_Policy,
11702 Pragma_Argument_Associations => New_List (
11703 Make_Pragma_Argument_Association (LocP,
11704 Expression => Make_Identifier (LocP, Kind)),
11705 Make_Pragma_Argument_Association (LocP,
11706 Expression => Policy))));
11711 -- Rewrite the Assertion_Policy pragma as null since we have
11712 -- now inserted all the equivalent Check pragmas.
11714 Rewrite (N, Make_Null_Statement (Loc));
11717 end Assertion_Policy;
11719 ------------------------------
11720 -- Assume_No_Invalid_Values --
11721 ------------------------------
11723 -- pragma Assume_No_Invalid_Values (On | Off);
11725 when Pragma_Assume_No_Invalid_Values =>
11727 Check_Valid_Configuration_Pragma;
11728 Check_Arg_Count (1);
11729 Check_No_Identifiers;
11730 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11732 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11733 Assume_No_Invalid_Values := True;
11735 Assume_No_Invalid_Values := False;
11738 --------------------------
11739 -- Attribute_Definition --
11740 --------------------------
11742 -- pragma Attribute_Definition
11743 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11744 -- [Entity =>] LOCAL_NAME,
11745 -- [Expression =>] EXPRESSION | NAME);
11747 when Pragma_Attribute_Definition => Attribute_Definition : declare
11748 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11753 Check_Arg_Count (3);
11754 Check_Optional_Identifier (Arg1, "attribute");
11755 Check_Optional_Identifier (Arg2, "entity");
11756 Check_Optional_Identifier (Arg3, "expression");
11758 if Nkind (Attribute_Designator) /= N_Identifier then
11759 Error_Msg_N ("attribute name expected", Attribute_Designator);
11763 Check_Arg_Is_Local_Name (Arg2);
11765 -- If the attribute is not recognized, then issue a warning (not
11766 -- an error), and ignore the pragma.
11768 Aname := Chars (Attribute_Designator);
11770 if not Is_Attribute_Name (Aname) then
11771 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11775 -- Otherwise, rewrite the pragma as an attribute definition clause
11778 Make_Attribute_Definition_Clause (Loc,
11779 Name => Get_Pragma_Arg (Arg2),
11781 Expression => Get_Pragma_Arg (Arg3)));
11783 end Attribute_Definition;
11785 ------------------------------------------------------------------
11786 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11787 ------------------------------------------------------------------
11789 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11790 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11791 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11792 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11794 when Pragma_Async_Readers |
11795 Pragma_Async_Writers |
11796 Pragma_Effective_Reads |
11797 Pragma_Effective_Writes =>
11798 Async_Effective : declare
11799 Obj_Decl : Node_Id;
11800 Obj_Id : Entity_Id;
11804 Check_No_Identifiers;
11805 Check_At_Most_N_Arguments (1);
11807 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
11809 -- Object declaration
11811 if Nkind (Obj_Decl) = N_Object_Declaration then
11814 -- Otherwise the pragma is associated with an illegal construact
11821 Obj_Id := Defining_Entity (Obj_Decl);
11823 -- Perform minimal verification to ensure that the argument is at
11824 -- least a variable. Subsequent finer grained checks will be done
11825 -- at the end of the declarative region the contains the pragma.
11827 if Ekind (Obj_Id) = E_Variable then
11829 -- Chain the pragma on the contract for further processing by
11830 -- Analyze_External_Property_In_Decl_Part.
11832 Add_Contract_Item (N, Obj_Id);
11834 -- A pragma that applies to a Ghost entity becomes Ghost for
11835 -- the purposes of legality checks and removal of ignored Ghost
11838 Mark_Pragma_As_Ghost (N, Obj_Id);
11840 -- Analyze the Boolean expression (if any)
11842 if Present (Arg1) then
11843 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
11846 -- Otherwise the external property applies to a constant
11849 Error_Pragma ("pragma % must apply to a volatile object");
11851 end Async_Effective;
11857 -- pragma Asynchronous (LOCAL_NAME);
11859 when Pragma_Asynchronous => Asynchronous : declare
11862 Formal : Entity_Id;
11867 procedure Process_Async_Pragma;
11868 -- Common processing for procedure and access-to-procedure case
11870 --------------------------
11871 -- Process_Async_Pragma --
11872 --------------------------
11874 procedure Process_Async_Pragma is
11877 Set_Is_Asynchronous (Nm);
11881 -- The formals should be of mode IN (RM E.4.1(6))
11884 while Present (S) loop
11885 Formal := Defining_Identifier (S);
11887 if Nkind (Formal) = N_Defining_Identifier
11888 and then Ekind (Formal) /= E_In_Parameter
11891 ("pragma% procedure can only have IN parameter",
11898 Set_Is_Asynchronous (Nm);
11899 end Process_Async_Pragma;
11901 -- Start of processing for pragma Asynchronous
11904 Check_Ada_83_Warning;
11905 Check_No_Identifiers;
11906 Check_Arg_Count (1);
11907 Check_Arg_Is_Local_Name (Arg1);
11909 if Debug_Flag_U then
11913 C_Ent := Cunit_Entity (Current_Sem_Unit);
11914 Analyze (Get_Pragma_Arg (Arg1));
11915 Nm := Entity (Get_Pragma_Arg (Arg1));
11917 -- A pragma that applies to a Ghost entity becomes Ghost for the
11918 -- purposes of legality checks and removal of ignored Ghost code.
11920 Mark_Pragma_As_Ghost (N, Nm);
11922 if not Is_Remote_Call_Interface (C_Ent)
11923 and then not Is_Remote_Types (C_Ent)
11925 -- This pragma should only appear in an RCI or Remote Types
11926 -- unit (RM E.4.1(4)).
11929 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11932 if Ekind (Nm) = E_Procedure
11933 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11935 if not Is_Remote_Call_Interface (Nm) then
11937 ("pragma% cannot be applied on non-remote procedure",
11941 L := Parameter_Specifications (Parent (Nm));
11942 Process_Async_Pragma;
11945 elsif Ekind (Nm) = E_Function then
11947 ("pragma% cannot be applied to function", Arg1);
11949 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11950 if Is_Record_Type (Nm) then
11952 -- A record type that is the Equivalent_Type for a remote
11953 -- access-to-subprogram type.
11955 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
11958 -- A non-expanded RAS type (distribution is not enabled)
11960 Decl := Declaration_Node (Nm);
11963 if Nkind (Decl) = N_Full_Type_Declaration
11964 and then Nkind (Type_Definition (Decl)) =
11965 N_Access_Procedure_Definition
11967 L := Parameter_Specifications (Type_Definition (Decl));
11968 Process_Async_Pragma;
11970 if Is_Asynchronous (Nm)
11971 and then Expander_Active
11972 and then Get_PCS_Name /= Name_No_DSA
11974 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11979 ("pragma% cannot reference access-to-function type",
11983 -- Only other possibility is Access-to-class-wide type
11985 elsif Is_Access_Type (Nm)
11986 and then Is_Class_Wide_Type (Designated_Type (Nm))
11988 Check_First_Subtype (Arg1);
11989 Set_Is_Asynchronous (Nm);
11990 if Expander_Active then
11991 RACW_Type_Is_Asynchronous (Nm);
11995 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12003 -- pragma Atomic (LOCAL_NAME);
12005 when Pragma_Atomic =>
12006 Process_Atomic_Independent_Shared_Volatile;
12008 -----------------------
12009 -- Atomic_Components --
12010 -----------------------
12012 -- pragma Atomic_Components (array_LOCAL_NAME);
12014 -- This processing is shared by Volatile_Components
12016 when Pragma_Atomic_Components |
12017 Pragma_Volatile_Components =>
12018 Atomic_Components : declare
12025 Check_Ada_83_Warning;
12026 Check_No_Identifiers;
12027 Check_Arg_Count (1);
12028 Check_Arg_Is_Local_Name (Arg1);
12029 E_Id := Get_Pragma_Arg (Arg1);
12031 if Etype (E_Id) = Any_Type then
12035 E := Entity (E_Id);
12037 -- A pragma that applies to a Ghost entity becomes Ghost for the
12038 -- purposes of legality checks and removal of ignored Ghost code.
12040 Mark_Pragma_As_Ghost (N, E);
12041 Check_Duplicate_Pragma (E);
12043 if Rep_Item_Too_Early (E, N)
12045 Rep_Item_Too_Late (E, N)
12050 D := Declaration_Node (E);
12053 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12055 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12056 and then Nkind (D) = N_Object_Declaration
12057 and then Nkind (Object_Definition (D)) =
12058 N_Constrained_Array_Definition)
12060 -- The flag is set on the object, or on the base type
12062 if Nkind (D) /= N_Object_Declaration then
12063 E := Base_Type (E);
12066 -- Atomic implies both Independent and Volatile
12068 if Prag_Id = Pragma_Atomic_Components then
12069 Set_Has_Atomic_Components (E);
12070 Set_Has_Independent_Components (E);
12073 Set_Has_Volatile_Components (E);
12076 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12078 end Atomic_Components;
12080 --------------------
12081 -- Attach_Handler --
12082 --------------------
12084 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12086 when Pragma_Attach_Handler =>
12087 Check_Ada_83_Warning;
12088 Check_No_Identifiers;
12089 Check_Arg_Count (2);
12091 if No_Run_Time_Mode then
12092 Error_Msg_CRT ("Attach_Handler pragma", N);
12094 Check_Interrupt_Or_Attach_Handler;
12096 -- The expression that designates the attribute may depend on a
12097 -- discriminant, and is therefore a per-object expression, to
12098 -- be expanded in the init proc. If expansion is enabled, then
12099 -- perform semantic checks on a copy only.
12104 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12107 -- In Relaxed_RM_Semantics mode, we allow any static
12108 -- integer value, for compatibility with other compilers.
12110 if Relaxed_RM_Semantics
12111 and then Nkind (Parg2) = N_Integer_Literal
12113 Typ := Standard_Integer;
12115 Typ := RTE (RE_Interrupt_ID);
12118 if Expander_Active then
12119 Temp := New_Copy_Tree (Parg2);
12120 Set_Parent (Temp, N);
12121 Preanalyze_And_Resolve (Temp, Typ);
12124 Resolve (Parg2, Typ);
12128 Process_Interrupt_Or_Attach_Handler;
12131 --------------------
12132 -- C_Pass_By_Copy --
12133 --------------------
12135 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12137 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12143 Check_Valid_Configuration_Pragma;
12144 Check_Arg_Count (1);
12145 Check_Optional_Identifier (Arg1, "max_size");
12147 Arg := Get_Pragma_Arg (Arg1);
12148 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12150 Val := Expr_Value (Arg);
12154 ("maximum size for pragma% must be positive", Arg1);
12156 elsif UI_Is_In_Int_Range (Val) then
12157 Default_C_Record_Mechanism := UI_To_Int (Val);
12159 -- If a giant value is given, Int'Last will do well enough.
12160 -- If sometime someone complains that a record larger than
12161 -- two gigabytes is not copied, we will worry about it then.
12164 Default_C_Record_Mechanism := Mechanism_Type'Last;
12166 end C_Pass_By_Copy;
12172 -- pragma Check ([Name =>] CHECK_KIND,
12173 -- [Check =>] Boolean_EXPRESSION
12174 -- [,[Message =>] String_EXPRESSION]);
12176 -- CHECK_KIND ::= IDENTIFIER |
12179 -- Invariant'Class |
12180 -- Type_Invariant'Class
12182 -- The identifiers Assertions and Statement_Assertions are not
12183 -- allowed, since they have special meaning for Check_Policy.
12185 when Pragma_Check => Check : declare
12191 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12194 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12195 -- the mode now to ensure that any nodes generated during analysis
12196 -- and expansion are marked as Ghost.
12198 Set_Ghost_Mode (N);
12201 Check_At_Least_N_Arguments (2);
12202 Check_At_Most_N_Arguments (3);
12203 Check_Optional_Identifier (Arg1, Name_Name);
12204 Check_Optional_Identifier (Arg2, Name_Check);
12206 if Arg_Count = 3 then
12207 Check_Optional_Identifier (Arg3, Name_Message);
12208 Str := Get_Pragma_Arg (Arg3);
12211 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12212 Check_Arg_Is_Identifier (Arg1);
12213 Cname := Chars (Get_Pragma_Arg (Arg1));
12215 -- Check forbidden name Assertions or Statement_Assertions
12218 when Name_Assertions =>
12220 ("""Assertions"" is not allowed as a check kind for "
12221 & "pragma%", Arg1);
12223 when Name_Statement_Assertions =>
12225 ("""Statement_Assertions"" is not allowed as a check kind "
12226 & "for pragma%", Arg1);
12232 -- Check applicable policy. We skip this if Checked/Ignored status
12233 -- is already set (e.g. in the case of a pragma from an aspect).
12235 if Is_Checked (N) or else Is_Ignored (N) then
12238 -- For a non-source pragma that is a rewriting of another pragma,
12239 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12241 elsif Is_Rewrite_Substitution (N)
12242 and then Nkind (Original_Node (N)) = N_Pragma
12243 and then Original_Node (N) /= N
12245 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12246 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12248 -- Otherwise query the applicable policy at this point
12251 case Check_Kind (Cname) is
12252 when Name_Ignore =>
12253 Set_Is_Ignored (N, True);
12254 Set_Is_Checked (N, False);
12257 Set_Is_Ignored (N, False);
12258 Set_Is_Checked (N, True);
12260 -- For disable, rewrite pragma as null statement and skip
12261 -- rest of the analysis of the pragma.
12263 when Name_Disable =>
12264 Rewrite (N, Make_Null_Statement (Loc));
12268 -- No other possibilities
12271 raise Program_Error;
12275 -- If check kind was not Disable, then continue pragma analysis
12277 Expr := Get_Pragma_Arg (Arg2);
12279 -- Deal with SCO generation
12283 -- Nothing to do for predicates as the checks occur in the
12284 -- client units. The SCO for the aspect in the declaration
12285 -- unit is conservatively always enabled.
12287 when Name_Predicate =>
12290 -- Otherwise mark aspect/pragma SCO as enabled
12293 if Is_Checked (N) and then not Split_PPC (N) then
12294 Set_SCO_Pragma_Enabled (Loc);
12298 -- Deal with analyzing the string argument
12300 if Arg_Count = 3 then
12302 -- If checks are not on we don't want any expansion (since
12303 -- such expansion would not get properly deleted) but
12304 -- we do want to analyze (to get proper references).
12305 -- The Preanalyze_And_Resolve routine does just what we want
12307 if Is_Ignored (N) then
12308 Preanalyze_And_Resolve (Str, Standard_String);
12310 -- Otherwise we need a proper analysis and expansion
12313 Analyze_And_Resolve (Str, Standard_String);
12317 -- Now you might think we could just do the same with the Boolean
12318 -- expression if checks are off (and expansion is on) and then
12319 -- rewrite the check as a null statement. This would work but we
12320 -- would lose the useful warnings about an assertion being bound
12321 -- to fail even if assertions are turned off.
12323 -- So instead we wrap the boolean expression in an if statement
12324 -- that looks like:
12326 -- if False and then condition then
12330 -- The reason we do this rewriting during semantic analysis rather
12331 -- than as part of normal expansion is that we cannot analyze and
12332 -- expand the code for the boolean expression directly, or it may
12333 -- cause insertion of actions that would escape the attempt to
12334 -- suppress the check code.
12336 -- Note that the Sloc for the if statement corresponds to the
12337 -- argument condition, not the pragma itself. The reason for
12338 -- this is that we may generate a warning if the condition is
12339 -- False at compile time, and we do not want to delete this
12340 -- warning when we delete the if statement.
12342 if Expander_Active and Is_Ignored (N) then
12343 Eloc := Sloc (Expr);
12346 Make_If_Statement (Eloc,
12348 Make_And_Then (Eloc,
12349 Left_Opnd => Make_Identifier (Eloc, Name_False),
12350 Right_Opnd => Expr),
12351 Then_Statements => New_List (
12352 Make_Null_Statement (Eloc))));
12354 -- Now go ahead and analyze the if statement
12356 In_Assertion_Expr := In_Assertion_Expr + 1;
12358 -- One rather special treatment. If we are now in Eliminated
12359 -- overflow mode, then suppress overflow checking since we do
12360 -- not want to drag in the bignum stuff if we are in Ignore
12361 -- mode anyway. This is particularly important if we are using
12362 -- a configurable run time that does not support bignum ops.
12364 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12366 Svo : constant Boolean :=
12367 Scope_Suppress.Suppress (Overflow_Check);
12369 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12370 Scope_Suppress.Suppress (Overflow_Check) := True;
12372 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12373 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12376 -- Not that special case
12382 -- All done with this check
12384 In_Assertion_Expr := In_Assertion_Expr - 1;
12386 -- Check is active or expansion not active. In these cases we can
12387 -- just go ahead and analyze the boolean with no worries.
12390 In_Assertion_Expr := In_Assertion_Expr + 1;
12391 Analyze_And_Resolve (Expr, Any_Boolean);
12392 In_Assertion_Expr := In_Assertion_Expr - 1;
12395 Ghost_Mode := Save_Ghost_Mode;
12398 --------------------------
12399 -- Check_Float_Overflow --
12400 --------------------------
12402 -- pragma Check_Float_Overflow;
12404 when Pragma_Check_Float_Overflow =>
12406 Check_Valid_Configuration_Pragma;
12407 Check_Arg_Count (0);
12408 Check_Float_Overflow := not Machine_Overflows_On_Target;
12414 -- pragma Check_Name (check_IDENTIFIER);
12416 when Pragma_Check_Name =>
12418 Check_No_Identifiers;
12419 Check_Valid_Configuration_Pragma;
12420 Check_Arg_Count (1);
12421 Check_Arg_Is_Identifier (Arg1);
12424 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12427 for J in Check_Names.First .. Check_Names.Last loop
12428 if Check_Names.Table (J) = Nam then
12433 Check_Names.Append (Nam);
12440 -- This is the old style syntax, which is still allowed in all modes:
12442 -- pragma Check_Policy ([Name =>] CHECK_KIND
12443 -- [Policy =>] POLICY_IDENTIFIER);
12445 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12447 -- CHECK_KIND ::= IDENTIFIER |
12450 -- Type_Invariant'Class |
12453 -- This is the new style syntax, compatible with Assertion_Policy
12454 -- and also allowed in all modes.
12456 -- Pragma Check_Policy (
12457 -- CHECK_KIND => POLICY_IDENTIFIER
12458 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12460 -- Note: the identifiers Name and Policy are not allowed as
12461 -- Check_Kind values. This avoids ambiguities between the old and
12462 -- new form syntax.
12464 when Pragma_Check_Policy => Check_Policy : declare
12469 Check_At_Least_N_Arguments (1);
12471 -- A Check_Policy pragma can appear either as a configuration
12472 -- pragma, or in a declarative part or a package spec (see RM
12473 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12474 -- followed for Check_Policy).
12476 if not Is_Configuration_Pragma then
12477 Check_Is_In_Decl_Part_Or_Package_Spec;
12480 -- Figure out if we have the old or new syntax. We have the
12481 -- old syntax if the first argument has no identifier, or the
12482 -- identifier is Name.
12484 if Nkind (Arg1) /= N_Pragma_Argument_Association
12485 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12489 Check_Arg_Count (2);
12490 Check_Optional_Identifier (Arg1, Name_Name);
12491 Kind := Get_Pragma_Arg (Arg1);
12492 Rewrite_Assertion_Kind (Kind);
12493 Check_Arg_Is_Identifier (Arg1);
12495 -- Check forbidden check kind
12497 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12498 Error_Msg_Name_2 := Chars (Kind);
12500 ("pragma% does not allow% as check name", Arg1);
12505 Check_Optional_Identifier (Arg2, Name_Policy);
12506 Check_Arg_Is_One_Of
12508 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12510 -- And chain pragma on the Check_Policy_List for search
12512 Set_Next_Pragma (N, Opt.Check_Policy_List);
12513 Opt.Check_Policy_List := N;
12515 -- For the new syntax, what we do is to convert each argument to
12516 -- an old syntax equivalent. We do that because we want to chain
12517 -- old style Check_Policy pragmas for the search (we don't want
12518 -- to have to deal with multiple arguments in the search).
12529 while Present (Arg) loop
12530 LocP := Sloc (Arg);
12531 Argx := Get_Pragma_Arg (Arg);
12533 -- Kind must be specified
12535 if Nkind (Arg) /= N_Pragma_Argument_Association
12536 or else Chars (Arg) = No_Name
12539 ("missing assertion kind for pragma%", Arg);
12542 -- Construct equivalent old form syntax Check_Policy
12543 -- pragma and insert it to get remaining checks.
12547 Chars => Name_Check_Policy,
12548 Pragma_Argument_Associations => New_List (
12549 Make_Pragma_Argument_Association (LocP,
12551 Make_Identifier (LocP, Chars (Arg))),
12552 Make_Pragma_Argument_Association (Sloc (Argx),
12553 Expression => Argx)));
12557 -- For a configuration pragma, insert old form in
12558 -- the corresponding file.
12560 if Is_Configuration_Pragma then
12561 Insert_After (N, New_P);
12565 Insert_Action (N, New_P);
12569 -- Rewrite original Check_Policy pragma to null, since we
12570 -- have converted it into a series of old syntax pragmas.
12572 Rewrite (N, Make_Null_Statement (Loc));
12582 -- pragma Comment (static_string_EXPRESSION)
12584 -- Processing for pragma Comment shares the circuitry for pragma
12585 -- Ident. The only differences are that Ident enforces a limit of 31
12586 -- characters on its argument, and also enforces limitations on
12587 -- placement for DEC compatibility. Pragma Comment shares neither of
12588 -- these restrictions.
12590 -------------------
12591 -- Common_Object --
12592 -------------------
12594 -- pragma Common_Object (
12595 -- [Internal =>] LOCAL_NAME
12596 -- [, [External =>] EXTERNAL_SYMBOL]
12597 -- [, [Size =>] EXTERNAL_SYMBOL]);
12599 -- Processing for this pragma is shared with Psect_Object
12601 ------------------------
12602 -- Compile_Time_Error --
12603 ------------------------
12605 -- pragma Compile_Time_Error
12606 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12608 when Pragma_Compile_Time_Error =>
12610 Process_Compile_Time_Warning_Or_Error;
12612 --------------------------
12613 -- Compile_Time_Warning --
12614 --------------------------
12616 -- pragma Compile_Time_Warning
12617 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12619 when Pragma_Compile_Time_Warning =>
12621 Process_Compile_Time_Warning_Or_Error;
12623 ---------------------------
12624 -- Compiler_Unit_Warning --
12625 ---------------------------
12627 -- pragma Compiler_Unit_Warning;
12631 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12632 -- errors not warnings. This means that we had introduced a big extra
12633 -- inertia to compiler changes, since even if we implemented a new
12634 -- feature, and even if all versions to be used for bootstrapping
12635 -- implemented this new feature, we could not use it, since old
12636 -- compilers would give errors for using this feature in units
12637 -- having Compiler_Unit pragmas.
12639 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12640 -- problem. We no longer have any units mentioning Compiler_Unit,
12641 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12642 -- and thus generates a warning which can be ignored. So that deals
12643 -- with the problem of old compilers not implementing the newer form
12646 -- Newer compilers recognize the new pragma, but generate warning
12647 -- messages instead of errors, which again can be ignored in the
12648 -- case of an old compiler which implements a wanted new feature
12649 -- but at the time felt like warning about it for older compilers.
12651 -- We retain Compiler_Unit so that new compilers can be used to build
12652 -- older run-times that use this pragma. That's an unusual case, but
12653 -- it's easy enough to handle, so why not?
12655 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12657 Check_Arg_Count (0);
12659 -- Only recognized in main unit
12661 if Current_Sem_Unit = Main_Unit then
12662 Compiler_Unit := True;
12665 -----------------------------
12666 -- Complete_Representation --
12667 -----------------------------
12669 -- pragma Complete_Representation;
12671 when Pragma_Complete_Representation =>
12673 Check_Arg_Count (0);
12675 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12677 ("pragma & must appear within record representation clause");
12680 ----------------------------
12681 -- Complex_Representation --
12682 ----------------------------
12684 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12686 when Pragma_Complex_Representation => Complex_Representation : declare
12693 Check_Arg_Count (1);
12694 Check_Optional_Identifier (Arg1, Name_Entity);
12695 Check_Arg_Is_Local_Name (Arg1);
12696 E_Id := Get_Pragma_Arg (Arg1);
12698 if Etype (E_Id) = Any_Type then
12702 E := Entity (E_Id);
12704 if not Is_Record_Type (E) then
12706 ("argument for pragma% must be record type", Arg1);
12709 Ent := First_Entity (E);
12712 or else No (Next_Entity (Ent))
12713 or else Present (Next_Entity (Next_Entity (Ent)))
12714 or else not Is_Floating_Point_Type (Etype (Ent))
12715 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12718 ("record for pragma% must have two fields of the same "
12719 & "floating-point type", Arg1);
12722 Set_Has_Complex_Representation (Base_Type (E));
12724 -- We need to treat the type has having a non-standard
12725 -- representation, for back-end purposes, even though in
12726 -- general a complex will have the default representation
12727 -- of a record with two real components.
12729 Set_Has_Non_Standard_Rep (Base_Type (E));
12731 end Complex_Representation;
12733 -------------------------
12734 -- Component_Alignment --
12735 -------------------------
12737 -- pragma Component_Alignment (
12738 -- [Form =>] ALIGNMENT_CHOICE
12739 -- [, [Name =>] type_LOCAL_NAME]);
12741 -- ALIGNMENT_CHOICE ::=
12743 -- | Component_Size_4
12747 when Pragma_Component_Alignment => Component_AlignmentP : declare
12748 Args : Args_List (1 .. 2);
12749 Names : constant Name_List (1 .. 2) := (
12753 Form : Node_Id renames Args (1);
12754 Name : Node_Id renames Args (2);
12756 Atype : Component_Alignment_Kind;
12761 Gather_Associations (Names, Args);
12764 Error_Pragma ("missing Form argument for pragma%");
12767 Check_Arg_Is_Identifier (Form);
12769 -- Get proper alignment, note that Default = Component_Size on all
12770 -- machines we have so far, and we want to set this value rather
12771 -- than the default value to indicate that it has been explicitly
12772 -- set (and thus will not get overridden by the default component
12773 -- alignment for the current scope)
12775 if Chars (Form) = Name_Component_Size then
12776 Atype := Calign_Component_Size;
12778 elsif Chars (Form) = Name_Component_Size_4 then
12779 Atype := Calign_Component_Size_4;
12781 elsif Chars (Form) = Name_Default then
12782 Atype := Calign_Component_Size;
12784 elsif Chars (Form) = Name_Storage_Unit then
12785 Atype := Calign_Storage_Unit;
12789 ("invalid Form parameter for pragma%", Form);
12792 -- Case with no name, supplied, affects scope table entry
12796 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12798 -- Case of name supplied
12801 Check_Arg_Is_Local_Name (Name);
12803 Typ := Entity (Name);
12806 or else Rep_Item_Too_Early (Typ, N)
12810 Typ := Underlying_Type (Typ);
12813 if not Is_Record_Type (Typ)
12814 and then not Is_Array_Type (Typ)
12817 ("Name parameter of pragma% must identify record or "
12818 & "array type", Name);
12821 -- An explicit Component_Alignment pragma overrides an
12822 -- implicit pragma Pack, but not an explicit one.
12824 if not Has_Pragma_Pack (Base_Type (Typ)) then
12825 Set_Is_Packed (Base_Type (Typ), False);
12826 Set_Component_Alignment (Base_Type (Typ), Atype);
12829 end Component_AlignmentP;
12831 --------------------------------
12832 -- Constant_After_Elaboration --
12833 --------------------------------
12835 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12837 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
12839 Obj_Decl : Node_Id;
12840 Obj_Id : Entity_Id;
12844 Check_No_Identifiers;
12845 Check_At_Most_N_Arguments (1);
12847 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12849 -- Object declaration
12851 if Nkind (Obj_Decl) = N_Object_Declaration then
12854 -- Otherwise the pragma is associated with an illegal construct
12861 Obj_Id := Defining_Entity (Obj_Decl);
12863 -- The object declaration must be a library-level variable which
12864 -- is either explicitly initialized or obtains a value during the
12865 -- elaboration of a package body (SPARK RM 3.3.1).
12867 if Ekind (Obj_Id) = E_Variable then
12868 if not Is_Library_Level_Entity (Obj_Id) then
12870 ("pragma % must apply to a library level variable");
12874 -- Otherwise the pragma applies to a constant, which is illegal
12877 Error_Pragma ("pragma % must apply to a variable declaration");
12881 -- Chain the pragma on the contract for completeness
12883 Add_Contract_Item (N, Obj_Id);
12885 -- A pragma that applies to a Ghost entity becomes Ghost for the
12886 -- purposes of legality checks and removal of ignored Ghost code.
12888 Mark_Pragma_As_Ghost (N, Obj_Id);
12890 -- Analyze the Boolean expression (if any)
12892 if Present (Arg1) then
12893 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12895 end Constant_After_Elaboration;
12897 --------------------
12898 -- Contract_Cases --
12899 --------------------
12901 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12903 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12905 -- CASE_GUARD ::= boolean_EXPRESSION | others
12907 -- CONSEQUENCE ::= boolean_EXPRESSION
12909 -- Characteristics:
12911 -- * Analysis - The annotation undergoes initial checks to verify
12912 -- the legal placement and context. Secondary checks preanalyze the
12915 -- Analyze_Contract_Cases_In_Decl_Part
12917 -- * Expansion - The annotation is expanded during the expansion of
12918 -- the related subprogram [body] contract as performed in:
12920 -- Expand_Subprogram_Contract
12922 -- * Template - The annotation utilizes the generic template of the
12923 -- related subprogram [body] when it is:
12925 -- aspect on subprogram declaration
12926 -- aspect on stand alone subprogram body
12927 -- pragma on stand alone subprogram body
12929 -- The annotation must prepare its own template when it is:
12931 -- pragma on subprogram declaration
12933 -- * Globals - Capture of global references must occur after full
12936 -- * Instance - The annotation is instantiated automatically when
12937 -- the related generic subprogram [body] is instantiated except for
12938 -- the "pragma on subprogram declaration" case. In that scenario
12939 -- the annotation must instantiate itself.
12941 when Pragma_Contract_Cases => Contract_Cases : declare
12942 Spec_Id : Entity_Id;
12943 Subp_Decl : Node_Id;
12947 Check_No_Identifiers;
12948 Check_Arg_Count (1);
12950 -- Ensure the proper placement of the pragma. Contract_Cases must
12951 -- be associated with a subprogram declaration or a body that acts
12955 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
12959 if Nkind (Subp_Decl) = N_Entry_Declaration then
12962 -- Generic subprogram
12964 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
12967 -- Body acts as spec
12969 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12970 and then No (Corresponding_Spec (Subp_Decl))
12974 -- Body stub acts as spec
12976 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12977 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12983 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
12991 Spec_Id := Unique_Defining_Entity (Subp_Decl);
12993 -- Chain the pragma on the contract for further processing by
12994 -- Analyze_Contract_Cases_In_Decl_Part.
12996 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12998 -- A pragma that applies to a Ghost entity becomes Ghost for the
12999 -- purposes of legality checks and removal of ignored Ghost code.
13001 Mark_Pragma_As_Ghost (N, Spec_Id);
13002 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13004 -- Fully analyze the pragma when it appears inside an entry
13005 -- or subprogram body because it cannot benefit from forward
13008 if Nkind_In (Subp_Decl, N_Entry_Body,
13010 N_Subprogram_Body_Stub)
13012 -- The legality checks of pragma Contract_Cases are affected by
13013 -- the SPARK mode in effect and the volatility of the context.
13014 -- Analyze all pragmas in a specific order.
13016 Analyze_If_Present (Pragma_SPARK_Mode);
13017 Analyze_If_Present (Pragma_Volatile_Function);
13018 Analyze_Contract_Cases_In_Decl_Part (N);
13020 end Contract_Cases;
13026 -- pragma Controlled (first_subtype_LOCAL_NAME);
13028 when Pragma_Controlled => Controlled : declare
13032 Check_No_Identifiers;
13033 Check_Arg_Count (1);
13034 Check_Arg_Is_Local_Name (Arg1);
13035 Arg := Get_Pragma_Arg (Arg1);
13037 if not Is_Entity_Name (Arg)
13038 or else not Is_Access_Type (Entity (Arg))
13040 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13042 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13050 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13051 -- [Entity =>] LOCAL_NAME);
13053 when Pragma_Convention => Convention : declare
13056 pragma Warnings (Off, C);
13057 pragma Warnings (Off, E);
13059 Check_Arg_Order ((Name_Convention, Name_Entity));
13060 Check_Ada_83_Warning;
13061 Check_Arg_Count (2);
13062 Process_Convention (C, E);
13064 -- A pragma that applies to a Ghost entity becomes Ghost for the
13065 -- purposes of legality checks and removal of ignored Ghost code.
13067 Mark_Pragma_As_Ghost (N, E);
13070 ---------------------------
13071 -- Convention_Identifier --
13072 ---------------------------
13074 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13075 -- [Convention =>] convention_IDENTIFIER);
13077 when Pragma_Convention_Identifier => Convention_Identifier : declare
13083 Check_Arg_Order ((Name_Name, Name_Convention));
13084 Check_Arg_Count (2);
13085 Check_Optional_Identifier (Arg1, Name_Name);
13086 Check_Optional_Identifier (Arg2, Name_Convention);
13087 Check_Arg_Is_Identifier (Arg1);
13088 Check_Arg_Is_Identifier (Arg2);
13089 Idnam := Chars (Get_Pragma_Arg (Arg1));
13090 Cname := Chars (Get_Pragma_Arg (Arg2));
13092 if Is_Convention_Name (Cname) then
13093 Record_Convention_Identifier
13094 (Idnam, Get_Convention_Id (Cname));
13097 ("second arg for % pragma must be convention", Arg2);
13099 end Convention_Identifier;
13105 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13107 when Pragma_CPP_Class => CPP_Class : declare
13111 if Warn_On_Obsolescent_Feature then
13113 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13114 & "effect; replace it by pragma import?j?", N);
13117 Check_Arg_Count (1);
13121 Chars => Name_Import,
13122 Pragma_Argument_Associations => New_List (
13123 Make_Pragma_Argument_Association (Loc,
13124 Expression => Make_Identifier (Loc, Name_CPP)),
13125 New_Copy (First (Pragma_Argument_Associations (N))))));
13129 ---------------------
13130 -- CPP_Constructor --
13131 ---------------------
13133 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13134 -- [, [External_Name =>] static_string_EXPRESSION ]
13135 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13137 when Pragma_CPP_Constructor => CPP_Constructor : declare
13140 Def_Id : Entity_Id;
13141 Tag_Typ : Entity_Id;
13145 Check_At_Least_N_Arguments (1);
13146 Check_At_Most_N_Arguments (3);
13147 Check_Optional_Identifier (Arg1, Name_Entity);
13148 Check_Arg_Is_Local_Name (Arg1);
13150 Id := Get_Pragma_Arg (Arg1);
13151 Find_Program_Unit_Name (Id);
13153 -- If we did not find the name, we are done
13155 if Etype (Id) = Any_Type then
13159 Def_Id := Entity (Id);
13161 -- Check if already defined as constructor
13163 if Is_Constructor (Def_Id) then
13165 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13169 if Ekind (Def_Id) = E_Function
13170 and then (Is_CPP_Class (Etype (Def_Id))
13171 or else (Is_Class_Wide_Type (Etype (Def_Id))
13173 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13175 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13177 ("'C'P'P constructor must be defined in the scope of "
13178 & "its returned type", Arg1);
13181 if Arg_Count >= 2 then
13182 Set_Imported (Def_Id);
13183 Set_Is_Public (Def_Id);
13184 Process_Interface_Name (Def_Id, Arg2, Arg3);
13187 Set_Has_Completion (Def_Id);
13188 Set_Is_Constructor (Def_Id);
13189 Set_Convention (Def_Id, Convention_CPP);
13191 -- Imported C++ constructors are not dispatching primitives
13192 -- because in C++ they don't have a dispatch table slot.
13193 -- However, in Ada the constructor has the profile of a
13194 -- function that returns a tagged type and therefore it has
13195 -- been treated as a primitive operation during semantic
13196 -- analysis. We now remove it from the list of primitive
13197 -- operations of the type.
13199 if Is_Tagged_Type (Etype (Def_Id))
13200 and then not Is_Class_Wide_Type (Etype (Def_Id))
13201 and then Is_Dispatching_Operation (Def_Id)
13203 Tag_Typ := Etype (Def_Id);
13205 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13206 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13210 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13211 Set_Is_Dispatching_Operation (Def_Id, False);
13214 -- For backward compatibility, if the constructor returns a
13215 -- class wide type, and we internally change the return type to
13216 -- the corresponding root type.
13218 if Is_Class_Wide_Type (Etype (Def_Id)) then
13219 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13223 ("pragma% requires function returning a 'C'P'P_Class type",
13226 end CPP_Constructor;
13232 when Pragma_CPP_Virtual => CPP_Virtual : declare
13236 if Warn_On_Obsolescent_Feature then
13238 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13247 when Pragma_CPP_Vtable => CPP_Vtable : declare
13251 if Warn_On_Obsolescent_Feature then
13253 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13262 -- pragma CPU (EXPRESSION);
13264 when Pragma_CPU => CPU : declare
13265 P : constant Node_Id := Parent (N);
13271 Check_No_Identifiers;
13272 Check_Arg_Count (1);
13276 if Nkind (P) = N_Subprogram_Body then
13277 Check_In_Main_Program;
13279 Arg := Get_Pragma_Arg (Arg1);
13280 Analyze_And_Resolve (Arg, Any_Integer);
13282 Ent := Defining_Unit_Name (Specification (P));
13284 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13285 Ent := Defining_Identifier (Ent);
13290 if not Is_OK_Static_Expression (Arg) then
13291 Flag_Non_Static_Expr
13292 ("main subprogram affinity is not static!", Arg);
13295 -- If constraint error, then we already signalled an error
13297 elsif Raises_Constraint_Error (Arg) then
13300 -- Otherwise check in range
13304 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13305 -- This is the entity System.Multiprocessors.CPU_Range;
13307 Val : constant Uint := Expr_Value (Arg);
13310 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13312 Val > Expr_Value (Type_High_Bound (CPU_Id))
13315 ("main subprogram CPU is out of range", Arg1);
13321 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13325 elsif Nkind (P) = N_Task_Definition then
13326 Arg := Get_Pragma_Arg (Arg1);
13327 Ent := Defining_Identifier (Parent (P));
13329 -- The expression must be analyzed in the special manner
13330 -- described in "Handling of Default and Per-Object
13331 -- Expressions" in sem.ads.
13333 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13335 -- Anything else is incorrect
13341 -- Check duplicate pragma before we chain the pragma in the Rep
13342 -- Item chain of Ent.
13344 Check_Duplicate_Pragma (Ent);
13345 Record_Rep_Item (Ent, N);
13352 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13354 when Pragma_Debug => Debug : declare
13361 -- The condition for executing the call is that the expander
13362 -- is active and that we are not ignoring this debug pragma.
13367 (Expander_Active and then not Is_Ignored (N)),
13370 if not Is_Ignored (N) then
13371 Set_SCO_Pragma_Enabled (Loc);
13374 if Arg_Count = 2 then
13376 Make_And_Then (Loc,
13377 Left_Opnd => Relocate_Node (Cond),
13378 Right_Opnd => Get_Pragma_Arg (Arg1));
13379 Call := Get_Pragma_Arg (Arg2);
13381 Call := Get_Pragma_Arg (Arg1);
13385 N_Indexed_Component,
13389 N_Selected_Component)
13391 -- If this pragma Debug comes from source, its argument was
13392 -- parsed as a name form (which is syntactically identical).
13393 -- In a generic context a parameterless call will be left as
13394 -- an expanded name (if global) or selected_component if local.
13395 -- Change it to a procedure call statement now.
13397 Change_Name_To_Procedure_Call_Statement (Call);
13399 elsif Nkind (Call) = N_Procedure_Call_Statement then
13401 -- Already in the form of a procedure call statement: nothing
13402 -- to do (could happen in case of an internally generated
13408 -- All other cases: diagnose error
13411 ("argument of pragma ""Debug"" is not procedure call",
13416 -- Rewrite into a conditional with an appropriate condition. We
13417 -- wrap the procedure call in a block so that overhead from e.g.
13418 -- use of the secondary stack does not generate execution overhead
13419 -- for suppressed conditions.
13421 -- Normally the analysis that follows will freeze the subprogram
13422 -- being called. However, if the call is to a null procedure,
13423 -- we want to freeze it before creating the block, because the
13424 -- analysis that follows may be done with expansion disabled, in
13425 -- which case the body will not be generated, leading to spurious
13428 if Nkind (Call) = N_Procedure_Call_Statement
13429 and then Is_Entity_Name (Name (Call))
13431 Analyze (Name (Call));
13432 Freeze_Before (N, Entity (Name (Call)));
13436 Make_Implicit_If_Statement (N,
13438 Then_Statements => New_List (
13439 Make_Block_Statement (Loc,
13440 Handled_Statement_Sequence =>
13441 Make_Handled_Sequence_Of_Statements (Loc,
13442 Statements => New_List (Relocate_Node (Call)))))));
13445 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13446 -- after analysis of the normally rewritten node, to capture all
13447 -- references to entities, which avoids issuing wrong warnings
13448 -- about unused entities.
13450 if GNATprove_Mode then
13451 Rewrite (N, Make_Null_Statement (Loc));
13459 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13461 when Pragma_Debug_Policy =>
13463 Check_Arg_Count (1);
13464 Check_No_Identifiers;
13465 Check_Arg_Is_Identifier (Arg1);
13467 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13468 -- rewrite it that way, and let the rest of the checking come
13469 -- from analyzing the rewritten pragma.
13473 Chars => Name_Check_Policy,
13474 Pragma_Argument_Associations => New_List (
13475 Make_Pragma_Argument_Association (Loc,
13476 Expression => Make_Identifier (Loc, Name_Debug)),
13478 Make_Pragma_Argument_Association (Loc,
13479 Expression => Get_Pragma_Arg (Arg1)))));
13482 -------------------------------
13483 -- Default_Initial_Condition --
13484 -------------------------------
13486 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13488 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13495 Check_No_Identifiers;
13496 Check_At_Most_N_Arguments (1);
13499 while Present (Stmt) loop
13501 -- Skip prior pragmas, but check for duplicates
13503 if Nkind (Stmt) = N_Pragma then
13504 if Pragma_Name (Stmt) = Pname then
13505 Error_Msg_Name_1 := Pname;
13506 Error_Msg_Sloc := Sloc (Stmt);
13507 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13510 -- Skip internally generated code
13512 elsif not Comes_From_Source (Stmt) then
13515 -- The associated private type [extension] has been found, stop
13518 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13519 N_Private_Type_Declaration)
13521 Typ := Defining_Entity (Stmt);
13524 -- The pragma does not apply to a legal construct, issue an
13525 -- error and stop the analysis.
13532 Stmt := Prev (Stmt);
13535 -- A pragma that applies to a Ghost entity becomes Ghost for the
13536 -- purposes of legality checks and removal of ignored Ghost code.
13538 Mark_Pragma_As_Ghost (N, Typ);
13539 Set_Has_Default_Init_Cond (Typ);
13540 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13542 -- Chain the pragma on the rep item chain for further processing
13544 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13545 end Default_Init_Cond;
13547 ----------------------------------
13548 -- Default_Scalar_Storage_Order --
13549 ----------------------------------
13551 -- pragma Default_Scalar_Storage_Order
13552 -- (High_Order_First | Low_Order_First);
13554 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13555 Default : Character;
13559 Check_Arg_Count (1);
13561 -- Default_Scalar_Storage_Order can appear as a configuration
13562 -- pragma, or in a declarative part of a package spec.
13564 if not Is_Configuration_Pragma then
13565 Check_Is_In_Decl_Part_Or_Package_Spec;
13568 Check_No_Identifiers;
13569 Check_Arg_Is_One_Of
13570 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13571 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13572 Default := Fold_Upper (Name_Buffer (1));
13574 if not Support_Nondefault_SSO_On_Target
13575 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13577 if Warn_On_Unrecognized_Pragma then
13579 ("non-default Scalar_Storage_Order not supported "
13580 & "on target?g?", N);
13582 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13585 -- Here set the specified default
13588 Opt.Default_SSO := Default;
13592 --------------------------
13593 -- Default_Storage_Pool --
13594 --------------------------
13596 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13598 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13603 Check_Arg_Count (1);
13605 -- Default_Storage_Pool can appear as a configuration pragma, or
13606 -- in a declarative part of a package spec.
13608 if not Is_Configuration_Pragma then
13609 Check_Is_In_Decl_Part_Or_Package_Spec;
13612 if From_Aspect_Specification (N) then
13614 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13616 if not In_Open_Scopes (E) then
13618 ("aspect must apply to package or subprogram", N);
13623 if Present (Arg1) then
13624 Pool := Get_Pragma_Arg (Arg1);
13626 -- Case of Default_Storage_Pool (null);
13628 if Nkind (Pool) = N_Null then
13631 -- This is an odd case, this is not really an expression,
13632 -- so we don't have a type for it. So just set the type to
13635 Set_Etype (Pool, Empty);
13637 -- Case of Default_Storage_Pool (storage_pool_NAME);
13640 -- If it's a configuration pragma, then the only allowed
13641 -- argument is "null".
13643 if Is_Configuration_Pragma then
13644 Error_Pragma_Arg ("NULL expected", Arg1);
13647 -- The expected type for a non-"null" argument is
13648 -- Root_Storage_Pool'Class, and the pool must be a variable.
13650 Analyze_And_Resolve
13651 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13653 if Is_Variable (Pool) then
13655 -- A pragma that applies to a Ghost entity becomes Ghost
13656 -- for the purposes of legality checks and removal of
13657 -- ignored Ghost code.
13659 Mark_Pragma_As_Ghost (N, Entity (Pool));
13663 ("default storage pool must be a variable", Arg1);
13667 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13668 -- access type will use this information to set the appropriate
13669 -- attributes of the access type.
13671 Default_Pool := Pool;
13673 end Default_Storage_Pool;
13679 -- pragma Depends (DEPENDENCY_RELATION);
13681 -- DEPENDENCY_RELATION ::=
13683 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13685 -- DEPENDENCY_CLAUSE ::=
13686 -- OUTPUT_LIST =>[+] INPUT_LIST
13687 -- | NULL_DEPENDENCY_CLAUSE
13689 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13691 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13693 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13695 -- OUTPUT ::= NAME | FUNCTION_RESULT
13698 -- where FUNCTION_RESULT is a function Result attribute_reference
13700 -- Characteristics:
13702 -- * Analysis - The annotation undergoes initial checks to verify
13703 -- the legal placement and context. Secondary checks fully analyze
13704 -- the dependency clauses in:
13706 -- Analyze_Depends_In_Decl_Part
13708 -- * Expansion - None.
13710 -- * Template - The annotation utilizes the generic template of the
13711 -- related subprogram [body] when it is:
13713 -- aspect on subprogram declaration
13714 -- aspect on stand alone subprogram body
13715 -- pragma on stand alone subprogram body
13717 -- The annotation must prepare its own template when it is:
13719 -- pragma on subprogram declaration
13721 -- * Globals - Capture of global references must occur after full
13724 -- * Instance - The annotation is instantiated automatically when
13725 -- the related generic subprogram [body] is instantiated except for
13726 -- the "pragma on subprogram declaration" case. In that scenario
13727 -- the annotation must instantiate itself.
13729 when Pragma_Depends => Depends : declare
13731 Spec_Id : Entity_Id;
13732 Subp_Decl : Node_Id;
13735 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
13739 -- Chain the pragma on the contract for further processing by
13740 -- Analyze_Depends_In_Decl_Part.
13742 Add_Contract_Item (N, Spec_Id);
13744 -- Fully analyze the pragma when it appears inside an entry
13745 -- or subprogram body because it cannot benefit from forward
13748 if Nkind_In (Subp_Decl, N_Entry_Body,
13750 N_Subprogram_Body_Stub)
13752 -- The legality checks of pragmas Depends and Global are
13753 -- affected by the SPARK mode in effect and the volatility
13754 -- of the context. In addition these two pragmas are subject
13755 -- to an inherent order:
13760 -- Analyze all these pragmas in the order outlined above
13762 Analyze_If_Present (Pragma_SPARK_Mode);
13763 Analyze_If_Present (Pragma_Volatile_Function);
13764 Analyze_If_Present (Pragma_Global);
13765 Analyze_Depends_In_Decl_Part (N);
13770 ---------------------
13771 -- Detect_Blocking --
13772 ---------------------
13774 -- pragma Detect_Blocking;
13776 when Pragma_Detect_Blocking =>
13778 Check_Arg_Count (0);
13779 Check_Valid_Configuration_Pragma;
13780 Detect_Blocking := True;
13782 ------------------------------------
13783 -- Disable_Atomic_Synchronization --
13784 ------------------------------------
13786 -- pragma Disable_Atomic_Synchronization [(Entity)];
13788 when Pragma_Disable_Atomic_Synchronization =>
13790 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13792 -------------------
13793 -- Discard_Names --
13794 -------------------
13796 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13798 when Pragma_Discard_Names => Discard_Names : declare
13803 Check_Ada_83_Warning;
13805 -- Deal with configuration pragma case
13807 if Arg_Count = 0 and then Is_Configuration_Pragma then
13808 Global_Discard_Names := True;
13811 -- Otherwise, check correct appropriate context
13814 Check_Is_In_Decl_Part_Or_Package_Spec;
13816 if Arg_Count = 0 then
13818 -- If there is no parameter, then from now on this pragma
13819 -- applies to any enumeration, exception or tagged type
13820 -- defined in the current declarative part, and recursively
13821 -- to any nested scope.
13823 Set_Discard_Names (Current_Scope);
13827 Check_Arg_Count (1);
13828 Check_Optional_Identifier (Arg1, Name_On);
13829 Check_Arg_Is_Local_Name (Arg1);
13831 E_Id := Get_Pragma_Arg (Arg1);
13833 if Etype (E_Id) = Any_Type then
13836 E := Entity (E_Id);
13839 -- A pragma that applies to a Ghost entity becomes Ghost for
13840 -- the purposes of legality checks and removal of ignored
13843 Mark_Pragma_As_Ghost (N, E);
13845 if (Is_First_Subtype (E)
13847 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13848 or else Ekind (E) = E_Exception
13850 Set_Discard_Names (E);
13851 Record_Rep_Item (E, N);
13855 ("inappropriate entity for pragma%", Arg1);
13861 ------------------------
13862 -- Dispatching_Domain --
13863 ------------------------
13865 -- pragma Dispatching_Domain (EXPRESSION);
13867 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13868 P : constant Node_Id := Parent (N);
13874 Check_No_Identifiers;
13875 Check_Arg_Count (1);
13877 -- This pragma is born obsolete, but not the aspect
13879 if not From_Aspect_Specification (N) then
13881 (No_Obsolescent_Features, Pragma_Identifier (N));
13884 if Nkind (P) = N_Task_Definition then
13885 Arg := Get_Pragma_Arg (Arg1);
13886 Ent := Defining_Identifier (Parent (P));
13888 -- A pragma that applies to a Ghost entity becomes Ghost for
13889 -- the purposes of legality checks and removal of ignored Ghost
13892 Mark_Pragma_As_Ghost (N, Ent);
13894 -- The expression must be analyzed in the special manner
13895 -- described in "Handling of Default and Per-Object
13896 -- Expressions" in sem.ads.
13898 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13900 -- Check duplicate pragma before we chain the pragma in the Rep
13901 -- Item chain of Ent.
13903 Check_Duplicate_Pragma (Ent);
13904 Record_Rep_Item (Ent, N);
13906 -- Anything else is incorrect
13911 end Dispatching_Domain;
13917 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13919 when Pragma_Elaborate => Elaborate : declare
13924 -- Pragma must be in context items list of a compilation unit
13926 if not Is_In_Context_Clause then
13930 -- Must be at least one argument
13932 if Arg_Count = 0 then
13933 Error_Pragma ("pragma% requires at least one argument");
13936 -- In Ada 83 mode, there can be no items following it in the
13937 -- context list except other pragmas and implicit with clauses
13938 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13939 -- placement rule does not apply.
13941 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13943 while Present (Citem) loop
13944 if Nkind (Citem) = N_Pragma
13945 or else (Nkind (Citem) = N_With_Clause
13946 and then Implicit_With (Citem))
13951 ("(Ada 83) pragma% must be at end of context clause");
13958 -- Finally, the arguments must all be units mentioned in a with
13959 -- clause in the same context clause. Note we already checked (in
13960 -- Par.Prag) that the arguments are all identifiers or selected
13964 Outer : while Present (Arg) loop
13965 Citem := First (List_Containing (N));
13966 Inner : while Citem /= N loop
13967 if Nkind (Citem) = N_With_Clause
13968 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13970 Set_Elaborate_Present (Citem, True);
13971 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13973 -- With the pragma present, elaboration calls on
13974 -- subprograms from the named unit need no further
13975 -- checks, as long as the pragma appears in the current
13976 -- compilation unit. If the pragma appears in some unit
13977 -- in the context, there might still be a need for an
13978 -- Elaborate_All_Desirable from the current compilation
13979 -- to the named unit, so we keep the check enabled.
13981 if In_Extended_Main_Source_Unit (N) then
13983 -- This does not apply in SPARK mode, where we allow
13984 -- pragma Elaborate, but we don't trust it to be right
13985 -- so we will still insist on the Elaborate_All.
13987 if SPARK_Mode /= On then
13988 Set_Suppress_Elaboration_Warnings
13989 (Entity (Name (Citem)));
14001 ("argument of pragma% is not withed unit", Arg);
14007 -- Give a warning if operating in static mode with one of the
14008 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14011 and not Dynamic_Elaboration_Checks
14013 -- pragma Elaborate not allowed in SPARK mode anyway. We
14014 -- already complained about it, no point in generating any
14015 -- further complaint.
14017 and SPARK_Mode /= On
14020 ("?l?use of pragma Elaborate may not be safe", N);
14022 ("?l?use pragma Elaborate_All instead if possible", N);
14026 -------------------
14027 -- Elaborate_All --
14028 -------------------
14030 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14032 when Pragma_Elaborate_All => Elaborate_All : declare
14037 Check_Ada_83_Warning;
14039 -- Pragma must be in context items list of a compilation unit
14041 if not Is_In_Context_Clause then
14045 -- Must be at least one argument
14047 if Arg_Count = 0 then
14048 Error_Pragma ("pragma% requires at least one argument");
14051 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14052 -- have to appear at the end of the context clause, but may
14053 -- appear mixed in with other items, even in Ada 83 mode.
14055 -- Final check: the arguments must all be units mentioned in
14056 -- a with clause in the same context clause. Note that we
14057 -- already checked (in Par.Prag) that all the arguments are
14058 -- either identifiers or selected components.
14061 Outr : while Present (Arg) loop
14062 Citem := First (List_Containing (N));
14063 Innr : while Citem /= N loop
14064 if Nkind (Citem) = N_With_Clause
14065 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14067 Set_Elaborate_All_Present (Citem, True);
14068 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14070 -- Suppress warnings and elaboration checks on the named
14071 -- unit if the pragma is in the current compilation, as
14072 -- for pragma Elaborate.
14074 if In_Extended_Main_Source_Unit (N) then
14075 Set_Suppress_Elaboration_Warnings
14076 (Entity (Name (Citem)));
14085 Set_Error_Posted (N);
14087 ("argument of pragma% is not withed unit", Arg);
14094 --------------------
14095 -- Elaborate_Body --
14096 --------------------
14098 -- pragma Elaborate_Body [( library_unit_NAME )];
14100 when Pragma_Elaborate_Body => Elaborate_Body : declare
14101 Cunit_Node : Node_Id;
14102 Cunit_Ent : Entity_Id;
14105 Check_Ada_83_Warning;
14106 Check_Valid_Library_Unit_Pragma;
14108 if Nkind (N) = N_Null_Statement then
14112 Cunit_Node := Cunit (Current_Sem_Unit);
14113 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14115 -- A pragma that applies to a Ghost entity becomes Ghost for the
14116 -- purposes of legality checks and removal of ignored Ghost code.
14118 Mark_Pragma_As_Ghost (N, Cunit_Ent);
14120 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14123 Error_Pragma ("pragma% must refer to a spec, not a body");
14125 Set_Body_Required (Cunit_Node, True);
14126 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14128 -- If we are in dynamic elaboration mode, then we suppress
14129 -- elaboration warnings for the unit, since it is definitely
14130 -- fine NOT to do dynamic checks at the first level (and such
14131 -- checks will be suppressed because no elaboration boolean
14132 -- is created for Elaborate_Body packages).
14134 -- But in the static model of elaboration, Elaborate_Body is
14135 -- definitely NOT good enough to ensure elaboration safety on
14136 -- its own, since the body may WITH other units that are not
14137 -- safe from an elaboration point of view, so a client must
14138 -- still do an Elaborate_All on such units.
14140 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14141 -- Elaborate_Body always suppressed elab warnings.
14143 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14144 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14147 end Elaborate_Body;
14149 ------------------------
14150 -- Elaboration_Checks --
14151 ------------------------
14153 -- pragma Elaboration_Checks (Static | Dynamic);
14155 when Pragma_Elaboration_Checks =>
14157 Check_Arg_Count (1);
14158 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14160 -- Set flag accordingly (ignore attempt at dynamic elaboration
14161 -- checks in SPARK mode).
14163 Dynamic_Elaboration_Checks :=
14164 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
14165 and then SPARK_Mode /= On;
14171 -- pragma Eliminate (
14172 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14173 -- [,[Entity =>] IDENTIFIER |
14174 -- SELECTED_COMPONENT |
14176 -- [, OVERLOADING_RESOLUTION]);
14178 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14181 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14182 -- FUNCTION_PROFILE
14184 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14186 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14187 -- Result_Type => result_SUBTYPE_NAME]
14189 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14190 -- SUBTYPE_NAME ::= STRING_LITERAL
14192 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14193 -- SOURCE_TRACE ::= STRING_LITERAL
14195 when Pragma_Eliminate => Eliminate : declare
14196 Args : Args_List (1 .. 5);
14197 Names : constant Name_List (1 .. 5) := (
14200 Name_Parameter_Types,
14202 Name_Source_Location);
14204 Unit_Name : Node_Id renames Args (1);
14205 Entity : Node_Id renames Args (2);
14206 Parameter_Types : Node_Id renames Args (3);
14207 Result_Type : Node_Id renames Args (4);
14208 Source_Location : Node_Id renames Args (5);
14212 Check_Valid_Configuration_Pragma;
14213 Gather_Associations (Names, Args);
14215 if No (Unit_Name) then
14216 Error_Pragma ("missing Unit_Name argument for pragma%");
14220 and then (Present (Parameter_Types)
14222 Present (Result_Type)
14224 Present (Source_Location))
14226 Error_Pragma ("missing Entity argument for pragma%");
14229 if (Present (Parameter_Types)
14231 Present (Result_Type))
14233 Present (Source_Location)
14236 ("parameter profile and source location cannot be used "
14237 & "together in pragma%");
14240 Process_Eliminate_Pragma
14249 -----------------------------------
14250 -- Enable_Atomic_Synchronization --
14251 -----------------------------------
14253 -- pragma Enable_Atomic_Synchronization [(Entity)];
14255 when Pragma_Enable_Atomic_Synchronization =>
14257 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14264 -- [ Convention =>] convention_IDENTIFIER,
14265 -- [ Entity =>] LOCAL_NAME
14266 -- [, [External_Name =>] static_string_EXPRESSION ]
14267 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14269 when Pragma_Export => Export : declare
14271 Def_Id : Entity_Id;
14273 pragma Warnings (Off, C);
14276 Check_Ada_83_Warning;
14280 Name_External_Name,
14283 Check_At_Least_N_Arguments (2);
14284 Check_At_Most_N_Arguments (4);
14286 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14287 -- pragma Export (Entity, "external name");
14289 if Relaxed_RM_Semantics
14290 and then Arg_Count = 2
14291 and then Nkind (Expression (Arg2)) = N_String_Literal
14294 Def_Id := Get_Pragma_Arg (Arg1);
14297 if not Is_Entity_Name (Def_Id) then
14298 Error_Pragma_Arg ("entity name required", Arg1);
14301 Def_Id := Entity (Def_Id);
14302 Set_Exported (Def_Id, Arg1);
14305 Process_Convention (C, Def_Id);
14307 -- A pragma that applies to a Ghost entity becomes Ghost for
14308 -- the purposes of legality checks and removal of ignored Ghost
14311 Mark_Pragma_As_Ghost (N, Def_Id);
14313 if Ekind (Def_Id) /= E_Constant then
14314 Note_Possible_Modification
14315 (Get_Pragma_Arg (Arg2), Sure => False);
14318 Process_Interface_Name (Def_Id, Arg3, Arg4);
14319 Set_Exported (Def_Id, Arg2);
14322 -- If the entity is a deferred constant, propagate the information
14323 -- to the full view, because gigi elaborates the full view only.
14325 if Ekind (Def_Id) = E_Constant
14326 and then Present (Full_View (Def_Id))
14329 Id2 : constant Entity_Id := Full_View (Def_Id);
14331 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14332 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14333 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14338 ---------------------
14339 -- Export_Function --
14340 ---------------------
14342 -- pragma Export_Function (
14343 -- [Internal =>] LOCAL_NAME
14344 -- [, [External =>] EXTERNAL_SYMBOL]
14345 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14346 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14347 -- [, [Mechanism =>] MECHANISM]
14348 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14350 -- EXTERNAL_SYMBOL ::=
14352 -- | static_string_EXPRESSION
14354 -- PARAMETER_TYPES ::=
14356 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14358 -- TYPE_DESIGNATOR ::=
14360 -- | subtype_Name ' Access
14364 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14366 -- MECHANISM_ASSOCIATION ::=
14367 -- [formal_parameter_NAME =>] MECHANISM_NAME
14369 -- MECHANISM_NAME ::=
14373 when Pragma_Export_Function => Export_Function : declare
14374 Args : Args_List (1 .. 6);
14375 Names : constant Name_List (1 .. 6) := (
14378 Name_Parameter_Types,
14381 Name_Result_Mechanism);
14383 Internal : Node_Id renames Args (1);
14384 External : Node_Id renames Args (2);
14385 Parameter_Types : Node_Id renames Args (3);
14386 Result_Type : Node_Id renames Args (4);
14387 Mechanism : Node_Id renames Args (5);
14388 Result_Mechanism : Node_Id renames Args (6);
14392 Gather_Associations (Names, Args);
14393 Process_Extended_Import_Export_Subprogram_Pragma (
14394 Arg_Internal => Internal,
14395 Arg_External => External,
14396 Arg_Parameter_Types => Parameter_Types,
14397 Arg_Result_Type => Result_Type,
14398 Arg_Mechanism => Mechanism,
14399 Arg_Result_Mechanism => Result_Mechanism);
14400 end Export_Function;
14402 -------------------
14403 -- Export_Object --
14404 -------------------
14406 -- pragma Export_Object (
14407 -- [Internal =>] LOCAL_NAME
14408 -- [, [External =>] EXTERNAL_SYMBOL]
14409 -- [, [Size =>] EXTERNAL_SYMBOL]);
14411 -- EXTERNAL_SYMBOL ::=
14413 -- | static_string_EXPRESSION
14415 -- PARAMETER_TYPES ::=
14417 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14419 -- TYPE_DESIGNATOR ::=
14421 -- | subtype_Name ' Access
14425 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14427 -- MECHANISM_ASSOCIATION ::=
14428 -- [formal_parameter_NAME =>] MECHANISM_NAME
14430 -- MECHANISM_NAME ::=
14434 when Pragma_Export_Object => Export_Object : declare
14435 Args : Args_List (1 .. 3);
14436 Names : constant Name_List (1 .. 3) := (
14441 Internal : Node_Id renames Args (1);
14442 External : Node_Id renames Args (2);
14443 Size : Node_Id renames Args (3);
14447 Gather_Associations (Names, Args);
14448 Process_Extended_Import_Export_Object_Pragma (
14449 Arg_Internal => Internal,
14450 Arg_External => External,
14454 ----------------------
14455 -- Export_Procedure --
14456 ----------------------
14458 -- pragma Export_Procedure (
14459 -- [Internal =>] LOCAL_NAME
14460 -- [, [External =>] EXTERNAL_SYMBOL]
14461 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14462 -- [, [Mechanism =>] MECHANISM]);
14464 -- EXTERNAL_SYMBOL ::=
14466 -- | static_string_EXPRESSION
14468 -- PARAMETER_TYPES ::=
14470 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14472 -- TYPE_DESIGNATOR ::=
14474 -- | subtype_Name ' Access
14478 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14480 -- MECHANISM_ASSOCIATION ::=
14481 -- [formal_parameter_NAME =>] MECHANISM_NAME
14483 -- MECHANISM_NAME ::=
14487 when Pragma_Export_Procedure => Export_Procedure : declare
14488 Args : Args_List (1 .. 4);
14489 Names : constant Name_List (1 .. 4) := (
14492 Name_Parameter_Types,
14495 Internal : Node_Id renames Args (1);
14496 External : Node_Id renames Args (2);
14497 Parameter_Types : Node_Id renames Args (3);
14498 Mechanism : Node_Id renames Args (4);
14502 Gather_Associations (Names, Args);
14503 Process_Extended_Import_Export_Subprogram_Pragma (
14504 Arg_Internal => Internal,
14505 Arg_External => External,
14506 Arg_Parameter_Types => Parameter_Types,
14507 Arg_Mechanism => Mechanism);
14508 end Export_Procedure;
14514 -- pragma Export_Value (
14515 -- [Value =>] static_integer_EXPRESSION,
14516 -- [Link_Name =>] static_string_EXPRESSION);
14518 when Pragma_Export_Value =>
14520 Check_Arg_Order ((Name_Value, Name_Link_Name));
14521 Check_Arg_Count (2);
14523 Check_Optional_Identifier (Arg1, Name_Value);
14524 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14526 Check_Optional_Identifier (Arg2, Name_Link_Name);
14527 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14529 -----------------------------
14530 -- Export_Valued_Procedure --
14531 -----------------------------
14533 -- pragma Export_Valued_Procedure (
14534 -- [Internal =>] LOCAL_NAME
14535 -- [, [External =>] EXTERNAL_SYMBOL,]
14536 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14537 -- [, [Mechanism =>] MECHANISM]);
14539 -- EXTERNAL_SYMBOL ::=
14541 -- | static_string_EXPRESSION
14543 -- PARAMETER_TYPES ::=
14545 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14547 -- TYPE_DESIGNATOR ::=
14549 -- | subtype_Name ' Access
14553 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14555 -- MECHANISM_ASSOCIATION ::=
14556 -- [formal_parameter_NAME =>] MECHANISM_NAME
14558 -- MECHANISM_NAME ::=
14562 when Pragma_Export_Valued_Procedure =>
14563 Export_Valued_Procedure : declare
14564 Args : Args_List (1 .. 4);
14565 Names : constant Name_List (1 .. 4) := (
14568 Name_Parameter_Types,
14571 Internal : Node_Id renames Args (1);
14572 External : Node_Id renames Args (2);
14573 Parameter_Types : Node_Id renames Args (3);
14574 Mechanism : Node_Id renames Args (4);
14578 Gather_Associations (Names, Args);
14579 Process_Extended_Import_Export_Subprogram_Pragma (
14580 Arg_Internal => Internal,
14581 Arg_External => External,
14582 Arg_Parameter_Types => Parameter_Types,
14583 Arg_Mechanism => Mechanism);
14584 end Export_Valued_Procedure;
14586 -------------------
14587 -- Extend_System --
14588 -------------------
14590 -- pragma Extend_System ([Name =>] Identifier);
14592 when Pragma_Extend_System => Extend_System : declare
14595 Check_Valid_Configuration_Pragma;
14596 Check_Arg_Count (1);
14597 Check_Optional_Identifier (Arg1, Name_Name);
14598 Check_Arg_Is_Identifier (Arg1);
14600 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14603 and then Name_Buffer (1 .. 4) = "aux_"
14605 if Present (System_Extend_Pragma_Arg) then
14606 if Chars (Get_Pragma_Arg (Arg1)) =
14607 Chars (Expression (System_Extend_Pragma_Arg))
14611 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14612 Error_Pragma ("pragma% conflicts with that #");
14616 System_Extend_Pragma_Arg := Arg1;
14618 if not GNAT_Mode then
14619 System_Extend_Unit := Arg1;
14623 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14627 ------------------------
14628 -- Extensions_Allowed --
14629 ------------------------
14631 -- pragma Extensions_Allowed (ON | OFF);
14633 when Pragma_Extensions_Allowed =>
14635 Check_Arg_Count (1);
14636 Check_No_Identifiers;
14637 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14639 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14640 Extensions_Allowed := True;
14641 Ada_Version := Ada_Version_Type'Last;
14644 Extensions_Allowed := False;
14645 Ada_Version := Ada_Version_Explicit;
14646 Ada_Version_Pragma := Empty;
14649 ------------------------
14650 -- Extensions_Visible --
14651 ------------------------
14653 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14655 -- Characteristics:
14657 -- * Analysis - The annotation is fully analyzed immediately upon
14658 -- elaboration as its expression must be static.
14660 -- * Expansion - None.
14662 -- * Template - The annotation utilizes the generic template of the
14663 -- related subprogram [body] when it is:
14665 -- aspect on subprogram declaration
14666 -- aspect on stand alone subprogram body
14667 -- pragma on stand alone subprogram body
14669 -- The annotation must prepare its own template when it is:
14671 -- pragma on subprogram declaration
14673 -- * Globals - Capture of global references must occur after full
14676 -- * Instance - The annotation is instantiated automatically when
14677 -- the related generic subprogram [body] is instantiated except for
14678 -- the "pragma on subprogram declaration" case. In that scenario
14679 -- the annotation must instantiate itself.
14681 when Pragma_Extensions_Visible => Extensions_Visible : declare
14682 Formal : Entity_Id;
14683 Has_OK_Formal : Boolean := False;
14684 Spec_Id : Entity_Id;
14685 Subp_Decl : Node_Id;
14689 Check_No_Identifiers;
14690 Check_At_Most_N_Arguments (1);
14693 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14695 -- Abstract subprogram declaration
14697 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
14700 -- Generic subprogram declaration
14702 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14705 -- Body acts as spec
14707 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14708 and then No (Corresponding_Spec (Subp_Decl))
14712 -- Body stub acts as spec
14714 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14715 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14719 -- Subprogram declaration
14721 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14724 -- Otherwise the pragma is associated with an illegal construct
14727 Error_Pragma ("pragma % must apply to a subprogram");
14731 -- Chain the pragma on the contract for completeness
14733 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14735 -- The legality checks of pragma Extension_Visible are affected
14736 -- by the SPARK mode in effect. Analyze all pragmas in specific
14739 Analyze_If_Present (Pragma_SPARK_Mode);
14741 -- Mark the pragma as Ghost if the related subprogram is also
14742 -- Ghost. This also ensures that any expansion performed further
14743 -- below will produce Ghost nodes.
14745 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14746 Mark_Pragma_As_Ghost (N, Spec_Id);
14748 -- Examine the formals of the related subprogram
14750 Formal := First_Formal (Spec_Id);
14751 while Present (Formal) loop
14753 -- At least one of the formals is of a specific tagged type,
14754 -- the pragma is legal.
14756 if Is_Specific_Tagged_Type (Etype (Formal)) then
14757 Has_OK_Formal := True;
14760 -- A generic subprogram with at least one formal of a private
14761 -- type ensures the legality of the pragma because the actual
14762 -- may be specifically tagged. Note that this is verified by
14763 -- the check above at instantiation time.
14765 elsif Is_Private_Type (Etype (Formal))
14766 and then Is_Generic_Type (Etype (Formal))
14768 Has_OK_Formal := True;
14772 Next_Formal (Formal);
14775 if not Has_OK_Formal then
14776 Error_Msg_Name_1 := Pname;
14777 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
14779 ("\subprogram & lacks parameter of specific tagged or "
14780 & "generic private type", N, Spec_Id);
14785 -- Analyze the Boolean expression (if any)
14787 if Present (Arg1) then
14788 Check_Static_Boolean_Expression
14789 (Expression (Get_Argument (N, Spec_Id)));
14791 end Extensions_Visible;
14797 -- pragma External (
14798 -- [ Convention =>] convention_IDENTIFIER,
14799 -- [ Entity =>] LOCAL_NAME
14800 -- [, [External_Name =>] static_string_EXPRESSION ]
14801 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14803 when Pragma_External => External : declare
14806 pragma Warnings (Off, C);
14813 Name_External_Name,
14815 Check_At_Least_N_Arguments (2);
14816 Check_At_Most_N_Arguments (4);
14817 Process_Convention (C, E);
14819 -- A pragma that applies to a Ghost entity becomes Ghost for the
14820 -- purposes of legality checks and removal of ignored Ghost code.
14822 Mark_Pragma_As_Ghost (N, E);
14824 Note_Possible_Modification
14825 (Get_Pragma_Arg (Arg2), Sure => False);
14826 Process_Interface_Name (E, Arg3, Arg4);
14827 Set_Exported (E, Arg2);
14830 --------------------------
14831 -- External_Name_Casing --
14832 --------------------------
14834 -- pragma External_Name_Casing (
14835 -- UPPERCASE | LOWERCASE
14836 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14838 when Pragma_External_Name_Casing => External_Name_Casing : declare
14841 Check_No_Identifiers;
14843 if Arg_Count = 2 then
14844 Check_Arg_Is_One_Of
14845 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14847 case Chars (Get_Pragma_Arg (Arg2)) is
14849 Opt.External_Name_Exp_Casing := As_Is;
14851 when Name_Uppercase =>
14852 Opt.External_Name_Exp_Casing := Uppercase;
14854 when Name_Lowercase =>
14855 Opt.External_Name_Exp_Casing := Lowercase;
14862 Check_Arg_Count (1);
14865 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14867 case Chars (Get_Pragma_Arg (Arg1)) is
14868 when Name_Uppercase =>
14869 Opt.External_Name_Imp_Casing := Uppercase;
14871 when Name_Lowercase =>
14872 Opt.External_Name_Imp_Casing := Lowercase;
14877 end External_Name_Casing;
14883 -- pragma Fast_Math;
14885 when Pragma_Fast_Math =>
14887 Check_No_Identifiers;
14888 Check_Valid_Configuration_Pragma;
14891 --------------------------
14892 -- Favor_Top_Level --
14893 --------------------------
14895 -- pragma Favor_Top_Level (type_NAME);
14897 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14902 Check_No_Identifiers;
14903 Check_Arg_Count (1);
14904 Check_Arg_Is_Local_Name (Arg1);
14905 Typ := Entity (Get_Pragma_Arg (Arg1));
14907 -- A pragma that applies to a Ghost entity becomes Ghost for the
14908 -- purposes of legality checks and removal of ignored Ghost code.
14910 Mark_Pragma_As_Ghost (N, Typ);
14912 -- If it's an access-to-subprogram type (in particular, not a
14913 -- subtype), set the flag on that type.
14915 if Is_Access_Subprogram_Type (Typ) then
14916 Set_Can_Use_Internal_Rep (Typ, False);
14918 -- Otherwise it's an error (name denotes the wrong sort of entity)
14922 ("access-to-subprogram type expected",
14923 Get_Pragma_Arg (Arg1));
14925 end Favor_Top_Level;
14927 ---------------------------
14928 -- Finalize_Storage_Only --
14929 ---------------------------
14931 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14933 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14934 Assoc : constant Node_Id := Arg1;
14935 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14940 Check_No_Identifiers;
14941 Check_Arg_Count (1);
14942 Check_Arg_Is_Local_Name (Arg1);
14944 Find_Type (Type_Id);
14945 Typ := Entity (Type_Id);
14948 or else Rep_Item_Too_Early (Typ, N)
14952 Typ := Underlying_Type (Typ);
14955 if not Is_Controlled (Typ) then
14956 Error_Pragma ("pragma% must specify controlled type");
14959 Check_First_Subtype (Arg1);
14961 if Finalize_Storage_Only (Typ) then
14962 Error_Pragma ("duplicate pragma%, only one allowed");
14964 elsif not Rep_Item_Too_Late (Typ, N) then
14965 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14967 end Finalize_Storage;
14973 -- pragma Ghost [ (boolean_EXPRESSION) ];
14975 when Pragma_Ghost => Ghost : declare
14979 Orig_Stmt : Node_Id;
14980 Prev_Id : Entity_Id;
14985 Check_No_Identifiers;
14986 Check_At_Most_N_Arguments (1);
14990 while Present (Stmt) loop
14992 -- Skip prior pragmas, but check for duplicates
14994 if Nkind (Stmt) = N_Pragma then
14995 if Pragma_Name (Stmt) = Pname then
14996 Error_Msg_Name_1 := Pname;
14997 Error_Msg_Sloc := Sloc (Stmt);
14998 Error_Msg_N ("pragma % duplicates pragma declared#", N);
15001 -- Task unit declared without a definition cannot be subject to
15002 -- pragma Ghost (SPARK RM 6.9(19)).
15004 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15005 N_Task_Type_Declaration)
15007 Error_Pragma ("pragma % cannot apply to a task type");
15010 -- Skip internally generated code
15012 elsif not Comes_From_Source (Stmt) then
15013 Orig_Stmt := Original_Node (Stmt);
15015 -- When pragma Ghost applies to an untagged derivation, the
15016 -- derivation is transformed into a [sub]type declaration.
15018 if Nkind_In (Stmt, N_Full_Type_Declaration,
15019 N_Subtype_Declaration)
15020 and then Comes_From_Source (Orig_Stmt)
15021 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15022 and then Nkind (Type_Definition (Orig_Stmt)) =
15023 N_Derived_Type_Definition
15025 Id := Defining_Entity (Stmt);
15028 -- When pragma Ghost applies to an object declaration which
15029 -- is initialized by means of a function call that returns
15030 -- on the secondary stack, the object declaration becomes a
15033 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15034 and then Comes_From_Source (Orig_Stmt)
15035 and then Nkind (Orig_Stmt) = N_Object_Declaration
15037 Id := Defining_Entity (Stmt);
15040 -- When pragma Ghost applies to an expression function, the
15041 -- expression function is transformed into a subprogram.
15043 elsif Nkind (Stmt) = N_Subprogram_Declaration
15044 and then Comes_From_Source (Orig_Stmt)
15045 and then Nkind (Orig_Stmt) = N_Expression_Function
15047 Id := Defining_Entity (Stmt);
15051 -- The pragma applies to a legal construct, stop the traversal
15053 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15054 N_Full_Type_Declaration,
15055 N_Generic_Subprogram_Declaration,
15056 N_Object_Declaration,
15057 N_Private_Extension_Declaration,
15058 N_Private_Type_Declaration,
15059 N_Subprogram_Declaration,
15060 N_Subtype_Declaration)
15062 Id := Defining_Entity (Stmt);
15065 -- The pragma does not apply to a legal construct, issue an
15066 -- error and stop the analysis.
15070 ("pragma % must apply to an object, package, subprogram "
15075 Stmt := Prev (Stmt);
15078 Context := Parent (N);
15080 -- Handle compilation units
15082 if Nkind (Context) = N_Compilation_Unit_Aux then
15083 Context := Unit (Parent (Context));
15086 -- Protected and task types cannot be subject to pragma Ghost
15087 -- (SPARK RM 6.9(19)).
15089 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15091 Error_Pragma ("pragma % cannot apply to a protected type");
15094 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15095 Error_Pragma ("pragma % cannot apply to a task type");
15101 -- When pragma Ghost is associated with a [generic] package, it
15102 -- appears in the visible declarations.
15104 if Nkind (Context) = N_Package_Specification
15105 and then Present (Visible_Declarations (Context))
15106 and then List_Containing (N) = Visible_Declarations (Context)
15108 Id := Defining_Entity (Context);
15110 -- Pragma Ghost applies to a stand alone subprogram body
15112 elsif Nkind (Context) = N_Subprogram_Body
15113 and then No (Corresponding_Spec (Context))
15115 Id := Defining_Entity (Context);
15117 -- Pragma Ghost applies to a subprogram declaration that acts
15118 -- as a compilation unit.
15120 elsif Nkind (Context) = N_Subprogram_Declaration then
15121 Id := Defining_Entity (Context);
15127 ("pragma % must apply to an object, package, subprogram or "
15132 -- Handle completions of types and constants that are subject to
15135 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15136 Prev_Id := Incomplete_Or_Partial_View (Id);
15138 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15139 Error_Msg_Name_1 := Pname;
15141 -- The full declaration of a deferred constant cannot be
15142 -- subject to pragma Ghost unless the deferred declaration
15143 -- is also Ghost (SPARK RM 6.9(9)).
15145 if Ekind (Prev_Id) = E_Constant then
15146 Error_Msg_Name_1 := Pname;
15147 Error_Msg_NE (Fix_Error
15148 ("pragma % must apply to declaration of deferred "
15149 & "constant &"), N, Id);
15152 -- Pragma Ghost may appear on the full view of an incomplete
15153 -- type because the incomplete declaration lacks aspects and
15154 -- cannot be subject to pragma Ghost.
15156 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15159 -- The full declaration of a type cannot be subject to
15160 -- pragma Ghost unless the partial view is also Ghost
15161 -- (SPARK RM 6.9(9)).
15164 Error_Msg_NE (Fix_Error
15165 ("pragma % must apply to partial view of type &"),
15171 -- A synchronized object cannot be subject to pragma Ghost
15172 -- (SPARK RM 6.9(19)).
15174 elsif Ekind (Id) = E_Variable then
15175 if Is_Protected_Type (Etype (Id)) then
15176 Error_Pragma ("pragma % cannot apply to a protected object");
15179 elsif Is_Task_Type (Etype (Id)) then
15180 Error_Pragma ("pragma % cannot apply to a task object");
15185 -- Analyze the Boolean expression (if any)
15187 if Present (Arg1) then
15188 Expr := Get_Pragma_Arg (Arg1);
15190 Analyze_And_Resolve (Expr, Standard_Boolean);
15192 if Is_OK_Static_Expression (Expr) then
15194 -- "Ghostness" cannot be turned off once enabled within a
15195 -- region (SPARK RM 6.9(6)).
15197 if Is_False (Expr_Value (Expr))
15198 and then Ghost_Mode > None
15201 ("pragma % with value False cannot appear in enabled "
15206 -- Otherwie the expression is not static
15210 ("expression of pragma % must be static", Expr);
15215 Set_Is_Ghost_Entity (Id);
15222 -- pragma Global (GLOBAL_SPECIFICATION);
15224 -- GLOBAL_SPECIFICATION ::=
15227 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15229 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15231 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15232 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15233 -- GLOBAL_ITEM ::= NAME
15235 -- Characteristics:
15237 -- * Analysis - The annotation undergoes initial checks to verify
15238 -- the legal placement and context. Secondary checks fully analyze
15239 -- the dependency clauses in:
15241 -- Analyze_Global_In_Decl_Part
15243 -- * Expansion - None.
15245 -- * Template - The annotation utilizes the generic template of the
15246 -- related subprogram [body] when it is:
15248 -- aspect on subprogram declaration
15249 -- aspect on stand alone subprogram body
15250 -- pragma on stand alone subprogram body
15252 -- The annotation must prepare its own template when it is:
15254 -- pragma on subprogram declaration
15256 -- * Globals - Capture of global references must occur after full
15259 -- * Instance - The annotation is instantiated automatically when
15260 -- the related generic subprogram [body] is instantiated except for
15261 -- the "pragma on subprogram declaration" case. In that scenario
15262 -- the annotation must instantiate itself.
15264 when Pragma_Global => Global : declare
15266 Spec_Id : Entity_Id;
15267 Subp_Decl : Node_Id;
15270 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15274 -- Chain the pragma on the contract for further processing by
15275 -- Analyze_Global_In_Decl_Part.
15277 Add_Contract_Item (N, Spec_Id);
15279 -- Fully analyze the pragma when it appears inside an entry
15280 -- or subprogram body because it cannot benefit from forward
15283 if Nkind_In (Subp_Decl, N_Entry_Body,
15285 N_Subprogram_Body_Stub)
15287 -- The legality checks of pragmas Depends and Global are
15288 -- affected by the SPARK mode in effect and the volatility
15289 -- of the context. In addition these two pragmas are subject
15290 -- to an inherent order:
15295 -- Analyze all these pragmas in the order outlined above
15297 Analyze_If_Present (Pragma_SPARK_Mode);
15298 Analyze_If_Present (Pragma_Volatile_Function);
15299 Analyze_Global_In_Decl_Part (N);
15300 Analyze_If_Present (Pragma_Depends);
15309 -- pragma Ident (static_string_EXPRESSION)
15311 -- Note: pragma Comment shares this processing. Pragma Ident is
15312 -- identical in effect to pragma Commment.
15314 when Pragma_Ident | Pragma_Comment => Ident : declare
15319 Check_Arg_Count (1);
15320 Check_No_Identifiers;
15321 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15324 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15331 GP := Parent (Parent (N));
15333 if Nkind_In (GP, N_Package_Declaration,
15334 N_Generic_Package_Declaration)
15339 -- If we have a compilation unit, then record the ident value,
15340 -- checking for improper duplication.
15342 if Nkind (GP) = N_Compilation_Unit then
15343 CS := Ident_String (Current_Sem_Unit);
15345 if Present (CS) then
15347 -- If we have multiple instances, concatenate them, but
15348 -- not in ASIS, where we want the original tree.
15350 if not ASIS_Mode then
15351 Start_String (Strval (CS));
15352 Store_String_Char (' ');
15353 Store_String_Chars (Strval (Str));
15354 Set_Strval (CS, End_String);
15358 Set_Ident_String (Current_Sem_Unit, Str);
15361 -- For subunits, we just ignore the Ident, since in GNAT these
15362 -- are not separate object files, and hence not separate units
15363 -- in the unit table.
15365 elsif Nkind (GP) = N_Subunit then
15371 -------------------
15372 -- Ignore_Pragma --
15373 -------------------
15375 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15377 -- Entirely handled in the parser, nothing to do here
15379 when Pragma_Ignore_Pragma =>
15382 ----------------------------
15383 -- Implementation_Defined --
15384 ----------------------------
15386 -- pragma Implementation_Defined (LOCAL_NAME);
15388 -- Marks previously declared entity as implementation defined. For
15389 -- an overloaded entity, applies to the most recent homonym.
15391 -- pragma Implementation_Defined;
15393 -- The form with no arguments appears anywhere within a scope, most
15394 -- typically a package spec, and indicates that all entities that are
15395 -- defined within the package spec are Implementation_Defined.
15397 when Pragma_Implementation_Defined => Implementation_Defined : declare
15402 Check_No_Identifiers;
15404 -- Form with no arguments
15406 if Arg_Count = 0 then
15407 Set_Is_Implementation_Defined (Current_Scope);
15409 -- Form with one argument
15412 Check_Arg_Count (1);
15413 Check_Arg_Is_Local_Name (Arg1);
15414 Ent := Entity (Get_Pragma_Arg (Arg1));
15415 Set_Is_Implementation_Defined (Ent);
15417 end Implementation_Defined;
15423 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15425 -- IMPLEMENTATION_KIND ::=
15426 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15428 -- "By_Any" and "Optional" are treated as synonyms in order to
15429 -- support Ada 2012 aspect Synchronization.
15431 when Pragma_Implemented => Implemented : declare
15432 Proc_Id : Entity_Id;
15437 Check_Arg_Count (2);
15438 Check_No_Identifiers;
15439 Check_Arg_Is_Identifier (Arg1);
15440 Check_Arg_Is_Local_Name (Arg1);
15441 Check_Arg_Is_One_Of (Arg2,
15444 Name_By_Protected_Procedure,
15447 -- Extract the name of the local procedure
15449 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15451 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15452 -- primitive procedure of a synchronized tagged type.
15454 if Ekind (Proc_Id) = E_Procedure
15455 and then Is_Primitive (Proc_Id)
15456 and then Present (First_Formal (Proc_Id))
15458 Typ := Etype (First_Formal (Proc_Id));
15460 if Is_Tagged_Type (Typ)
15463 -- Check for a protected, a synchronized or a task interface
15465 ((Is_Interface (Typ)
15466 and then Is_Synchronized_Interface (Typ))
15468 -- Check for a protected type or a task type that implements
15472 (Is_Concurrent_Record_Type (Typ)
15473 and then Present (Interfaces (Typ)))
15475 -- In analysis-only mode, examine original protected type
15478 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15479 and then Present (Interface_List (Parent (Typ))))
15481 -- Check for a private record extension with keyword
15485 (Ekind_In (Typ, E_Record_Type_With_Private,
15486 E_Record_Subtype_With_Private)
15487 and then Synchronized_Present (Parent (Typ))))
15492 ("controlling formal must be of synchronized tagged type",
15497 -- Procedures declared inside a protected type must be accepted
15499 elsif Ekind (Proc_Id) = E_Procedure
15500 and then Is_Protected_Type (Scope (Proc_Id))
15504 -- The first argument is not a primitive procedure
15508 ("pragma % must be applied to a primitive procedure", Arg1);
15512 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15513 -- By_Protected_Procedure to the primitive procedure of a task
15516 if Chars (Arg2) = Name_By_Protected_Procedure
15517 and then Is_Interface (Typ)
15518 and then Is_Task_Interface (Typ)
15521 ("implementation kind By_Protected_Procedure cannot be "
15522 & "applied to a task interface primitive", Arg2);
15526 Record_Rep_Item (Proc_Id, N);
15529 ----------------------
15530 -- Implicit_Packing --
15531 ----------------------
15533 -- pragma Implicit_Packing;
15535 when Pragma_Implicit_Packing =>
15537 Check_Arg_Count (0);
15538 Implicit_Packing := True;
15545 -- [Convention =>] convention_IDENTIFIER,
15546 -- [Entity =>] LOCAL_NAME
15547 -- [, [External_Name =>] static_string_EXPRESSION ]
15548 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15550 when Pragma_Import =>
15551 Check_Ada_83_Warning;
15555 Name_External_Name,
15558 Check_At_Least_N_Arguments (2);
15559 Check_At_Most_N_Arguments (4);
15560 Process_Import_Or_Interface;
15562 ---------------------
15563 -- Import_Function --
15564 ---------------------
15566 -- pragma Import_Function (
15567 -- [Internal =>] LOCAL_NAME,
15568 -- [, [External =>] EXTERNAL_SYMBOL]
15569 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15570 -- [, [Result_Type =>] SUBTYPE_MARK]
15571 -- [, [Mechanism =>] MECHANISM]
15572 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15574 -- EXTERNAL_SYMBOL ::=
15576 -- | static_string_EXPRESSION
15578 -- PARAMETER_TYPES ::=
15580 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15582 -- TYPE_DESIGNATOR ::=
15584 -- | subtype_Name ' Access
15588 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15590 -- MECHANISM_ASSOCIATION ::=
15591 -- [formal_parameter_NAME =>] MECHANISM_NAME
15593 -- MECHANISM_NAME ::=
15597 when Pragma_Import_Function => Import_Function : declare
15598 Args : Args_List (1 .. 6);
15599 Names : constant Name_List (1 .. 6) := (
15602 Name_Parameter_Types,
15605 Name_Result_Mechanism);
15607 Internal : Node_Id renames Args (1);
15608 External : Node_Id renames Args (2);
15609 Parameter_Types : Node_Id renames Args (3);
15610 Result_Type : Node_Id renames Args (4);
15611 Mechanism : Node_Id renames Args (5);
15612 Result_Mechanism : Node_Id renames Args (6);
15616 Gather_Associations (Names, Args);
15617 Process_Extended_Import_Export_Subprogram_Pragma (
15618 Arg_Internal => Internal,
15619 Arg_External => External,
15620 Arg_Parameter_Types => Parameter_Types,
15621 Arg_Result_Type => Result_Type,
15622 Arg_Mechanism => Mechanism,
15623 Arg_Result_Mechanism => Result_Mechanism);
15624 end Import_Function;
15626 -------------------
15627 -- Import_Object --
15628 -------------------
15630 -- pragma Import_Object (
15631 -- [Internal =>] LOCAL_NAME
15632 -- [, [External =>] EXTERNAL_SYMBOL]
15633 -- [, [Size =>] EXTERNAL_SYMBOL]);
15635 -- EXTERNAL_SYMBOL ::=
15637 -- | static_string_EXPRESSION
15639 when Pragma_Import_Object => Import_Object : declare
15640 Args : Args_List (1 .. 3);
15641 Names : constant Name_List (1 .. 3) := (
15646 Internal : Node_Id renames Args (1);
15647 External : Node_Id renames Args (2);
15648 Size : Node_Id renames Args (3);
15652 Gather_Associations (Names, Args);
15653 Process_Extended_Import_Export_Object_Pragma (
15654 Arg_Internal => Internal,
15655 Arg_External => External,
15659 ----------------------
15660 -- Import_Procedure --
15661 ----------------------
15663 -- pragma Import_Procedure (
15664 -- [Internal =>] LOCAL_NAME
15665 -- [, [External =>] EXTERNAL_SYMBOL]
15666 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15667 -- [, [Mechanism =>] MECHANISM]);
15669 -- EXTERNAL_SYMBOL ::=
15671 -- | static_string_EXPRESSION
15673 -- PARAMETER_TYPES ::=
15675 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15677 -- TYPE_DESIGNATOR ::=
15679 -- | subtype_Name ' Access
15683 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15685 -- MECHANISM_ASSOCIATION ::=
15686 -- [formal_parameter_NAME =>] MECHANISM_NAME
15688 -- MECHANISM_NAME ::=
15692 when Pragma_Import_Procedure => Import_Procedure : declare
15693 Args : Args_List (1 .. 4);
15694 Names : constant Name_List (1 .. 4) := (
15697 Name_Parameter_Types,
15700 Internal : Node_Id renames Args (1);
15701 External : Node_Id renames Args (2);
15702 Parameter_Types : Node_Id renames Args (3);
15703 Mechanism : Node_Id renames Args (4);
15707 Gather_Associations (Names, Args);
15708 Process_Extended_Import_Export_Subprogram_Pragma (
15709 Arg_Internal => Internal,
15710 Arg_External => External,
15711 Arg_Parameter_Types => Parameter_Types,
15712 Arg_Mechanism => Mechanism);
15713 end Import_Procedure;
15715 -----------------------------
15716 -- Import_Valued_Procedure --
15717 -----------------------------
15719 -- pragma Import_Valued_Procedure (
15720 -- [Internal =>] LOCAL_NAME
15721 -- [, [External =>] EXTERNAL_SYMBOL]
15722 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15723 -- [, [Mechanism =>] MECHANISM]);
15725 -- EXTERNAL_SYMBOL ::=
15727 -- | static_string_EXPRESSION
15729 -- PARAMETER_TYPES ::=
15731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15733 -- TYPE_DESIGNATOR ::=
15735 -- | subtype_Name ' Access
15739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15741 -- MECHANISM_ASSOCIATION ::=
15742 -- [formal_parameter_NAME =>] MECHANISM_NAME
15744 -- MECHANISM_NAME ::=
15748 when Pragma_Import_Valued_Procedure =>
15749 Import_Valued_Procedure : declare
15750 Args : Args_List (1 .. 4);
15751 Names : constant Name_List (1 .. 4) := (
15754 Name_Parameter_Types,
15757 Internal : Node_Id renames Args (1);
15758 External : Node_Id renames Args (2);
15759 Parameter_Types : Node_Id renames Args (3);
15760 Mechanism : Node_Id renames Args (4);
15764 Gather_Associations (Names, Args);
15765 Process_Extended_Import_Export_Subprogram_Pragma (
15766 Arg_Internal => Internal,
15767 Arg_External => External,
15768 Arg_Parameter_Types => Parameter_Types,
15769 Arg_Mechanism => Mechanism);
15770 end Import_Valued_Procedure;
15776 -- pragma Independent (LOCAL_NAME);
15778 when Pragma_Independent =>
15779 Process_Atomic_Independent_Shared_Volatile;
15781 ----------------------------
15782 -- Independent_Components --
15783 ----------------------------
15785 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15787 when Pragma_Independent_Components => Independent_Components : declare
15795 Check_Ada_83_Warning;
15797 Check_No_Identifiers;
15798 Check_Arg_Count (1);
15799 Check_Arg_Is_Local_Name (Arg1);
15800 E_Id := Get_Pragma_Arg (Arg1);
15802 if Etype (E_Id) = Any_Type then
15806 E := Entity (E_Id);
15808 -- A pragma that applies to a Ghost entity becomes Ghost for the
15809 -- purposes of legality checks and removal of ignored Ghost code.
15811 Mark_Pragma_As_Ghost (N, E);
15813 -- Check duplicate before we chain ourselves
15815 Check_Duplicate_Pragma (E);
15817 -- Check appropriate entity
15819 if Rep_Item_Too_Early (E, N)
15821 Rep_Item_Too_Late (E, N)
15826 D := Declaration_Node (E);
15829 -- The flag is set on the base type, or on the object
15831 if K = N_Full_Type_Declaration
15832 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15834 Set_Has_Independent_Components (Base_Type (E));
15835 Record_Independence_Check (N, Base_Type (E));
15837 -- For record type, set all components independent
15839 if Is_Record_Type (E) then
15840 C := First_Component (E);
15841 while Present (C) loop
15842 Set_Is_Independent (C);
15843 Next_Component (C);
15847 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15848 and then Nkind (D) = N_Object_Declaration
15849 and then Nkind (Object_Definition (D)) =
15850 N_Constrained_Array_Definition
15852 Set_Has_Independent_Components (E);
15853 Record_Independence_Check (N, E);
15856 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15858 end Independent_Components;
15860 -----------------------
15861 -- Initial_Condition --
15862 -----------------------
15864 -- pragma Initial_Condition (boolean_EXPRESSION);
15866 -- Characteristics:
15868 -- * Analysis - The annotation undergoes initial checks to verify
15869 -- the legal placement and context. Secondary checks preanalyze the
15872 -- Analyze_Initial_Condition_In_Decl_Part
15874 -- * Expansion - The annotation is expanded during the expansion of
15875 -- the package body whose declaration is subject to the annotation
15878 -- Expand_Pragma_Initial_Condition
15880 -- * Template - The annotation utilizes the generic template of the
15881 -- related package declaration.
15883 -- * Globals - Capture of global references must occur after full
15886 -- * Instance - The annotation is instantiated automatically when
15887 -- the related generic package is instantiated.
15889 when Pragma_Initial_Condition => Initial_Condition : declare
15890 Pack_Decl : Node_Id;
15891 Pack_Id : Entity_Id;
15895 Check_No_Identifiers;
15896 Check_Arg_Count (1);
15898 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15900 -- Ensure the proper placement of the pragma. Initial_Condition
15901 -- must be associated with a package declaration.
15903 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15904 N_Package_Declaration)
15908 -- Otherwise the pragma is associated with an illegal context
15915 Pack_Id := Defining_Entity (Pack_Decl);
15917 -- Chain the pragma on the contract for further processing by
15918 -- Analyze_Initial_Condition_In_Decl_Part.
15920 Add_Contract_Item (N, Pack_Id);
15922 -- The legality checks of pragmas Abstract_State, Initializes, and
15923 -- Initial_Condition are affected by the SPARK mode in effect. In
15924 -- addition, these three pragmas are subject to an inherent order:
15926 -- 1) Abstract_State
15928 -- 3) Initial_Condition
15930 -- Analyze all these pragmas in the order outlined above
15932 Analyze_If_Present (Pragma_SPARK_Mode);
15933 Analyze_If_Present (Pragma_Abstract_State);
15934 Analyze_If_Present (Pragma_Initializes);
15936 -- A pragma that applies to a Ghost entity becomes Ghost for the
15937 -- purposes of legality checks and removal of ignored Ghost code.
15939 Mark_Pragma_As_Ghost (N, Pack_Id);
15940 end Initial_Condition;
15942 ------------------------
15943 -- Initialize_Scalars --
15944 ------------------------
15946 -- pragma Initialize_Scalars;
15948 when Pragma_Initialize_Scalars =>
15950 Check_Arg_Count (0);
15951 Check_Valid_Configuration_Pragma;
15952 Check_Restriction (No_Initialize_Scalars, N);
15954 -- Initialize_Scalars creates false positives in CodePeer, and
15955 -- incorrect negative results in GNATprove mode, so ignore this
15956 -- pragma in these modes.
15958 if not Restriction_Active (No_Initialize_Scalars)
15959 and then not (CodePeer_Mode or GNATprove_Mode)
15961 Init_Or_Norm_Scalars := True;
15962 Initialize_Scalars := True;
15969 -- pragma Initializes (INITIALIZATION_LIST);
15971 -- INITIALIZATION_LIST ::=
15973 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15975 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15980 -- | (INPUT {, INPUT})
15984 -- Characteristics:
15986 -- * Analysis - The annotation undergoes initial checks to verify
15987 -- the legal placement and context. Secondary checks preanalyze the
15990 -- Analyze_Initializes_In_Decl_Part
15992 -- * Expansion - None.
15994 -- * Template - The annotation utilizes the generic template of the
15995 -- related package declaration.
15997 -- * Globals - Capture of global references must occur after full
16000 -- * Instance - The annotation is instantiated automatically when
16001 -- the related generic package is instantiated.
16003 when Pragma_Initializes => Initializes : declare
16004 Pack_Decl : Node_Id;
16005 Pack_Id : Entity_Id;
16009 Check_No_Identifiers;
16010 Check_Arg_Count (1);
16012 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16014 -- Ensure the proper placement of the pragma. Initializes must be
16015 -- associated with a package declaration.
16017 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16018 N_Package_Declaration)
16022 -- Otherwise the pragma is associated with an illegal construc
16029 Pack_Id := Defining_Entity (Pack_Decl);
16031 -- Chain the pragma on the contract for further processing by
16032 -- Analyze_Initializes_In_Decl_Part.
16034 Add_Contract_Item (N, Pack_Id);
16036 -- The legality checks of pragmas Abstract_State, Initializes, and
16037 -- Initial_Condition are affected by the SPARK mode in effect. In
16038 -- addition, these three pragmas are subject to an inherent order:
16040 -- 1) Abstract_State
16042 -- 3) Initial_Condition
16044 -- Analyze all these pragmas in the order outlined above
16046 Analyze_If_Present (Pragma_SPARK_Mode);
16047 Analyze_If_Present (Pragma_Abstract_State);
16049 -- A pragma that applies to a Ghost entity becomes Ghost for the
16050 -- purposes of legality checks and removal of ignored Ghost code.
16052 Mark_Pragma_As_Ghost (N, Pack_Id);
16053 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16055 Analyze_If_Present (Pragma_Initial_Condition);
16062 -- pragma Inline ( NAME {, NAME} );
16064 when Pragma_Inline =>
16066 -- Pragma always active unless in GNATprove mode. It is disabled
16067 -- in GNATprove mode because frontend inlining is applied
16068 -- independently of pragmas Inline and Inline_Always for
16069 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16072 if not GNATprove_Mode then
16074 -- Inline status is Enabled if inlining option is active
16076 if Inline_Active then
16077 Process_Inline (Enabled);
16079 Process_Inline (Disabled);
16083 -------------------
16084 -- Inline_Always --
16085 -------------------
16087 -- pragma Inline_Always ( NAME {, NAME} );
16089 when Pragma_Inline_Always =>
16092 -- Pragma always active unless in CodePeer mode or GNATprove
16093 -- mode. It is disabled in CodePeer mode because inlining is
16094 -- not helpful, and enabling it caused walk order issues. It
16095 -- is disabled in GNATprove mode because frontend inlining is
16096 -- applied independently of pragmas Inline and Inline_Always for
16097 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16100 if not CodePeer_Mode and not GNATprove_Mode then
16101 Process_Inline (Enabled);
16104 --------------------
16105 -- Inline_Generic --
16106 --------------------
16108 -- pragma Inline_Generic (NAME {, NAME});
16110 when Pragma_Inline_Generic =>
16112 Process_Generic_List;
16114 ----------------------
16115 -- Inspection_Point --
16116 ----------------------
16118 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16120 when Pragma_Inspection_Point => Inspection_Point : declare
16127 if Arg_Count > 0 then
16130 Exp := Get_Pragma_Arg (Arg);
16133 if not Is_Entity_Name (Exp)
16134 or else not Is_Object (Entity (Exp))
16136 Error_Pragma_Arg ("object name required", Arg);
16140 exit when No (Arg);
16143 end Inspection_Point;
16149 -- pragma Interface (
16150 -- [ Convention =>] convention_IDENTIFIER,
16151 -- [ Entity =>] LOCAL_NAME
16152 -- [, [External_Name =>] static_string_EXPRESSION ]
16153 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16155 when Pragma_Interface =>
16160 Name_External_Name,
16162 Check_At_Least_N_Arguments (2);
16163 Check_At_Most_N_Arguments (4);
16164 Process_Import_Or_Interface;
16166 -- In Ada 2005, the permission to use Interface (a reserved word)
16167 -- as a pragma name is considered an obsolescent feature, and this
16168 -- pragma was already obsolescent in Ada 95.
16170 if Ada_Version >= Ada_95 then
16172 (No_Obsolescent_Features, Pragma_Identifier (N));
16174 if Warn_On_Obsolescent_Feature then
16176 ("pragma Interface is an obsolescent feature?j?", N);
16178 ("|use pragma Import instead?j?", N);
16182 --------------------
16183 -- Interface_Name --
16184 --------------------
16186 -- pragma Interface_Name (
16187 -- [ Entity =>] LOCAL_NAME
16188 -- [,[External_Name =>] static_string_EXPRESSION ]
16189 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16191 when Pragma_Interface_Name => Interface_Name : declare
16193 Def_Id : Entity_Id;
16194 Hom_Id : Entity_Id;
16200 ((Name_Entity, Name_External_Name, Name_Link_Name));
16201 Check_At_Least_N_Arguments (2);
16202 Check_At_Most_N_Arguments (3);
16203 Id := Get_Pragma_Arg (Arg1);
16206 -- This is obsolete from Ada 95 on, but it is an implementation
16207 -- defined pragma, so we do not consider that it violates the
16208 -- restriction (No_Obsolescent_Features).
16210 if Ada_Version >= Ada_95 then
16211 if Warn_On_Obsolescent_Feature then
16213 ("pragma Interface_Name is an obsolescent feature?j?", N);
16215 ("|use pragma Import instead?j?", N);
16219 if not Is_Entity_Name (Id) then
16221 ("first argument for pragma% must be entity name", Arg1);
16222 elsif Etype (Id) = Any_Type then
16225 Def_Id := Entity (Id);
16228 -- Special DEC-compatible processing for the object case, forces
16229 -- object to be imported.
16231 if Ekind (Def_Id) = E_Variable then
16232 Kill_Size_Check_Code (Def_Id);
16233 Note_Possible_Modification (Id, Sure => False);
16235 -- Initialization is not allowed for imported variable
16237 if Present (Expression (Parent (Def_Id)))
16238 and then Comes_From_Source (Expression (Parent (Def_Id)))
16240 Error_Msg_Sloc := Sloc (Def_Id);
16242 ("no initialization allowed for declaration of& #",
16246 -- For compatibility, support VADS usage of providing both
16247 -- pragmas Interface and Interface_Name to obtain the effect
16248 -- of a single Import pragma.
16250 if Is_Imported (Def_Id)
16251 and then Present (First_Rep_Item (Def_Id))
16252 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16254 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16258 Set_Imported (Def_Id);
16261 Set_Is_Public (Def_Id);
16262 Process_Interface_Name (Def_Id, Arg2, Arg3);
16265 -- Otherwise must be subprogram
16267 elsif not Is_Subprogram (Def_Id) then
16269 ("argument of pragma% is not subprogram", Arg1);
16272 Check_At_Most_N_Arguments (3);
16276 -- Loop through homonyms
16279 Def_Id := Get_Base_Subprogram (Hom_Id);
16281 if Is_Imported (Def_Id) then
16282 Process_Interface_Name (Def_Id, Arg2, Arg3);
16286 exit when From_Aspect_Specification (N);
16287 Hom_Id := Homonym (Hom_Id);
16289 exit when No (Hom_Id)
16290 or else Scope (Hom_Id) /= Current_Scope;
16295 ("argument of pragma% is not imported subprogram",
16299 end Interface_Name;
16301 -----------------------
16302 -- Interrupt_Handler --
16303 -----------------------
16305 -- pragma Interrupt_Handler (handler_NAME);
16307 when Pragma_Interrupt_Handler =>
16308 Check_Ada_83_Warning;
16309 Check_Arg_Count (1);
16310 Check_No_Identifiers;
16312 if No_Run_Time_Mode then
16313 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16315 Check_Interrupt_Or_Attach_Handler;
16316 Process_Interrupt_Or_Attach_Handler;
16319 ------------------------
16320 -- Interrupt_Priority --
16321 ------------------------
16323 -- pragma Interrupt_Priority [(EXPRESSION)];
16325 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16326 P : constant Node_Id := Parent (N);
16331 Check_Ada_83_Warning;
16333 if Arg_Count /= 0 then
16334 Arg := Get_Pragma_Arg (Arg1);
16335 Check_Arg_Count (1);
16336 Check_No_Identifiers;
16338 -- The expression must be analyzed in the special manner
16339 -- described in "Handling of Default and Per-Object
16340 -- Expressions" in sem.ads.
16342 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16345 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16350 Ent := Defining_Identifier (Parent (P));
16352 -- Check duplicate pragma before we chain the pragma in the Rep
16353 -- Item chain of Ent.
16355 Check_Duplicate_Pragma (Ent);
16356 Record_Rep_Item (Ent, N);
16358 -- Check the No_Task_At_Interrupt_Priority restriction
16360 if Nkind (P) = N_Task_Definition then
16361 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16364 end Interrupt_Priority;
16366 ---------------------
16367 -- Interrupt_State --
16368 ---------------------
16370 -- pragma Interrupt_State (
16371 -- [Name =>] INTERRUPT_ID,
16372 -- [State =>] INTERRUPT_STATE);
16374 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16375 -- INTERRUPT_STATE => System | Runtime | User
16377 -- Note: if the interrupt id is given as an identifier, then it must
16378 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16379 -- given as a static integer expression which must be in the range of
16380 -- Ada.Interrupts.Interrupt_ID.
16382 when Pragma_Interrupt_State => Interrupt_State : declare
16383 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16384 -- This is the entity Ada.Interrupts.Interrupt_ID;
16386 State_Type : Character;
16387 -- Set to 's'/'r'/'u' for System/Runtime/User
16390 -- Index to entry in Interrupt_States table
16393 -- Value of interrupt
16395 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16396 -- The first argument to the pragma
16398 Int_Ent : Entity_Id;
16399 -- Interrupt entity in Ada.Interrupts.Names
16403 Check_Arg_Order ((Name_Name, Name_State));
16404 Check_Arg_Count (2);
16406 Check_Optional_Identifier (Arg1, Name_Name);
16407 Check_Optional_Identifier (Arg2, Name_State);
16408 Check_Arg_Is_Identifier (Arg2);
16410 -- First argument is identifier
16412 if Nkind (Arg1X) = N_Identifier then
16414 -- Search list of names in Ada.Interrupts.Names
16416 Int_Ent := First_Entity (RTE (RE_Names));
16418 if No (Int_Ent) then
16419 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16421 elsif Chars (Int_Ent) = Chars (Arg1X) then
16422 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16426 Next_Entity (Int_Ent);
16429 -- First argument is not an identifier, so it must be a static
16430 -- expression of type Ada.Interrupts.Interrupt_ID.
16433 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16434 Int_Val := Expr_Value (Arg1X);
16436 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16438 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16441 ("value not in range of type "
16442 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16448 case Chars (Get_Pragma_Arg (Arg2)) is
16449 when Name_Runtime => State_Type := 'r';
16450 when Name_System => State_Type := 's';
16451 when Name_User => State_Type := 'u';
16454 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16457 -- Check if entry is already stored
16459 IST_Num := Interrupt_States.First;
16461 -- If entry not found, add it
16463 if IST_Num > Interrupt_States.Last then
16464 Interrupt_States.Append
16465 ((Interrupt_Number => UI_To_Int (Int_Val),
16466 Interrupt_State => State_Type,
16467 Pragma_Loc => Loc));
16470 -- Case of entry for the same entry
16472 elsif Int_Val = Interrupt_States.Table (IST_Num).
16475 -- If state matches, done, no need to make redundant entry
16478 State_Type = Interrupt_States.Table (IST_Num).
16481 -- Otherwise if state does not match, error
16484 Interrupt_States.Table (IST_Num).Pragma_Loc;
16486 ("state conflicts with that given #", Arg2);
16490 IST_Num := IST_Num + 1;
16492 end Interrupt_State;
16498 -- pragma Invariant
16499 -- ([Entity =>] type_LOCAL_NAME,
16500 -- [Check =>] EXPRESSION
16501 -- [,[Message =>] String_Expression]);
16503 when Pragma_Invariant => Invariant : declare
16510 Check_At_Least_N_Arguments (2);
16511 Check_At_Most_N_Arguments (3);
16512 Check_Optional_Identifier (Arg1, Name_Entity);
16513 Check_Optional_Identifier (Arg2, Name_Check);
16515 if Arg_Count = 3 then
16516 Check_Optional_Identifier (Arg3, Name_Message);
16517 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16520 Check_Arg_Is_Local_Name (Arg1);
16522 Type_Id := Get_Pragma_Arg (Arg1);
16523 Find_Type (Type_Id);
16524 Typ := Entity (Type_Id);
16526 if Typ = Any_Type then
16529 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16531 elsif Is_Interface (Typ) then
16534 -- An invariant must apply to a private type, or appear in the
16535 -- private part of a package spec and apply to a completion.
16536 -- a class-wide invariant can only appear on a private declaration
16537 -- or private extension, not a completion.
16539 elsif Ekind_In (Typ, E_Private_Type,
16540 E_Record_Type_With_Private,
16541 E_Limited_Private_Type)
16545 elsif In_Private_Part (Current_Scope)
16546 and then Has_Private_Declaration (Typ)
16547 and then not Class_Present (N)
16551 elsif In_Private_Part (Current_Scope) then
16553 ("pragma% only allowed for private type declared in "
16554 & "visible part", Arg1);
16558 ("pragma% only allowed for private type", Arg1);
16561 -- A pragma that applies to a Ghost entity becomes Ghost for the
16562 -- purposes of legality checks and removal of ignored Ghost code.
16564 Mark_Pragma_As_Ghost (N, Typ);
16566 -- Not allowed for abstract type in the non-class case (it is
16567 -- allowed to use Invariant'Class for abstract types).
16569 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16571 ("pragma% not allowed for abstract type", Arg1);
16574 -- Link the pragma on to the rep item chain, for processing when
16575 -- the type is frozen.
16577 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16579 -- Note that the type has at least one invariant, and also that
16580 -- it has inheritable invariants if we have Invariant'Class
16581 -- or Type_Invariant'Class. Build the corresponding invariant
16582 -- procedure declaration, so that calls to it can be generated
16583 -- before the body is built (e.g. within an expression function).
16585 -- Interface types have no invariant procedure; their invariants
16586 -- are propagated to the build invariant procedure of all the
16587 -- types covering the interface type.
16589 if not Is_Interface (Typ) then
16590 Insert_After_And_Analyze
16591 (N, Build_Invariant_Procedure_Declaration (Typ));
16594 if Class_Present (N) then
16595 Set_Has_Inheritable_Invariants (Typ);
16603 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16605 when Pragma_Keep_Names => Keep_Names : declare
16610 Check_Arg_Count (1);
16611 Check_Optional_Identifier (Arg1, Name_On);
16612 Check_Arg_Is_Local_Name (Arg1);
16614 Arg := Get_Pragma_Arg (Arg1);
16617 if Etype (Arg) = Any_Type then
16621 if not Is_Entity_Name (Arg)
16622 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16625 ("pragma% requires a local enumeration type", Arg1);
16628 Set_Discard_Names (Entity (Arg), False);
16635 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16637 when Pragma_License =>
16640 -- Do not analyze pragma any further in CodePeer mode, to avoid
16641 -- extraneous errors in this implementation-dependent pragma,
16642 -- which has a different profile on other compilers.
16644 if CodePeer_Mode then
16648 Check_Arg_Count (1);
16649 Check_No_Identifiers;
16650 Check_Valid_Configuration_Pragma;
16651 Check_Arg_Is_Identifier (Arg1);
16654 Sind : constant Source_File_Index :=
16655 Source_Index (Current_Sem_Unit);
16658 case Chars (Get_Pragma_Arg (Arg1)) is
16660 Set_License (Sind, GPL);
16662 when Name_Modified_GPL =>
16663 Set_License (Sind, Modified_GPL);
16665 when Name_Restricted =>
16666 Set_License (Sind, Restricted);
16668 when Name_Unrestricted =>
16669 Set_License (Sind, Unrestricted);
16672 Error_Pragma_Arg ("invalid license name", Arg1);
16680 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16682 when Pragma_Link_With => Link_With : declare
16688 if Operating_Mode = Generate_Code
16689 and then In_Extended_Main_Source_Unit (N)
16691 Check_At_Least_N_Arguments (1);
16692 Check_No_Identifiers;
16693 Check_Is_In_Decl_Part_Or_Package_Spec;
16694 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16698 while Present (Arg) loop
16699 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16701 -- Store argument, converting sequences of spaces to a
16702 -- single null character (this is one of the differences
16703 -- in processing between Link_With and Linker_Options).
16705 Arg_Store : declare
16706 C : constant Char_Code := Get_Char_Code (' ');
16707 S : constant String_Id :=
16708 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16709 L : constant Nat := String_Length (S);
16712 procedure Skip_Spaces;
16713 -- Advance F past any spaces
16719 procedure Skip_Spaces is
16721 while F <= L and then Get_String_Char (S, F) = C loop
16726 -- Start of processing for Arg_Store
16729 Skip_Spaces; -- skip leading spaces
16731 -- Loop through characters, changing any embedded
16732 -- sequence of spaces to a single null character (this
16733 -- is how Link_With/Linker_Options differ)
16736 if Get_String_Char (S, F) = C then
16739 Store_String_Char (ASCII.NUL);
16742 Store_String_Char (Get_String_Char (S, F));
16750 if Present (Arg) then
16751 Store_String_Char (ASCII.NUL);
16755 Store_Linker_Option_String (End_String);
16763 -- pragma Linker_Alias (
16764 -- [Entity =>] LOCAL_NAME
16765 -- [Target =>] static_string_EXPRESSION);
16767 when Pragma_Linker_Alias =>
16769 Check_Arg_Order ((Name_Entity, Name_Target));
16770 Check_Arg_Count (2);
16771 Check_Optional_Identifier (Arg1, Name_Entity);
16772 Check_Optional_Identifier (Arg2, Name_Target);
16773 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16774 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16776 -- The only processing required is to link this item on to the
16777 -- list of rep items for the given entity. This is accomplished
16778 -- by the call to Rep_Item_Too_Late (when no error is detected
16779 -- and False is returned).
16781 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16784 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16787 ------------------------
16788 -- Linker_Constructor --
16789 ------------------------
16791 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16793 -- Code is shared with Linker_Destructor
16795 -----------------------
16796 -- Linker_Destructor --
16797 -----------------------
16799 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16801 when Pragma_Linker_Constructor |
16802 Pragma_Linker_Destructor =>
16803 Linker_Constructor : declare
16809 Check_Arg_Count (1);
16810 Check_No_Identifiers;
16811 Check_Arg_Is_Local_Name (Arg1);
16812 Arg1_X := Get_Pragma_Arg (Arg1);
16814 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16816 if not Is_Library_Level_Entity (Proc) then
16818 ("argument for pragma% must be library level entity", Arg1);
16821 -- The only processing required is to link this item on to the
16822 -- list of rep items for the given entity. This is accomplished
16823 -- by the call to Rep_Item_Too_Late (when no error is detected
16824 -- and False is returned).
16826 if Rep_Item_Too_Late (Proc, N) then
16829 Set_Has_Gigi_Rep_Item (Proc);
16831 end Linker_Constructor;
16833 --------------------
16834 -- Linker_Options --
16835 --------------------
16837 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16839 when Pragma_Linker_Options => Linker_Options : declare
16843 Check_Ada_83_Warning;
16844 Check_No_Identifiers;
16845 Check_Arg_Count (1);
16846 Check_Is_In_Decl_Part_Or_Package_Spec;
16847 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16848 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16851 while Present (Arg) loop
16852 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16853 Store_String_Char (ASCII.NUL);
16855 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16859 if Operating_Mode = Generate_Code
16860 and then In_Extended_Main_Source_Unit (N)
16862 Store_Linker_Option_String (End_String);
16864 end Linker_Options;
16866 --------------------
16867 -- Linker_Section --
16868 --------------------
16870 -- pragma Linker_Section (
16871 -- [Entity =>] LOCAL_NAME
16872 -- [Section =>] static_string_EXPRESSION);
16874 when Pragma_Linker_Section => Linker_Section : declare
16879 Ghost_Error_Posted : Boolean := False;
16880 -- Flag set when an error concerning the illegal mix of Ghost and
16881 -- non-Ghost subprograms is emitted.
16883 Ghost_Id : Entity_Id := Empty;
16884 -- The entity of the first Ghost subprogram encountered while
16885 -- processing the arguments of the pragma.
16889 Check_Arg_Order ((Name_Entity, Name_Section));
16890 Check_Arg_Count (2);
16891 Check_Optional_Identifier (Arg1, Name_Entity);
16892 Check_Optional_Identifier (Arg2, Name_Section);
16893 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16894 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16896 -- Check kind of entity
16898 Arg := Get_Pragma_Arg (Arg1);
16899 Ent := Entity (Arg);
16901 case Ekind (Ent) is
16903 -- Objects (constants and variables) and types. For these cases
16904 -- all we need to do is to set the Linker_Section_pragma field,
16905 -- checking that we do not have a duplicate.
16907 when E_Constant | E_Variable | Type_Kind =>
16908 LPE := Linker_Section_Pragma (Ent);
16910 if Present (LPE) then
16911 Error_Msg_Sloc := Sloc (LPE);
16913 ("Linker_Section already specified for &#", Arg1, Ent);
16916 Set_Linker_Section_Pragma (Ent, N);
16918 -- A pragma that applies to a Ghost entity becomes Ghost for
16919 -- the purposes of legality checks and removal of ignored
16922 Mark_Pragma_As_Ghost (N, Ent);
16926 when Subprogram_Kind =>
16928 -- Aspect case, entity already set
16930 if From_Aspect_Specification (N) then
16931 Set_Linker_Section_Pragma
16932 (Entity (Corresponding_Aspect (N)), N);
16934 -- Pragma case, we must climb the homonym chain, but skip
16935 -- any for which the linker section is already set.
16939 if No (Linker_Section_Pragma (Ent)) then
16940 Set_Linker_Section_Pragma (Ent, N);
16942 -- A pragma that applies to a Ghost entity becomes
16943 -- Ghost for the purposes of legality checks and
16944 -- removal of ignored Ghost code.
16946 Mark_Pragma_As_Ghost (N, Ent);
16948 -- Capture the entity of the first Ghost subprogram
16949 -- being processed for error detection purposes.
16951 if Is_Ghost_Entity (Ent) then
16952 if No (Ghost_Id) then
16956 -- Otherwise the subprogram is non-Ghost. It is
16957 -- illegal to mix references to Ghost and non-Ghost
16958 -- entities (SPARK RM 6.9).
16960 elsif Present (Ghost_Id)
16961 and then not Ghost_Error_Posted
16963 Ghost_Error_Posted := True;
16965 Error_Msg_Name_1 := Pname;
16967 ("pragma % cannot mention ghost and "
16968 & "non-ghost subprograms", N);
16970 Error_Msg_Sloc := Sloc (Ghost_Id);
16972 ("\& # declared as ghost", N, Ghost_Id);
16974 Error_Msg_Sloc := Sloc (Ent);
16976 ("\& # declared as non-ghost", N, Ent);
16980 Ent := Homonym (Ent);
16982 or else Scope (Ent) /= Current_Scope;
16986 -- All other cases are illegal
16990 ("pragma% applies only to objects, subprograms, and types",
16993 end Linker_Section;
16999 -- pragma List (On | Off)
17001 -- There is nothing to do here, since we did all the processing for
17002 -- this pragma in Par.Prag (so that it works properly even in syntax
17005 when Pragma_List =>
17012 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17014 when Pragma_Lock_Free => Lock_Free : declare
17015 P : constant Node_Id := Parent (N);
17021 Check_No_Identifiers;
17022 Check_At_Most_N_Arguments (1);
17024 -- Protected definition case
17026 if Nkind (P) = N_Protected_Definition then
17027 Ent := Defining_Identifier (Parent (P));
17031 if Arg_Count = 1 then
17032 Arg := Get_Pragma_Arg (Arg1);
17033 Val := Is_True (Static_Boolean (Arg));
17035 -- No arguments (expression is considered to be True)
17041 -- Check duplicate pragma before we chain the pragma in the Rep
17042 -- Item chain of Ent.
17044 Check_Duplicate_Pragma (Ent);
17045 Record_Rep_Item (Ent, N);
17046 Set_Uses_Lock_Free (Ent, Val);
17048 -- Anything else is incorrect placement
17055 --------------------
17056 -- Locking_Policy --
17057 --------------------
17059 -- pragma Locking_Policy (policy_IDENTIFIER);
17061 when Pragma_Locking_Policy => declare
17062 subtype LP_Range is Name_Id
17063 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17068 Check_Ada_83_Warning;
17069 Check_Arg_Count (1);
17070 Check_No_Identifiers;
17071 Check_Arg_Is_Locking_Policy (Arg1);
17072 Check_Valid_Configuration_Pragma;
17073 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17076 when Name_Ceiling_Locking =>
17078 when Name_Inheritance_Locking =>
17080 when Name_Concurrent_Readers_Locking =>
17084 if Locking_Policy /= ' '
17085 and then Locking_Policy /= LP
17087 Error_Msg_Sloc := Locking_Policy_Sloc;
17088 Error_Pragma ("locking policy incompatible with policy#");
17090 -- Set new policy, but always preserve System_Location since we
17091 -- like the error message with the run time name.
17094 Locking_Policy := LP;
17096 if Locking_Policy_Sloc /= System_Location then
17097 Locking_Policy_Sloc := Loc;
17102 -------------------
17103 -- Loop_Optimize --
17104 -------------------
17106 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17108 -- OPTIMIZATION_HINT ::=
17109 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17111 when Pragma_Loop_Optimize => Loop_Optimize : declare
17116 Check_At_Least_N_Arguments (1);
17117 Check_No_Identifiers;
17119 Hint := First (Pragma_Argument_Associations (N));
17120 while Present (Hint) loop
17121 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17129 Check_Loop_Pragma_Placement;
17136 -- pragma Loop_Variant
17137 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17139 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17141 -- CHANGE_DIRECTION ::= Increases | Decreases
17143 when Pragma_Loop_Variant => Loop_Variant : declare
17148 Check_At_Least_N_Arguments (1);
17149 Check_Loop_Pragma_Placement;
17151 -- Process all increasing / decreasing expressions
17153 Variant := First (Pragma_Argument_Associations (N));
17154 while Present (Variant) loop
17155 if not Nam_In (Chars (Variant), Name_Decreases,
17158 Error_Pragma_Arg ("wrong change modifier", Variant);
17161 Preanalyze_Assert_Expression
17162 (Expression (Variant), Any_Discrete);
17168 -----------------------
17169 -- Machine_Attribute --
17170 -----------------------
17172 -- pragma Machine_Attribute (
17173 -- [Entity =>] LOCAL_NAME,
17174 -- [Attribute_Name =>] static_string_EXPRESSION
17175 -- [, [Info =>] static_EXPRESSION] );
17177 when Pragma_Machine_Attribute => Machine_Attribute : declare
17178 Def_Id : Entity_Id;
17182 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17184 if Arg_Count = 3 then
17185 Check_Optional_Identifier (Arg3, Name_Info);
17186 Check_Arg_Is_OK_Static_Expression (Arg3);
17188 Check_Arg_Count (2);
17191 Check_Optional_Identifier (Arg1, Name_Entity);
17192 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17193 Check_Arg_Is_Local_Name (Arg1);
17194 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17195 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17197 if Is_Access_Type (Def_Id) then
17198 Def_Id := Designated_Type (Def_Id);
17201 if Rep_Item_Too_Early (Def_Id, N) then
17205 Def_Id := Underlying_Type (Def_Id);
17207 -- The only processing required is to link this item on to the
17208 -- list of rep items for the given entity. This is accomplished
17209 -- by the call to Rep_Item_Too_Late (when no error is detected
17210 -- and False is returned).
17212 if Rep_Item_Too_Late (Def_Id, N) then
17215 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17217 end Machine_Attribute;
17224 -- (MAIN_OPTION [, MAIN_OPTION]);
17227 -- [STACK_SIZE =>] static_integer_EXPRESSION
17228 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17229 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17231 when Pragma_Main => Main : declare
17232 Args : Args_List (1 .. 3);
17233 Names : constant Name_List (1 .. 3) := (
17235 Name_Task_Stack_Size_Default,
17236 Name_Time_Slicing_Enabled);
17242 Gather_Associations (Names, Args);
17244 for J in 1 .. 2 loop
17245 if Present (Args (J)) then
17246 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17250 if Present (Args (3)) then
17251 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17255 while Present (Nod) loop
17256 if Nkind (Nod) = N_Pragma
17257 and then Pragma_Name (Nod) = Name_Main
17259 Error_Msg_Name_1 := Pname;
17260 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17271 -- pragma Main_Storage
17272 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17274 -- MAIN_STORAGE_OPTION ::=
17275 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17276 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17278 when Pragma_Main_Storage => Main_Storage : declare
17279 Args : Args_List (1 .. 2);
17280 Names : constant Name_List (1 .. 2) := (
17281 Name_Working_Storage,
17288 Gather_Associations (Names, Args);
17290 for J in 1 .. 2 loop
17291 if Present (Args (J)) then
17292 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17296 Check_In_Main_Program;
17299 while Present (Nod) loop
17300 if Nkind (Nod) = N_Pragma
17301 and then Pragma_Name (Nod) = Name_Main_Storage
17303 Error_Msg_Name_1 := Pname;
17304 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17315 -- pragma Memory_Size (NUMERIC_LITERAL)
17317 when Pragma_Memory_Size =>
17320 -- Memory size is simply ignored
17322 Check_No_Identifiers;
17323 Check_Arg_Count (1);
17324 Check_Arg_Is_Integer_Literal (Arg1);
17332 -- The only correct use of this pragma is on its own in a file, in
17333 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17334 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17335 -- check for a file containing nothing but a No_Body pragma). If we
17336 -- attempt to process it during normal semantics processing, it means
17337 -- it was misplaced.
17339 when Pragma_No_Body =>
17343 -----------------------------
17344 -- No_Elaboration_Code_All --
17345 -----------------------------
17347 -- pragma No_Elaboration_Code_All;
17349 when Pragma_No_Elaboration_Code_All =>
17351 Check_Valid_Library_Unit_Pragma;
17353 if Nkind (N) = N_Null_Statement then
17357 -- Must appear for a spec or generic spec
17359 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17360 N_Generic_Package_Declaration,
17361 N_Generic_Subprogram_Declaration,
17362 N_Package_Declaration,
17363 N_Subprogram_Declaration)
17367 ("pragma% can only occur for package "
17368 & "or subprogram spec"));
17371 -- Set flag in unit table
17373 Set_No_Elab_Code_All (Current_Sem_Unit);
17375 -- Set restriction No_Elaboration_Code if this is the main unit
17377 if Current_Sem_Unit = Main_Unit then
17378 Set_Restriction (No_Elaboration_Code, N);
17381 -- If we are in the main unit or in an extended main source unit,
17382 -- then we also add it to the configuration restrictions so that
17383 -- it will apply to all units in the extended main source.
17385 if Current_Sem_Unit = Main_Unit
17386 or else In_Extended_Main_Source_Unit (N)
17388 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17391 -- If in main extended unit, activate transitive with test
17393 if In_Extended_Main_Source_Unit (N) then
17394 Opt.No_Elab_Code_All_Pragma := N;
17401 -- pragma No_Inline ( NAME {, NAME} );
17403 when Pragma_No_Inline =>
17405 Process_Inline (Suppressed);
17411 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17413 when Pragma_No_Return => No_Return : declare
17419 Ghost_Error_Posted : Boolean := False;
17420 -- Flag set when an error concerning the illegal mix of Ghost and
17421 -- non-Ghost subprograms is emitted.
17423 Ghost_Id : Entity_Id := Empty;
17424 -- The entity of the first Ghost procedure encountered while
17425 -- processing the arguments of the pragma.
17429 Check_At_Least_N_Arguments (1);
17431 -- Loop through arguments of pragma
17434 while Present (Arg) loop
17435 Check_Arg_Is_Local_Name (Arg);
17436 Id := Get_Pragma_Arg (Arg);
17439 if not Is_Entity_Name (Id) then
17440 Error_Pragma_Arg ("entity name required", Arg);
17443 if Etype (Id) = Any_Type then
17447 -- Loop to find matching procedures
17453 and then Scope (E) = Current_Scope
17455 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17458 -- A pragma that applies to a Ghost entity becomes Ghost
17459 -- for the purposes of legality checks and removal of
17460 -- ignored Ghost code.
17462 Mark_Pragma_As_Ghost (N, E);
17464 -- Capture the entity of the first Ghost procedure being
17465 -- processed for error detection purposes.
17467 if Is_Ghost_Entity (E) then
17468 if No (Ghost_Id) then
17472 -- Otherwise the subprogram is non-Ghost. It is illegal
17473 -- to mix references to Ghost and non-Ghost entities
17476 elsif Present (Ghost_Id)
17477 and then not Ghost_Error_Posted
17479 Ghost_Error_Posted := True;
17481 Error_Msg_Name_1 := Pname;
17483 ("pragma % cannot mention ghost and non-ghost "
17484 & "procedures", N);
17486 Error_Msg_Sloc := Sloc (Ghost_Id);
17487 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17489 Error_Msg_Sloc := Sloc (E);
17490 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17493 -- Set flag on any alias as well
17495 if Is_Overloadable (E) and then Present (Alias (E)) then
17496 Set_No_Return (Alias (E));
17502 exit when From_Aspect_Specification (N);
17506 -- If entity in not in current scope it may be the enclosing
17507 -- suprogram body to which the aspect applies.
17510 if Entity (Id) = Current_Scope
17511 and then From_Aspect_Specification (N)
17513 Set_No_Return (Entity (Id));
17515 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17527 -- pragma No_Run_Time;
17529 -- Note: this pragma is retained for backwards compatibility. See
17530 -- body of Rtsfind for full details on its handling.
17532 when Pragma_No_Run_Time =>
17534 Check_Valid_Configuration_Pragma;
17535 Check_Arg_Count (0);
17537 No_Run_Time_Mode := True;
17538 Configurable_Run_Time_Mode := True;
17540 -- Set Duration to 32 bits if word size is 32
17542 if Ttypes.System_Word_Size = 32 then
17543 Duration_32_Bits_On_Target := True;
17546 -- Set appropriate restrictions
17548 Set_Restriction (No_Finalization, N);
17549 Set_Restriction (No_Exception_Handlers, N);
17550 Set_Restriction (Max_Tasks, N, 0);
17551 Set_Restriction (No_Tasking, N);
17553 -----------------------
17554 -- No_Tagged_Streams --
17555 -----------------------
17557 -- pragma No_Tagged_Streams;
17558 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17560 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17566 Check_At_Most_N_Arguments (1);
17568 -- One argument case
17570 if Arg_Count = 1 then
17571 Check_Optional_Identifier (Arg1, Name_Entity);
17572 Check_Arg_Is_Local_Name (Arg1);
17573 E_Id := Get_Pragma_Arg (Arg1);
17575 if Etype (E_Id) = Any_Type then
17579 E := Entity (E_Id);
17581 Check_Duplicate_Pragma (E);
17583 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17585 ("argument for pragma% must be root tagged type", Arg1);
17588 if Rep_Item_Too_Early (E, N)
17590 Rep_Item_Too_Late (E, N)
17594 Set_No_Tagged_Streams_Pragma (E, N);
17597 -- Zero argument case
17600 Check_Is_In_Decl_Part_Or_Package_Spec;
17601 No_Tagged_Streams := N;
17603 end No_Tagged_Strms;
17605 ------------------------
17606 -- No_Strict_Aliasing --
17607 ------------------------
17609 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17611 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17616 Check_At_Most_N_Arguments (1);
17618 if Arg_Count = 0 then
17619 Check_Valid_Configuration_Pragma;
17620 Opt.No_Strict_Aliasing := True;
17623 Check_Optional_Identifier (Arg2, Name_Entity);
17624 Check_Arg_Is_Local_Name (Arg1);
17625 E_Id := Entity (Get_Pragma_Arg (Arg1));
17627 if E_Id = Any_Type then
17629 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17630 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17633 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17635 end No_Strict_Aliasing;
17637 -----------------------
17638 -- Normalize_Scalars --
17639 -----------------------
17641 -- pragma Normalize_Scalars;
17643 when Pragma_Normalize_Scalars =>
17644 Check_Ada_83_Warning;
17645 Check_Arg_Count (0);
17646 Check_Valid_Configuration_Pragma;
17648 -- Normalize_Scalars creates false positives in CodePeer, and
17649 -- incorrect negative results in GNATprove mode, so ignore this
17650 -- pragma in these modes.
17652 if not (CodePeer_Mode or GNATprove_Mode) then
17653 Normalize_Scalars := True;
17654 Init_Or_Norm_Scalars := True;
17661 -- pragma Obsolescent;
17663 -- pragma Obsolescent (
17664 -- [Message =>] static_string_EXPRESSION
17665 -- [,[Version =>] Ada_05]]);
17667 -- pragma Obsolescent (
17668 -- [Entity =>] NAME
17669 -- [,[Message =>] static_string_EXPRESSION
17670 -- [,[Version =>] Ada_05]] );
17672 when Pragma_Obsolescent => Obsolescent : declare
17676 procedure Set_Obsolescent (E : Entity_Id);
17677 -- Given an entity Ent, mark it as obsolescent if appropriate
17679 ---------------------
17680 -- Set_Obsolescent --
17681 ---------------------
17683 procedure Set_Obsolescent (E : Entity_Id) is
17692 -- A pragma that applies to a Ghost entity becomes Ghost for
17693 -- the purposes of legality checks and removal of ignored Ghost
17696 Mark_Pragma_As_Ghost (N, E);
17698 -- Entity name was given
17700 if Present (Ename) then
17702 -- If entity name matches, we are fine. Save entity in
17703 -- pragma argument, for ASIS use.
17705 if Chars (Ename) = Chars (Ent) then
17706 Set_Entity (Ename, Ent);
17707 Generate_Reference (Ent, Ename);
17709 -- If entity name does not match, only possibility is an
17710 -- enumeration literal from an enumeration type declaration.
17712 elsif Ekind (Ent) /= E_Enumeration_Type then
17714 ("pragma % entity name does not match declaration");
17717 Ent := First_Literal (E);
17721 ("pragma % entity name does not match any "
17722 & "enumeration literal");
17724 elsif Chars (Ent) = Chars (Ename) then
17725 Set_Entity (Ename, Ent);
17726 Generate_Reference (Ent, Ename);
17730 Ent := Next_Literal (Ent);
17736 -- Ent points to entity to be marked
17738 if Arg_Count >= 1 then
17740 -- Deal with static string argument
17742 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17743 S := Strval (Get_Pragma_Arg (Arg1));
17745 for J in 1 .. String_Length (S) loop
17746 if not In_Character_Range (Get_String_Char (S, J)) then
17748 ("pragma% argument does not allow wide characters",
17753 Obsolescent_Warnings.Append
17754 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17756 -- Check for Ada_05 parameter
17758 if Arg_Count /= 1 then
17759 Check_Arg_Count (2);
17762 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17765 Check_Arg_Is_Identifier (Argx);
17767 if Chars (Argx) /= Name_Ada_05 then
17768 Error_Msg_Name_2 := Name_Ada_05;
17770 ("only allowed argument for pragma% is %", Argx);
17773 if Ada_Version_Explicit < Ada_2005
17774 or else not Warn_On_Ada_2005_Compatibility
17782 -- Set flag if pragma active
17785 Set_Is_Obsolescent (Ent);
17789 end Set_Obsolescent;
17791 -- Start of processing for pragma Obsolescent
17796 Check_At_Most_N_Arguments (3);
17798 -- See if first argument specifies an entity name
17802 (Chars (Arg1) = Name_Entity
17804 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17806 N_Operator_Symbol))
17808 Ename := Get_Pragma_Arg (Arg1);
17810 -- Eliminate first argument, so we can share processing
17814 Arg_Count := Arg_Count - 1;
17816 -- No Entity name argument given
17822 if Arg_Count >= 1 then
17823 Check_Optional_Identifier (Arg1, Name_Message);
17825 if Arg_Count = 2 then
17826 Check_Optional_Identifier (Arg2, Name_Version);
17830 -- Get immediately preceding declaration
17833 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17837 -- Cases where we do not follow anything other than another pragma
17841 -- First case: library level compilation unit declaration with
17842 -- the pragma immediately following the declaration.
17844 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17846 (Defining_Entity (Unit (Parent (Parent (N)))));
17849 -- Case 2: library unit placement for package
17853 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17855 if Is_Package_Or_Generic_Package (Ent) then
17856 Set_Obsolescent (Ent);
17862 -- Cases where we must follow a declaration, including an
17863 -- abstract subprogram declaration, which is not in the
17864 -- other node subtypes.
17867 if Nkind (Decl) not in N_Declaration
17868 and then Nkind (Decl) not in N_Later_Decl_Item
17869 and then Nkind (Decl) not in N_Generic_Declaration
17870 and then Nkind (Decl) not in N_Renaming_Declaration
17871 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
17874 ("pragma% misplaced, "
17875 & "must immediately follow a declaration");
17878 Set_Obsolescent (Defining_Entity (Decl));
17888 -- pragma Optimize (Time | Space | Off);
17890 -- The actual check for optimize is done in Gigi. Note that this
17891 -- pragma does not actually change the optimization setting, it
17892 -- simply checks that it is consistent with the pragma.
17894 when Pragma_Optimize =>
17895 Check_No_Identifiers;
17896 Check_Arg_Count (1);
17897 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17899 ------------------------
17900 -- Optimize_Alignment --
17901 ------------------------
17903 -- pragma Optimize_Alignment (Time | Space | Off);
17905 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17907 Check_No_Identifiers;
17908 Check_Arg_Count (1);
17909 Check_Valid_Configuration_Pragma;
17912 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17916 Opt.Optimize_Alignment := 'T';
17918 Opt.Optimize_Alignment := 'S';
17920 Opt.Optimize_Alignment := 'O';
17922 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17926 -- Set indication that mode is set locally. If we are in fact in a
17927 -- configuration pragma file, this setting is harmless since the
17928 -- switch will get reset anyway at the start of each unit.
17930 Optimize_Alignment_Local := True;
17931 end Optimize_Alignment;
17937 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17939 when Pragma_Ordered => Ordered : declare
17940 Assoc : constant Node_Id := Arg1;
17946 Check_No_Identifiers;
17947 Check_Arg_Count (1);
17948 Check_Arg_Is_Local_Name (Arg1);
17950 Type_Id := Get_Pragma_Arg (Assoc);
17951 Find_Type (Type_Id);
17952 Typ := Entity (Type_Id);
17954 if Typ = Any_Type then
17957 Typ := Underlying_Type (Typ);
17960 if not Is_Enumeration_Type (Typ) then
17961 Error_Pragma ("pragma% must specify enumeration type");
17964 Check_First_Subtype (Arg1);
17965 Set_Has_Pragma_Ordered (Base_Type (Typ));
17968 -------------------
17969 -- Overflow_Mode --
17970 -------------------
17972 -- pragma Overflow_Mode
17973 -- ([General => ] MODE [, [Assertions => ] MODE]);
17975 -- MODE := STRICT | MINIMIZED | ELIMINATED
17977 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17978 -- since System.Bignums makes this assumption. This is true of nearly
17979 -- all (all?) targets.
17981 when Pragma_Overflow_Mode => Overflow_Mode : declare
17982 function Get_Overflow_Mode
17984 Arg : Node_Id) return Overflow_Mode_Type;
17985 -- Function to process one pragma argument, Arg. If an identifier
17986 -- is present, it must be Name. Mode type is returned if a valid
17987 -- argument exists, otherwise an error is signalled.
17989 -----------------------
17990 -- Get_Overflow_Mode --
17991 -----------------------
17993 function Get_Overflow_Mode
17995 Arg : Node_Id) return Overflow_Mode_Type
17997 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18000 Check_Optional_Identifier (Arg, Name);
18001 Check_Arg_Is_Identifier (Argx);
18003 if Chars (Argx) = Name_Strict then
18006 elsif Chars (Argx) = Name_Minimized then
18009 elsif Chars (Argx) = Name_Eliminated then
18010 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18012 ("Eliminated not implemented on this target", Argx);
18018 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18020 end Get_Overflow_Mode;
18022 -- Start of processing for Overflow_Mode
18026 Check_At_Least_N_Arguments (1);
18027 Check_At_Most_N_Arguments (2);
18029 -- Process first argument
18031 Scope_Suppress.Overflow_Mode_General :=
18032 Get_Overflow_Mode (Name_General, Arg1);
18034 -- Case of only one argument
18036 if Arg_Count = 1 then
18037 Scope_Suppress.Overflow_Mode_Assertions :=
18038 Scope_Suppress.Overflow_Mode_General;
18040 -- Case of two arguments present
18043 Scope_Suppress.Overflow_Mode_Assertions :=
18044 Get_Overflow_Mode (Name_Assertions, Arg2);
18048 --------------------------
18049 -- Overriding Renamings --
18050 --------------------------
18052 -- pragma Overriding_Renamings;
18054 when Pragma_Overriding_Renamings =>
18056 Check_Arg_Count (0);
18057 Check_Valid_Configuration_Pragma;
18058 Overriding_Renamings := True;
18064 -- pragma Pack (first_subtype_LOCAL_NAME);
18066 when Pragma_Pack => Pack : declare
18067 Assoc : constant Node_Id := Arg1;
18069 Ignore : Boolean := False;
18074 Check_No_Identifiers;
18075 Check_Arg_Count (1);
18076 Check_Arg_Is_Local_Name (Arg1);
18077 Type_Id := Get_Pragma_Arg (Assoc);
18079 if not Is_Entity_Name (Type_Id)
18080 or else not Is_Type (Entity (Type_Id))
18083 ("argument for pragma% must be type or subtype", Arg1);
18086 Find_Type (Type_Id);
18087 Typ := Entity (Type_Id);
18090 or else Rep_Item_Too_Early (Typ, N)
18094 Typ := Underlying_Type (Typ);
18097 -- A pragma that applies to a Ghost entity becomes Ghost for the
18098 -- purposes of legality checks and removal of ignored Ghost code.
18100 Mark_Pragma_As_Ghost (N, Typ);
18102 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18103 Error_Pragma ("pragma% must specify array or record type");
18106 Check_First_Subtype (Arg1);
18107 Check_Duplicate_Pragma (Typ);
18111 if Is_Array_Type (Typ) then
18112 Ctyp := Component_Type (Typ);
18114 -- Ignore pack that does nothing
18116 if Known_Static_Esize (Ctyp)
18117 and then Known_Static_RM_Size (Ctyp)
18118 and then Esize (Ctyp) = RM_Size (Ctyp)
18119 and then Addressable (Esize (Ctyp))
18124 -- Process OK pragma Pack. Note that if there is a separate
18125 -- component clause present, the Pack will be cancelled. This
18126 -- processing is in Freeze.
18128 if not Rep_Item_Too_Late (Typ, N) then
18130 -- In CodePeer mode, we do not need complex front-end
18131 -- expansions related to pragma Pack, so disable handling
18134 if CodePeer_Mode then
18137 -- Normal case where we do the pack action
18141 Set_Is_Packed (Base_Type (Typ));
18142 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18145 Set_Has_Pragma_Pack (Base_Type (Typ));
18149 -- For record types, the pack is always effective
18151 else pragma Assert (Is_Record_Type (Typ));
18152 if not Rep_Item_Too_Late (Typ, N) then
18153 Set_Is_Packed (Base_Type (Typ));
18154 Set_Has_Pragma_Pack (Base_Type (Typ));
18155 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18166 -- There is nothing to do here, since we did all the processing for
18167 -- this pragma in Par.Prag (so that it works properly even in syntax
18170 when Pragma_Page =>
18177 -- pragma Part_Of (ABSTRACT_STATE);
18179 -- ABSTRACT_STATE ::= NAME
18181 when Pragma_Part_Of => Part_Of : declare
18182 procedure Propagate_Part_Of
18183 (Pack_Id : Entity_Id;
18184 State_Id : Entity_Id;
18185 Instance : Node_Id);
18186 -- Propagate the Part_Of indicator to all abstract states and
18187 -- objects declared in the visible state space of a package
18188 -- denoted by Pack_Id. State_Id is the encapsulating state.
18189 -- Instance is the package instantiation node.
18191 -----------------------
18192 -- Propagate_Part_Of --
18193 -----------------------
18195 procedure Propagate_Part_Of
18196 (Pack_Id : Entity_Id;
18197 State_Id : Entity_Id;
18198 Instance : Node_Id)
18200 Has_Item : Boolean := False;
18201 -- Flag set when the visible state space contains at least one
18202 -- abstract state or variable.
18204 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18205 -- Propagate the Part_Of indicator to all abstract states and
18206 -- objects declared in the visible state space of a package
18207 -- denoted by Pack_Id.
18209 -----------------------
18210 -- Propagate_Part_Of --
18211 -----------------------
18213 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18214 Constits : Elist_Id;
18215 Item_Id : Entity_Id;
18218 -- Traverse the entity chain of the package and set relevant
18219 -- attributes of abstract states and objects declared in the
18220 -- visible state space of the package.
18222 Item_Id := First_Entity (Pack_Id);
18223 while Present (Item_Id)
18224 and then not In_Private_Part (Item_Id)
18226 -- Do not consider internally generated items
18228 if not Comes_From_Source (Item_Id) then
18231 -- The Part_Of indicator turns an abstract state or an
18232 -- object into a constituent of the encapsulating state.
18234 elsif Ekind_In (Item_Id, E_Abstract_State,
18239 Constits := Part_Of_Constituents (State_Id);
18241 if No (Constits) then
18242 Constits := New_Elmt_List;
18243 Set_Part_Of_Constituents (State_Id, Constits);
18246 Append_Elmt (Item_Id, Constits);
18247 Set_Encapsulating_State (Item_Id, State_Id);
18249 -- Recursively handle nested packages and instantiations
18251 elsif Ekind (Item_Id) = E_Package then
18252 Propagate_Part_Of (Item_Id);
18255 Next_Entity (Item_Id);
18257 end Propagate_Part_Of;
18259 -- Start of processing for Propagate_Part_Of
18262 Propagate_Part_Of (Pack_Id);
18264 -- Detect a package instantiation that is subject to a Part_Of
18265 -- indicator, but has no visible state.
18267 if not Has_Item then
18269 ("package instantiation & has Part_Of indicator but "
18270 & "lacks visible state", Instance, Pack_Id);
18272 end Propagate_Part_Of;
18276 Constits : Elist_Id;
18278 Encap_Id : Entity_Id;
18279 Item_Id : Entity_Id;
18283 -- Start of processing for Part_Of
18287 Check_No_Identifiers;
18288 Check_Arg_Count (1);
18290 Stmt := Find_Related_Context (N, Do_Checks => True);
18292 -- Object declaration
18294 if Nkind (Stmt) = N_Object_Declaration then
18297 -- Package instantiation
18299 elsif Nkind (Stmt) = N_Package_Instantiation then
18302 -- Single concurrent type declaration
18304 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18307 -- Otherwise the pragma is associated with an illegal construct
18314 -- Extract the entity of the related object declaration or package
18315 -- instantiation. In the case of the instantiation, use the entity
18316 -- of the instance spec.
18318 if Nkind (Stmt) = N_Package_Instantiation then
18319 Stmt := Instance_Spec (Stmt);
18322 Item_Id := Defining_Entity (Stmt);
18323 Encap := Get_Pragma_Arg (Arg1);
18325 -- A pragma that applies to a Ghost entity becomes Ghost for the
18326 -- purposes of legality checks and removal of ignored Ghost code.
18328 Mark_Pragma_As_Ghost (N, Item_Id);
18330 -- Chain the pragma on the contract for further processing by
18331 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18333 Add_Contract_Item (N, Item_Id);
18335 -- A variable may act as consituent of a single concurrent type
18336 -- which in turn could be declared after the variable. Due to this
18337 -- discrepancy, the full analysis of indicator Part_Of is delayed
18338 -- until the end of the enclosing declarative region (see routine
18339 -- Analyze_Part_Of_In_Decl_Part).
18341 if Ekind (Item_Id) = E_Variable then
18344 -- Otherwise indicator Part_Of applies to a constant or a package
18348 -- Detect any discrepancies between the placement of the
18349 -- constant or package instantiation with respect to state
18350 -- space and the encapsulating state.
18354 Item_Id => Item_Id,
18356 Encap_Id => Encap_Id,
18360 pragma Assert (Present (Encap_Id));
18362 if Ekind (Item_Id) = E_Constant then
18363 Constits := Part_Of_Constituents (Encap_Id);
18365 if No (Constits) then
18366 Constits := New_Elmt_List;
18367 Set_Part_Of_Constituents (Encap_Id, Constits);
18370 Append_Elmt (Item_Id, Constits);
18371 Set_Encapsulating_State (Item_Id, Encap_Id);
18373 -- Propagate the Part_Of indicator to the visible state
18374 -- space of the package instantiation.
18378 (Pack_Id => Item_Id,
18379 State_Id => Encap_Id,
18386 ----------------------------------
18387 -- Partition_Elaboration_Policy --
18388 ----------------------------------
18390 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18392 when Pragma_Partition_Elaboration_Policy => declare
18393 subtype PEP_Range is Name_Id
18394 range First_Partition_Elaboration_Policy_Name
18395 .. Last_Partition_Elaboration_Policy_Name;
18396 PEP_Val : PEP_Range;
18401 Check_Arg_Count (1);
18402 Check_No_Identifiers;
18403 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18404 Check_Valid_Configuration_Pragma;
18405 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18408 when Name_Concurrent =>
18410 when Name_Sequential =>
18414 if Partition_Elaboration_Policy /= ' '
18415 and then Partition_Elaboration_Policy /= PEP
18417 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18419 ("partition elaboration policy incompatible with policy#");
18421 -- Set new policy, but always preserve System_Location since we
18422 -- like the error message with the run time name.
18425 Partition_Elaboration_Policy := PEP;
18427 if Partition_Elaboration_Policy_Sloc /= System_Location then
18428 Partition_Elaboration_Policy_Sloc := Loc;
18437 -- pragma Passive [(PASSIVE_FORM)];
18439 -- PASSIVE_FORM ::= Semaphore | No
18441 when Pragma_Passive =>
18444 if Nkind (Parent (N)) /= N_Task_Definition then
18445 Error_Pragma ("pragma% must be within task definition");
18448 if Arg_Count /= 0 then
18449 Check_Arg_Count (1);
18450 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18453 ----------------------------------
18454 -- Preelaborable_Initialization --
18455 ----------------------------------
18457 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18459 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18464 Check_Arg_Count (1);
18465 Check_No_Identifiers;
18466 Check_Arg_Is_Identifier (Arg1);
18467 Check_Arg_Is_Local_Name (Arg1);
18468 Check_First_Subtype (Arg1);
18469 Ent := Entity (Get_Pragma_Arg (Arg1));
18471 -- A pragma that applies to a Ghost entity becomes Ghost for the
18472 -- purposes of legality checks and removal of ignored Ghost code.
18474 Mark_Pragma_As_Ghost (N, Ent);
18476 -- The pragma may come from an aspect on a private declaration,
18477 -- even if the freeze point at which this is analyzed in the
18478 -- private part after the full view.
18480 if Has_Private_Declaration (Ent)
18481 and then From_Aspect_Specification (N)
18485 -- Check appropriate type argument
18487 elsif Is_Private_Type (Ent)
18488 or else Is_Protected_Type (Ent)
18489 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18491 -- AI05-0028: The pragma applies to all composite types. Note
18492 -- that we apply this binding interpretation to earlier versions
18493 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18494 -- choice since there are other compilers that do the same.
18496 or else Is_Composite_Type (Ent)
18502 ("pragma % can only be applied to private, formal derived, "
18503 & "protected, or composite type", Arg1);
18506 -- Give an error if the pragma is applied to a protected type that
18507 -- does not qualify (due to having entries, or due to components
18508 -- that do not qualify).
18510 if Is_Protected_Type (Ent)
18511 and then not Has_Preelaborable_Initialization (Ent)
18514 ("protected type & does not have preelaborable "
18515 & "initialization", Ent);
18517 -- Otherwise mark the type as definitely having preelaborable
18521 Set_Known_To_Have_Preelab_Init (Ent);
18524 if Has_Pragma_Preelab_Init (Ent)
18525 and then Warn_On_Redundant_Constructs
18527 Error_Pragma ("?r?duplicate pragma%!");
18529 Set_Has_Pragma_Preelab_Init (Ent);
18533 --------------------
18534 -- Persistent_BSS --
18535 --------------------
18537 -- pragma Persistent_BSS [(object_NAME)];
18539 when Pragma_Persistent_BSS => Persistent_BSS : declare
18546 Check_At_Most_N_Arguments (1);
18548 -- Case of application to specific object (one argument)
18550 if Arg_Count = 1 then
18551 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18553 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18555 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18558 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18561 Ent := Entity (Get_Pragma_Arg (Arg1));
18562 Decl := Parent (Ent);
18564 -- A pragma that applies to a Ghost entity becomes Ghost for
18565 -- the purposes of legality checks and removal of ignored Ghost
18568 Mark_Pragma_As_Ghost (N, Ent);
18570 -- Check for duplication before inserting in list of
18571 -- representation items.
18573 Check_Duplicate_Pragma (Ent);
18575 if Rep_Item_Too_Late (Ent, N) then
18579 if Present (Expression (Decl)) then
18581 ("object for pragma% cannot have initialization", Arg1);
18584 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18586 ("object type for pragma% is not potentially persistent",
18591 Make_Linker_Section_Pragma
18592 (Ent, Sloc (N), ".persistent.bss");
18593 Insert_After (N, Prag);
18596 -- Case of use as configuration pragma with no arguments
18599 Check_Valid_Configuration_Pragma;
18600 Persistent_BSS_Mode := True;
18602 end Persistent_BSS;
18608 -- pragma Polling (ON | OFF);
18610 when Pragma_Polling =>
18612 Check_Arg_Count (1);
18613 Check_No_Identifiers;
18614 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18615 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18617 -----------------------------------
18618 -- Post/Post_Class/Postcondition --
18619 -----------------------------------
18621 -- pragma Post (Boolean_EXPRESSION);
18622 -- pragma Post_Class (Boolean_EXPRESSION);
18623 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18624 -- [,[Message =>] String_EXPRESSION]);
18626 -- Characteristics:
18628 -- * Analysis - The annotation undergoes initial checks to verify
18629 -- the legal placement and context. Secondary checks preanalyze the
18632 -- Analyze_Pre_Post_Condition_In_Decl_Part
18634 -- * Expansion - The annotation is expanded during the expansion of
18635 -- the related subprogram [body] contract as performed in:
18637 -- Expand_Subprogram_Contract
18639 -- * Template - The annotation utilizes the generic template of the
18640 -- related subprogram [body] when it is:
18642 -- aspect on subprogram declaration
18643 -- aspect on stand alone subprogram body
18644 -- pragma on stand alone subprogram body
18646 -- The annotation must prepare its own template when it is:
18648 -- pragma on subprogram declaration
18650 -- * Globals - Capture of global references must occur after full
18653 -- * Instance - The annotation is instantiated automatically when
18654 -- the related generic subprogram [body] is instantiated except for
18655 -- the "pragma on subprogram declaration" case. In that scenario
18656 -- the annotation must instantiate itself.
18659 Pragma_Post_Class |
18660 Pragma_Postcondition =>
18661 Analyze_Pre_Post_Condition;
18663 --------------------------------
18664 -- Pre/Pre_Class/Precondition --
18665 --------------------------------
18667 -- pragma Pre (Boolean_EXPRESSION);
18668 -- pragma Pre_Class (Boolean_EXPRESSION);
18669 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18670 -- [,[Message =>] String_EXPRESSION]);
18672 -- Characteristics:
18674 -- * Analysis - The annotation undergoes initial checks to verify
18675 -- the legal placement and context. Secondary checks preanalyze the
18678 -- Analyze_Pre_Post_Condition_In_Decl_Part
18680 -- * Expansion - The annotation is expanded during the expansion of
18681 -- the related subprogram [body] contract as performed in:
18683 -- Expand_Subprogram_Contract
18685 -- * Template - The annotation utilizes the generic template of the
18686 -- related subprogram [body] when it is:
18688 -- aspect on subprogram declaration
18689 -- aspect on stand alone subprogram body
18690 -- pragma on stand alone subprogram body
18692 -- The annotation must prepare its own template when it is:
18694 -- pragma on subprogram declaration
18696 -- * Globals - Capture of global references must occur after full
18699 -- * Instance - The annotation is instantiated automatically when
18700 -- the related generic subprogram [body] is instantiated except for
18701 -- the "pragma on subprogram declaration" case. In that scenario
18702 -- the annotation must instantiate itself.
18706 Pragma_Precondition =>
18707 Analyze_Pre_Post_Condition;
18713 -- pragma Predicate
18714 -- ([Entity =>] type_LOCAL_NAME,
18715 -- [Check =>] boolean_EXPRESSION);
18717 when Pragma_Predicate => Predicate : declare
18724 Check_Arg_Count (2);
18725 Check_Optional_Identifier (Arg1, Name_Entity);
18726 Check_Optional_Identifier (Arg2, Name_Check);
18728 Check_Arg_Is_Local_Name (Arg1);
18730 Type_Id := Get_Pragma_Arg (Arg1);
18731 Find_Type (Type_Id);
18732 Typ := Entity (Type_Id);
18734 if Typ = Any_Type then
18738 -- A pragma that applies to a Ghost entity becomes Ghost for the
18739 -- purposes of legality checks and removal of ignored Ghost code.
18741 Mark_Pragma_As_Ghost (N, Typ);
18743 -- The remaining processing is simply to link the pragma on to
18744 -- the rep item chain, for processing when the type is frozen.
18745 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18746 -- mark the type as having predicates.
18747 -- If the current policy is Ignore mark the subtype accordingly.
18748 -- In the case of predicates we consider them enabled unless an
18749 -- Ignore is specified, to preserve existing warnings.
18751 Set_Has_Predicates (Typ);
18752 Set_Predicates_Ignored (Typ,
18753 Present (Check_Policy_List)
18755 Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
18756 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18759 -----------------------
18760 -- Predicate_Failure --
18761 -----------------------
18763 -- pragma Predicate_Failure
18764 -- ([Entity =>] type_LOCAL_NAME,
18765 -- [Message =>] string_EXPRESSION);
18767 when Pragma_Predicate_Failure => Predicate_Failure : declare
18774 Check_Arg_Count (2);
18775 Check_Optional_Identifier (Arg1, Name_Entity);
18776 Check_Optional_Identifier (Arg2, Name_Message);
18778 Check_Arg_Is_Local_Name (Arg1);
18780 Type_Id := Get_Pragma_Arg (Arg1);
18781 Find_Type (Type_Id);
18782 Typ := Entity (Type_Id);
18784 if Typ = Any_Type then
18788 -- A pragma that applies to a Ghost entity becomes Ghost for the
18789 -- purposes of legality checks and removal of ignored Ghost code.
18791 Mark_Pragma_As_Ghost (N, Typ);
18793 -- The remaining processing is simply to link the pragma on to
18794 -- the rep item chain, for processing when the type is frozen.
18795 -- This is accomplished by a call to Rep_Item_Too_Late.
18797 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18798 end Predicate_Failure;
18804 -- pragma Preelaborate [(library_unit_NAME)];
18806 -- Set the flag Is_Preelaborated of program unit name entity
18808 when Pragma_Preelaborate => Preelaborate : declare
18809 Pa : constant Node_Id := Parent (N);
18810 Pk : constant Node_Kind := Nkind (Pa);
18814 Check_Ada_83_Warning;
18815 Check_Valid_Library_Unit_Pragma;
18817 if Nkind (N) = N_Null_Statement then
18821 Ent := Find_Lib_Unit_Name;
18823 -- A pragma that applies to a Ghost entity becomes Ghost for the
18824 -- purposes of legality checks and removal of ignored Ghost code.
18826 Mark_Pragma_As_Ghost (N, Ent);
18827 Check_Duplicate_Pragma (Ent);
18829 -- This filters out pragmas inside generic parents that show up
18830 -- inside instantiations. Pragmas that come from aspects in the
18831 -- unit are not ignored.
18833 if Present (Ent) then
18834 if Pk = N_Package_Specification
18835 and then Present (Generic_Parent (Pa))
18836 and then not From_Aspect_Specification (N)
18841 if not Debug_Flag_U then
18842 Set_Is_Preelaborated (Ent);
18843 Set_Suppress_Elaboration_Warnings (Ent);
18849 -------------------------------
18850 -- Prefix_Exception_Messages --
18851 -------------------------------
18853 -- pragma Prefix_Exception_Messages;
18855 when Pragma_Prefix_Exception_Messages =>
18857 Check_Valid_Configuration_Pragma;
18858 Check_Arg_Count (0);
18859 Prefix_Exception_Messages := True;
18865 -- pragma Priority (EXPRESSION);
18867 when Pragma_Priority => Priority : declare
18868 P : constant Node_Id := Parent (N);
18873 Check_No_Identifiers;
18874 Check_Arg_Count (1);
18878 if Nkind (P) = N_Subprogram_Body then
18879 Check_In_Main_Program;
18881 Ent := Defining_Unit_Name (Specification (P));
18883 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18884 Ent := Defining_Identifier (Ent);
18887 Arg := Get_Pragma_Arg (Arg1);
18888 Analyze_And_Resolve (Arg, Standard_Integer);
18892 if not Is_OK_Static_Expression (Arg) then
18893 Flag_Non_Static_Expr
18894 ("main subprogram priority is not static!", Arg);
18897 -- If constraint error, then we already signalled an error
18899 elsif Raises_Constraint_Error (Arg) then
18902 -- Otherwise check in range except if Relaxed_RM_Semantics
18903 -- where we ignore the value if out of range.
18906 if not Relaxed_RM_Semantics
18907 and then not Is_In_Range (Arg, RTE (RE_Priority))
18910 ("main subprogram priority is out of range", Arg1);
18913 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18917 -- Load an arbitrary entity from System.Tasking.Stages or
18918 -- System.Tasking.Restricted.Stages (depending on the
18919 -- supported profile) to make sure that one of these packages
18920 -- is implicitly with'ed, since we need to have the tasking
18921 -- run time active for the pragma Priority to have any effect.
18922 -- Previously we with'ed the package System.Tasking, but this
18923 -- package does not trigger the required initialization of the
18924 -- run-time library.
18927 Discard : Entity_Id;
18928 pragma Warnings (Off, Discard);
18930 if Restricted_Profile then
18931 Discard := RTE (RE_Activate_Restricted_Tasks);
18933 Discard := RTE (RE_Activate_Tasks);
18937 -- Task or Protected, must be of type Integer
18939 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18940 Arg := Get_Pragma_Arg (Arg1);
18941 Ent := Defining_Identifier (Parent (P));
18943 -- The expression must be analyzed in the special manner
18944 -- described in "Handling of Default and Per-Object
18945 -- Expressions" in sem.ads.
18947 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18949 if not Is_OK_Static_Expression (Arg) then
18950 Check_Restriction (Static_Priorities, Arg);
18953 -- Anything else is incorrect
18959 -- Check duplicate pragma before we chain the pragma in the Rep
18960 -- Item chain of Ent.
18962 Check_Duplicate_Pragma (Ent);
18963 Record_Rep_Item (Ent, N);
18966 -----------------------------------
18967 -- Priority_Specific_Dispatching --
18968 -----------------------------------
18970 -- pragma Priority_Specific_Dispatching (
18971 -- policy_IDENTIFIER,
18972 -- first_priority_EXPRESSION,
18973 -- last_priority_EXPRESSION);
18975 when Pragma_Priority_Specific_Dispatching =>
18976 Priority_Specific_Dispatching : declare
18977 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18978 -- This is the entity System.Any_Priority;
18981 Lower_Bound : Node_Id;
18982 Upper_Bound : Node_Id;
18988 Check_Arg_Count (3);
18989 Check_No_Identifiers;
18990 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18991 Check_Valid_Configuration_Pragma;
18992 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18993 DP := Fold_Upper (Name_Buffer (1));
18995 Lower_Bound := Get_Pragma_Arg (Arg2);
18996 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
18997 Lower_Val := Expr_Value (Lower_Bound);
18999 Upper_Bound := Get_Pragma_Arg (Arg3);
19000 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19001 Upper_Val := Expr_Value (Upper_Bound);
19003 -- It is not allowed to use Task_Dispatching_Policy and
19004 -- Priority_Specific_Dispatching in the same partition.
19006 if Task_Dispatching_Policy /= ' ' then
19007 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19009 ("pragma% incompatible with Task_Dispatching_Policy#");
19011 -- Check lower bound in range
19013 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19015 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19018 ("first_priority is out of range", Arg2);
19020 -- Check upper bound in range
19022 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19024 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19027 ("last_priority is out of range", Arg3);
19029 -- Check that the priority range is valid
19031 elsif Lower_Val > Upper_Val then
19033 ("last_priority_expression must be greater than or equal to "
19034 & "first_priority_expression");
19036 -- Store the new policy, but always preserve System_Location since
19037 -- we like the error message with the run-time name.
19040 -- Check overlapping in the priority ranges specified in other
19041 -- Priority_Specific_Dispatching pragmas within the same
19042 -- partition. We can only check those we know about.
19045 Specific_Dispatching.First .. Specific_Dispatching.Last
19047 if Specific_Dispatching.Table (J).First_Priority in
19048 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19049 or else Specific_Dispatching.Table (J).Last_Priority in
19050 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19053 Specific_Dispatching.Table (J).Pragma_Loc;
19055 ("priority range overlaps with "
19056 & "Priority_Specific_Dispatching#");
19060 -- The use of Priority_Specific_Dispatching is incompatible
19061 -- with Task_Dispatching_Policy.
19063 if Task_Dispatching_Policy /= ' ' then
19064 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19066 ("Priority_Specific_Dispatching incompatible "
19067 & "with Task_Dispatching_Policy#");
19070 -- The use of Priority_Specific_Dispatching forces ceiling
19073 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19074 Error_Msg_Sloc := Locking_Policy_Sloc;
19076 ("Priority_Specific_Dispatching incompatible "
19077 & "with Locking_Policy#");
19079 -- Set the Ceiling_Locking policy, but preserve System_Location
19080 -- since we like the error message with the run time name.
19083 Locking_Policy := 'C';
19085 if Locking_Policy_Sloc /= System_Location then
19086 Locking_Policy_Sloc := Loc;
19090 -- Add entry in the table
19092 Specific_Dispatching.Append
19093 ((Dispatching_Policy => DP,
19094 First_Priority => UI_To_Int (Lower_Val),
19095 Last_Priority => UI_To_Int (Upper_Val),
19096 Pragma_Loc => Loc));
19098 end Priority_Specific_Dispatching;
19104 -- pragma Profile (profile_IDENTIFIER);
19106 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19108 when Pragma_Profile =>
19110 Check_Arg_Count (1);
19111 Check_Valid_Configuration_Pragma;
19112 Check_No_Identifiers;
19115 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19118 if Chars (Argx) = Name_Ravenscar then
19119 Set_Ravenscar_Profile (Ravenscar, N);
19121 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19122 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19124 elsif Chars (Argx) = Name_Restricted then
19125 Set_Profile_Restrictions
19127 N, Warn => Treat_Restrictions_As_Warnings);
19129 elsif Chars (Argx) = Name_Rational then
19130 Set_Rational_Profile;
19132 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19133 Set_Profile_Restrictions
19134 (No_Implementation_Extensions,
19135 N, Warn => Treat_Restrictions_As_Warnings);
19138 Error_Pragma_Arg ("& is not a valid profile", Argx);
19142 ----------------------
19143 -- Profile_Warnings --
19144 ----------------------
19146 -- pragma Profile_Warnings (profile_IDENTIFIER);
19148 -- profile_IDENTIFIER => Restricted | Ravenscar
19150 when Pragma_Profile_Warnings =>
19152 Check_Arg_Count (1);
19153 Check_Valid_Configuration_Pragma;
19154 Check_No_Identifiers;
19157 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19160 if Chars (Argx) = Name_Ravenscar then
19161 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19163 elsif Chars (Argx) = Name_Restricted then
19164 Set_Profile_Restrictions (Restricted, N, Warn => True);
19166 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19167 Set_Profile_Restrictions
19168 (No_Implementation_Extensions, N, Warn => True);
19171 Error_Pragma_Arg ("& is not a valid profile", Argx);
19175 --------------------------
19176 -- Propagate_Exceptions --
19177 --------------------------
19179 -- pragma Propagate_Exceptions;
19181 -- Note: this pragma is obsolete and has no effect
19183 when Pragma_Propagate_Exceptions =>
19185 Check_Arg_Count (0);
19187 if Warn_On_Obsolescent_Feature then
19189 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19190 "and has no effect?j?", N);
19193 -----------------------------
19194 -- Provide_Shift_Operators --
19195 -----------------------------
19197 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19199 when Pragma_Provide_Shift_Operators =>
19200 Provide_Shift_Operators : declare
19203 procedure Declare_Shift_Operator (Nam : Name_Id);
19204 -- Insert declaration and pragma Instrinsic for named shift op
19206 ----------------------------
19207 -- Declare_Shift_Operator --
19208 ----------------------------
19210 procedure Declare_Shift_Operator (Nam : Name_Id) is
19216 Make_Subprogram_Declaration (Loc,
19217 Make_Function_Specification (Loc,
19218 Defining_Unit_Name =>
19219 Make_Defining_Identifier (Loc, Chars => Nam),
19221 Result_Definition =>
19222 Make_Identifier (Loc, Chars => Chars (Ent)),
19224 Parameter_Specifications => New_List (
19225 Make_Parameter_Specification (Loc,
19226 Defining_Identifier =>
19227 Make_Defining_Identifier (Loc, Name_Value),
19229 Make_Identifier (Loc, Chars => Chars (Ent))),
19231 Make_Parameter_Specification (Loc,
19232 Defining_Identifier =>
19233 Make_Defining_Identifier (Loc, Name_Amount),
19235 New_Occurrence_Of (Standard_Natural, Loc)))));
19239 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19240 Pragma_Argument_Associations => New_List (
19241 Make_Pragma_Argument_Association (Loc,
19242 Expression => Make_Identifier (Loc, Name_Intrinsic)),
19243 Make_Pragma_Argument_Association (Loc,
19244 Expression => Make_Identifier (Loc, Nam))));
19246 Insert_After (N, Import);
19247 Insert_After (N, Func);
19248 end Declare_Shift_Operator;
19250 -- Start of processing for Provide_Shift_Operators
19254 Check_Arg_Count (1);
19255 Check_Arg_Is_Local_Name (Arg1);
19257 Arg1 := Get_Pragma_Arg (Arg1);
19259 -- We must have an entity name
19261 if not Is_Entity_Name (Arg1) then
19263 ("pragma % must apply to integer first subtype", Arg1);
19266 -- If no Entity, means there was a prior error so ignore
19268 if Present (Entity (Arg1)) then
19269 Ent := Entity (Arg1);
19271 -- Apply error checks
19273 if not Is_First_Subtype (Ent) then
19275 ("cannot apply pragma %",
19276 "\& is not a first subtype",
19279 elsif not Is_Integer_Type (Ent) then
19281 ("cannot apply pragma %",
19282 "\& is not an integer type",
19285 elsif Has_Shift_Operator (Ent) then
19287 ("cannot apply pragma %",
19288 "\& already has declared shift operators",
19291 elsif Is_Frozen (Ent) then
19293 ("pragma % appears too late",
19294 "\& is already frozen",
19298 -- Now declare the operators. We do this during analysis rather
19299 -- than expansion, since we want the operators available if we
19300 -- are operating in -gnatc or ASIS mode.
19302 Declare_Shift_Operator (Name_Rotate_Left);
19303 Declare_Shift_Operator (Name_Rotate_Right);
19304 Declare_Shift_Operator (Name_Shift_Left);
19305 Declare_Shift_Operator (Name_Shift_Right);
19306 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19308 end Provide_Shift_Operators;
19314 -- pragma Psect_Object (
19315 -- [Internal =>] LOCAL_NAME,
19316 -- [, [External =>] EXTERNAL_SYMBOL]
19317 -- [, [Size =>] EXTERNAL_SYMBOL]);
19319 when Pragma_Psect_Object | Pragma_Common_Object =>
19320 Psect_Object : declare
19321 Args : Args_List (1 .. 3);
19322 Names : constant Name_List (1 .. 3) := (
19327 Internal : Node_Id renames Args (1);
19328 External : Node_Id renames Args (2);
19329 Size : Node_Id renames Args (3);
19331 Def_Id : Entity_Id;
19333 procedure Check_Arg (Arg : Node_Id);
19334 -- Checks that argument is either a string literal or an
19335 -- identifier, and posts error message if not.
19341 procedure Check_Arg (Arg : Node_Id) is
19343 if not Nkind_In (Original_Node (Arg),
19348 ("inappropriate argument for pragma %", Arg);
19352 -- Start of processing for Common_Object/Psect_Object
19356 Gather_Associations (Names, Args);
19357 Process_Extended_Import_Export_Internal_Arg (Internal);
19359 Def_Id := Entity (Internal);
19361 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19363 ("pragma% must designate an object", Internal);
19366 Check_Arg (Internal);
19368 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19370 ("cannot use pragma% for imported/exported object",
19374 if Is_Concurrent_Type (Etype (Internal)) then
19376 ("cannot specify pragma % for task/protected object",
19380 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19382 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19384 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19387 if Ekind (Def_Id) = E_Constant then
19389 ("cannot specify pragma % for a constant", Internal);
19392 if Is_Record_Type (Etype (Internal)) then
19398 Ent := First_Entity (Etype (Internal));
19399 while Present (Ent) loop
19400 Decl := Declaration_Node (Ent);
19402 if Ekind (Ent) = E_Component
19403 and then Nkind (Decl) = N_Component_Declaration
19404 and then Present (Expression (Decl))
19405 and then Warn_On_Export_Import
19408 ("?x?object for pragma % has defaults", Internal);
19418 if Present (Size) then
19422 if Present (External) then
19423 Check_Arg_Is_External_Name (External);
19426 -- If all error tests pass, link pragma on to the rep item chain
19428 Record_Rep_Item (Def_Id, N);
19435 -- pragma Pure [(library_unit_NAME)];
19437 when Pragma_Pure => Pure : declare
19441 Check_Ada_83_Warning;
19443 -- If the pragma comes from a subprogram instantiation, nothing to
19444 -- check, this can happen at any level of nesting.
19446 if Is_Wrapper_Package (Current_Scope) then
19449 Check_Valid_Library_Unit_Pragma;
19452 if Nkind (N) = N_Null_Statement then
19456 Ent := Find_Lib_Unit_Name;
19458 -- A pragma that applies to a Ghost entity becomes Ghost for the
19459 -- purposes of legality checks and removal of ignored Ghost code.
19461 Mark_Pragma_As_Ghost (N, Ent);
19463 if not Debug_Flag_U then
19465 Set_Has_Pragma_Pure (Ent);
19466 Set_Suppress_Elaboration_Warnings (Ent);
19470 -------------------
19471 -- Pure_Function --
19472 -------------------
19474 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19476 when Pragma_Pure_Function => Pure_Function : declare
19477 Def_Id : Entity_Id;
19480 Effective : Boolean := False;
19484 Check_Arg_Count (1);
19485 Check_Optional_Identifier (Arg1, Name_Entity);
19486 Check_Arg_Is_Local_Name (Arg1);
19487 E_Id := Get_Pragma_Arg (Arg1);
19489 if Error_Posted (E_Id) then
19493 -- Loop through homonyms (overloadings) of referenced entity
19495 E := Entity (E_Id);
19497 -- A pragma that applies to a Ghost entity becomes Ghost for the
19498 -- purposes of legality checks and removal of ignored Ghost code.
19500 Mark_Pragma_As_Ghost (N, E);
19502 if Present (E) then
19504 Def_Id := Get_Base_Subprogram (E);
19506 if not Ekind_In (Def_Id, E_Function,
19507 E_Generic_Function,
19511 ("pragma% requires a function name", Arg1);
19514 Set_Is_Pure (Def_Id);
19516 if not Has_Pragma_Pure_Function (Def_Id) then
19517 Set_Has_Pragma_Pure_Function (Def_Id);
19521 exit when From_Aspect_Specification (N);
19523 exit when No (E) or else Scope (E) /= Current_Scope;
19527 and then Warn_On_Redundant_Constructs
19530 ("pragma Pure_Function on& is redundant?r?",
19536 --------------------
19537 -- Queuing_Policy --
19538 --------------------
19540 -- pragma Queuing_Policy (policy_IDENTIFIER);
19542 when Pragma_Queuing_Policy => declare
19546 Check_Ada_83_Warning;
19547 Check_Arg_Count (1);
19548 Check_No_Identifiers;
19549 Check_Arg_Is_Queuing_Policy (Arg1);
19550 Check_Valid_Configuration_Pragma;
19551 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19552 QP := Fold_Upper (Name_Buffer (1));
19554 if Queuing_Policy /= ' '
19555 and then Queuing_Policy /= QP
19557 Error_Msg_Sloc := Queuing_Policy_Sloc;
19558 Error_Pragma ("queuing policy incompatible with policy#");
19560 -- Set new policy, but always preserve System_Location since we
19561 -- like the error message with the run time name.
19564 Queuing_Policy := QP;
19566 if Queuing_Policy_Sloc /= System_Location then
19567 Queuing_Policy_Sloc := Loc;
19576 -- pragma Rational, for compatibility with foreign compiler
19578 when Pragma_Rational =>
19579 Set_Rational_Profile;
19581 ---------------------
19582 -- Refined_Depends --
19583 ---------------------
19585 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19587 -- DEPENDENCY_RELATION ::=
19589 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19591 -- DEPENDENCY_CLAUSE ::=
19592 -- OUTPUT_LIST =>[+] INPUT_LIST
19593 -- | NULL_DEPENDENCY_CLAUSE
19595 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19597 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19599 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19601 -- OUTPUT ::= NAME | FUNCTION_RESULT
19604 -- where FUNCTION_RESULT is a function Result attribute_reference
19606 -- Characteristics:
19608 -- * Analysis - The annotation undergoes initial checks to verify
19609 -- the legal placement and context. Secondary checks fully analyze
19610 -- the dependency clauses/global list in:
19612 -- Analyze_Refined_Depends_In_Decl_Part
19614 -- * Expansion - None.
19616 -- * Template - The annotation utilizes the generic template of the
19617 -- related subprogram body.
19619 -- * Globals - Capture of global references must occur after full
19622 -- * Instance - The annotation is instantiated automatically when
19623 -- the related generic subprogram body is instantiated.
19625 when Pragma_Refined_Depends => Refined_Depends : declare
19626 Body_Id : Entity_Id;
19628 Spec_Id : Entity_Id;
19631 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19635 -- Chain the pragma on the contract for further processing by
19636 -- Analyze_Refined_Depends_In_Decl_Part.
19638 Add_Contract_Item (N, Body_Id);
19640 -- The legality checks of pragmas Refined_Depends and
19641 -- Refined_Global are affected by the SPARK mode in effect and
19642 -- the volatility of the context. In addition these two pragmas
19643 -- are subject to an inherent order:
19645 -- 1) Refined_Global
19646 -- 2) Refined_Depends
19648 -- Analyze all these pragmas in the order outlined above
19650 Analyze_If_Present (Pragma_SPARK_Mode);
19651 Analyze_If_Present (Pragma_Volatile_Function);
19652 Analyze_If_Present (Pragma_Refined_Global);
19653 Analyze_Refined_Depends_In_Decl_Part (N);
19655 end Refined_Depends;
19657 --------------------
19658 -- Refined_Global --
19659 --------------------
19661 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19663 -- GLOBAL_SPECIFICATION ::=
19666 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
19668 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19670 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19671 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19672 -- GLOBAL_ITEM ::= NAME
19674 -- Characteristics:
19676 -- * Analysis - The annotation undergoes initial checks to verify
19677 -- the legal placement and context. Secondary checks fully analyze
19678 -- the dependency clauses/global list in:
19680 -- Analyze_Refined_Global_In_Decl_Part
19682 -- * Expansion - None.
19684 -- * Template - The annotation utilizes the generic template of the
19685 -- related subprogram body.
19687 -- * Globals - Capture of global references must occur after full
19690 -- * Instance - The annotation is instantiated automatically when
19691 -- the related generic subprogram body is instantiated.
19693 when Pragma_Refined_Global => Refined_Global : declare
19694 Body_Id : Entity_Id;
19696 Spec_Id : Entity_Id;
19699 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19703 -- Chain the pragma on the contract for further processing by
19704 -- Analyze_Refined_Global_In_Decl_Part.
19706 Add_Contract_Item (N, Body_Id);
19708 -- The legality checks of pragmas Refined_Depends and
19709 -- Refined_Global are affected by the SPARK mode in effect and
19710 -- the volatility of the context. In addition these two pragmas
19711 -- are subject to an inherent order:
19713 -- 1) Refined_Global
19714 -- 2) Refined_Depends
19716 -- Analyze all these pragmas in the order outlined above
19718 Analyze_If_Present (Pragma_SPARK_Mode);
19719 Analyze_If_Present (Pragma_Volatile_Function);
19720 Analyze_Refined_Global_In_Decl_Part (N);
19721 Analyze_If_Present (Pragma_Refined_Depends);
19723 end Refined_Global;
19729 -- pragma Refined_Post (boolean_EXPRESSION);
19731 -- Characteristics:
19733 -- * Analysis - The annotation is fully analyzed immediately upon
19734 -- elaboration as it cannot forward reference entities.
19736 -- * Expansion - The annotation is expanded during the expansion of
19737 -- the related subprogram body contract as performed in:
19739 -- Expand_Subprogram_Contract
19741 -- * Template - The annotation utilizes the generic template of the
19742 -- related subprogram body.
19744 -- * Globals - Capture of global references must occur after full
19747 -- * Instance - The annotation is instantiated automatically when
19748 -- the related generic subprogram body is instantiated.
19750 when Pragma_Refined_Post => Refined_Post : declare
19751 Body_Id : Entity_Id;
19753 Spec_Id : Entity_Id;
19756 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19758 -- Fully analyze the pragma when it appears inside a subprogram
19759 -- body because it cannot benefit from forward references.
19763 -- Chain the pragma on the contract for completeness
19765 Add_Contract_Item (N, Body_Id);
19767 -- The legality checks of pragma Refined_Post are affected by
19768 -- the SPARK mode in effect and the volatility of the context.
19769 -- Analyze all pragmas in a specific order.
19771 Analyze_If_Present (Pragma_SPARK_Mode);
19772 Analyze_If_Present (Pragma_Volatile_Function);
19773 Analyze_Pre_Post_Condition_In_Decl_Part (N);
19775 -- Currently it is not possible to inline pre/postconditions on
19776 -- a subprogram subject to pragma Inline_Always.
19778 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
19782 -------------------
19783 -- Refined_State --
19784 -------------------
19786 -- pragma Refined_State (REFINEMENT_LIST);
19788 -- REFINEMENT_LIST ::=
19789 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19791 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19793 -- CONSTITUENT_LIST ::=
19796 -- | (CONSTITUENT {, CONSTITUENT})
19798 -- CONSTITUENT ::= object_NAME | state_NAME
19800 -- Characteristics:
19802 -- * Analysis - The annotation undergoes initial checks to verify
19803 -- the legal placement and context. Secondary checks preanalyze the
19804 -- refinement clauses in:
19806 -- Analyze_Refined_State_In_Decl_Part
19808 -- * Expansion - None.
19810 -- * Template - The annotation utilizes the template of the related
19813 -- * Globals - Capture of global references must occur after full
19816 -- * Instance - The annotation is instantiated automatically when
19817 -- the related generic package body is instantiated.
19819 when Pragma_Refined_State => Refined_State : declare
19820 Pack_Decl : Node_Id;
19821 Spec_Id : Entity_Id;
19825 Check_No_Identifiers;
19826 Check_Arg_Count (1);
19828 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
19830 -- Ensure the proper placement of the pragma. Refined states must
19831 -- be associated with a package body.
19833 if Nkind (Pack_Decl) = N_Package_Body then
19836 -- Otherwise the pragma is associated with an illegal construct
19843 Spec_Id := Corresponding_Spec (Pack_Decl);
19845 -- Chain the pragma on the contract for further processing by
19846 -- Analyze_Refined_State_In_Decl_Part.
19848 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
19850 -- The legality checks of pragma Refined_State are affected by the
19851 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19853 Analyze_If_Present (Pragma_SPARK_Mode);
19855 -- A pragma that applies to a Ghost entity becomes Ghost for the
19856 -- purposes of legality checks and removal of ignored Ghost code.
19858 Mark_Pragma_As_Ghost (N, Spec_Id);
19860 -- State refinement is allowed only when the corresponding package
19861 -- declaration has non-null pragma Abstract_State. Refinement not
19862 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19864 if SPARK_Mode /= Off
19866 (No (Abstract_States (Spec_Id))
19867 or else Has_Null_Abstract_State (Spec_Id))
19870 ("useless refinement, package & does not define abstract "
19871 & "states", N, Spec_Id);
19876 -----------------------
19877 -- Relative_Deadline --
19878 -----------------------
19880 -- pragma Relative_Deadline (time_span_EXPRESSION);
19882 when Pragma_Relative_Deadline => Relative_Deadline : declare
19883 P : constant Node_Id := Parent (N);
19888 Check_No_Identifiers;
19889 Check_Arg_Count (1);
19891 Arg := Get_Pragma_Arg (Arg1);
19893 -- The expression must be analyzed in the special manner described
19894 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19896 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19900 if Nkind (P) = N_Subprogram_Body then
19901 Check_In_Main_Program;
19903 -- Only Task and subprogram cases allowed
19905 elsif Nkind (P) /= N_Task_Definition then
19909 -- Check duplicate pragma before we set the corresponding flag
19911 if Has_Relative_Deadline_Pragma (P) then
19912 Error_Pragma ("duplicate pragma% not allowed");
19915 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19916 -- Relative_Deadline pragma node cannot be inserted in the Rep
19917 -- Item chain of Ent since it is rewritten by the expander as a
19918 -- procedure call statement that will break the chain.
19920 Set_Has_Relative_Deadline_Pragma (P);
19921 end Relative_Deadline;
19923 ------------------------
19924 -- Remote_Access_Type --
19925 ------------------------
19927 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19929 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19934 Check_Arg_Count (1);
19935 Check_Optional_Identifier (Arg1, Name_Entity);
19936 Check_Arg_Is_Local_Name (Arg1);
19938 E := Entity (Get_Pragma_Arg (Arg1));
19940 -- A pragma that applies to a Ghost entity becomes Ghost for the
19941 -- purposes of legality checks and removal of ignored Ghost code.
19943 Mark_Pragma_As_Ghost (N, E);
19945 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19946 and then Ekind (E) = E_General_Access_Type
19947 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19948 and then Scope (Root_Type (Directly_Designated_Type (E)))
19950 and then Is_Valid_Remote_Object_Type
19951 (Root_Type (Directly_Designated_Type (E)))
19953 Set_Is_Remote_Types (E);
19957 ("pragma% applies only to formal access to classwide types",
19960 end Remote_Access_Type;
19962 ---------------------------
19963 -- Remote_Call_Interface --
19964 ---------------------------
19966 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19968 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19969 Cunit_Node : Node_Id;
19970 Cunit_Ent : Entity_Id;
19974 Check_Ada_83_Warning;
19975 Check_Valid_Library_Unit_Pragma;
19977 if Nkind (N) = N_Null_Statement then
19981 Cunit_Node := Cunit (Current_Sem_Unit);
19982 K := Nkind (Unit (Cunit_Node));
19983 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19985 -- A pragma that applies to a Ghost entity becomes Ghost for the
19986 -- purposes of legality checks and removal of ignored Ghost code.
19988 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19990 if K = N_Package_Declaration
19991 or else K = N_Generic_Package_Declaration
19992 or else K = N_Subprogram_Declaration
19993 or else K = N_Generic_Subprogram_Declaration
19994 or else (K = N_Subprogram_Body
19995 and then Acts_As_Spec (Unit (Cunit_Node)))
20000 "pragma% must apply to package or subprogram declaration");
20003 Set_Is_Remote_Call_Interface (Cunit_Ent);
20004 end Remote_Call_Interface;
20010 -- pragma Remote_Types [(library_unit_NAME)];
20012 when Pragma_Remote_Types => Remote_Types : declare
20013 Cunit_Node : Node_Id;
20014 Cunit_Ent : Entity_Id;
20017 Check_Ada_83_Warning;
20018 Check_Valid_Library_Unit_Pragma;
20020 if Nkind (N) = N_Null_Statement then
20024 Cunit_Node := Cunit (Current_Sem_Unit);
20025 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20027 -- A pragma that applies to a Ghost entity becomes Ghost for the
20028 -- purposes of legality checks and removal of ignored Ghost code.
20030 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20032 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20033 N_Generic_Package_Declaration)
20036 ("pragma% can only apply to a package declaration");
20039 Set_Is_Remote_Types (Cunit_Ent);
20046 -- pragma Ravenscar;
20048 when Pragma_Ravenscar =>
20050 Check_Arg_Count (0);
20051 Check_Valid_Configuration_Pragma;
20052 Set_Ravenscar_Profile (Ravenscar, N);
20054 if Warn_On_Obsolescent_Feature then
20056 ("pragma Ravenscar is an obsolescent feature?j?", N);
20058 ("|use pragma Profile (Ravenscar) instead?j?", N);
20061 -------------------------
20062 -- Restricted_Run_Time --
20063 -------------------------
20065 -- pragma Restricted_Run_Time;
20067 when Pragma_Restricted_Run_Time =>
20069 Check_Arg_Count (0);
20070 Check_Valid_Configuration_Pragma;
20071 Set_Profile_Restrictions
20072 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20074 if Warn_On_Obsolescent_Feature then
20076 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20079 ("|use pragma Profile (Restricted) instead?j?", N);
20086 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20089 -- restriction_IDENTIFIER
20090 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20092 when Pragma_Restrictions =>
20093 Process_Restrictions_Or_Restriction_Warnings
20094 (Warn => Treat_Restrictions_As_Warnings);
20096 --------------------------
20097 -- Restriction_Warnings --
20098 --------------------------
20100 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20103 -- restriction_IDENTIFIER
20104 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20106 when Pragma_Restriction_Warnings =>
20108 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20114 -- pragma Reviewable;
20116 when Pragma_Reviewable =>
20117 Check_Ada_83_Warning;
20118 Check_Arg_Count (0);
20120 -- Call dummy debugging function rv. This is done to assist front
20121 -- end debugging. By placing a Reviewable pragma in the source
20122 -- program, a breakpoint on rv catches this place in the source,
20123 -- allowing convenient stepping to the point of interest.
20127 --------------------------
20128 -- Short_Circuit_And_Or --
20129 --------------------------
20131 -- pragma Short_Circuit_And_Or;
20133 when Pragma_Short_Circuit_And_Or =>
20135 Check_Arg_Count (0);
20136 Check_Valid_Configuration_Pragma;
20137 Short_Circuit_And_Or := True;
20139 -------------------
20140 -- Share_Generic --
20141 -------------------
20143 -- pragma Share_Generic (GNAME {, GNAME});
20145 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20147 when Pragma_Share_Generic =>
20149 Process_Generic_List;
20155 -- pragma Shared (LOCAL_NAME);
20157 when Pragma_Shared =>
20159 Process_Atomic_Independent_Shared_Volatile;
20161 --------------------
20162 -- Shared_Passive --
20163 --------------------
20165 -- pragma Shared_Passive [(library_unit_NAME)];
20167 -- Set the flag Is_Shared_Passive of program unit name entity
20169 when Pragma_Shared_Passive => Shared_Passive : declare
20170 Cunit_Node : Node_Id;
20171 Cunit_Ent : Entity_Id;
20174 Check_Ada_83_Warning;
20175 Check_Valid_Library_Unit_Pragma;
20177 if Nkind (N) = N_Null_Statement then
20181 Cunit_Node := Cunit (Current_Sem_Unit);
20182 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20184 -- A pragma that applies to a Ghost entity becomes Ghost for the
20185 -- purposes of legality checks and removal of ignored Ghost code.
20187 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20189 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20190 N_Generic_Package_Declaration)
20193 ("pragma% can only apply to a package declaration");
20196 Set_Is_Shared_Passive (Cunit_Ent);
20197 end Shared_Passive;
20199 -----------------------
20200 -- Short_Descriptors --
20201 -----------------------
20203 -- pragma Short_Descriptors;
20205 -- Recognize and validate, but otherwise ignore
20207 when Pragma_Short_Descriptors =>
20209 Check_Arg_Count (0);
20210 Check_Valid_Configuration_Pragma;
20212 ------------------------------
20213 -- Simple_Storage_Pool_Type --
20214 ------------------------------
20216 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20218 when Pragma_Simple_Storage_Pool_Type =>
20219 Simple_Storage_Pool_Type : declare
20225 Check_Arg_Count (1);
20226 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20228 Type_Id := Get_Pragma_Arg (Arg1);
20229 Find_Type (Type_Id);
20230 Typ := Entity (Type_Id);
20232 if Typ = Any_Type then
20236 -- A pragma that applies to a Ghost entity becomes Ghost for the
20237 -- purposes of legality checks and removal of ignored Ghost code.
20239 Mark_Pragma_As_Ghost (N, Typ);
20241 -- We require the pragma to apply to a type declared in a package
20242 -- declaration, but not (immediately) within a package body.
20244 if Ekind (Current_Scope) /= E_Package
20245 or else In_Package_Body (Current_Scope)
20248 ("pragma% can only apply to type declared immediately "
20249 & "within a package declaration");
20252 -- A simple storage pool type must be an immutably limited record
20253 -- or private type. If the pragma is given for a private type,
20254 -- the full type is similarly restricted (which is checked later
20255 -- in Freeze_Entity).
20257 if Is_Record_Type (Typ)
20258 and then not Is_Limited_View (Typ)
20261 ("pragma% can only apply to explicitly limited record type");
20263 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20265 ("pragma% can only apply to a private type that is limited");
20267 elsif not Is_Record_Type (Typ)
20268 and then not Is_Private_Type (Typ)
20271 ("pragma% can only apply to limited record or private type");
20274 Record_Rep_Item (Typ, N);
20275 end Simple_Storage_Pool_Type;
20277 ----------------------
20278 -- Source_File_Name --
20279 ----------------------
20281 -- There are five forms for this pragma:
20283 -- pragma Source_File_Name (
20284 -- [UNIT_NAME =>] unit_NAME,
20285 -- BODY_FILE_NAME => STRING_LITERAL
20286 -- [, [INDEX =>] INTEGER_LITERAL]);
20288 -- pragma Source_File_Name (
20289 -- [UNIT_NAME =>] unit_NAME,
20290 -- SPEC_FILE_NAME => STRING_LITERAL
20291 -- [, [INDEX =>] INTEGER_LITERAL]);
20293 -- pragma Source_File_Name (
20294 -- BODY_FILE_NAME => STRING_LITERAL
20295 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20296 -- [, CASING => CASING_SPEC]);
20298 -- pragma Source_File_Name (
20299 -- SPEC_FILE_NAME => STRING_LITERAL
20300 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20301 -- [, CASING => CASING_SPEC]);
20303 -- pragma Source_File_Name (
20304 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20305 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20306 -- [, CASING => CASING_SPEC]);
20308 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20310 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20311 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20312 -- only be used when no project file is used, while SFNP can only be
20313 -- used when a project file is used.
20315 -- No processing here. Processing was completed during parsing, since
20316 -- we need to have file names set as early as possible. Units are
20317 -- loaded well before semantic processing starts.
20319 -- The only processing we defer to this point is the check for
20320 -- correct placement.
20322 when Pragma_Source_File_Name =>
20324 Check_Valid_Configuration_Pragma;
20326 ------------------------------
20327 -- Source_File_Name_Project --
20328 ------------------------------
20330 -- See Source_File_Name for syntax
20332 -- No processing here. Processing was completed during parsing, since
20333 -- we need to have file names set as early as possible. Units are
20334 -- loaded well before semantic processing starts.
20336 -- The only processing we defer to this point is the check for
20337 -- correct placement.
20339 when Pragma_Source_File_Name_Project =>
20341 Check_Valid_Configuration_Pragma;
20343 -- Check that a pragma Source_File_Name_Project is used only in a
20344 -- configuration pragmas file.
20346 -- Pragmas Source_File_Name_Project should only be generated by
20347 -- the Project Manager in configuration pragmas files.
20349 -- This is really an ugly test. It seems to depend on some
20350 -- accidental and undocumented property. At the very least it
20351 -- needs to be documented, but it would be better to have a
20352 -- clean way of testing if we are in a configuration file???
20354 if Present (Parent (N)) then
20356 ("pragma% can only appear in a configuration pragmas file");
20359 ----------------------
20360 -- Source_Reference --
20361 ----------------------
20363 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20365 -- Nothing to do, all processing completed in Par.Prag, since we need
20366 -- the information for possible parser messages that are output.
20368 when Pragma_Source_Reference =>
20375 -- pragma SPARK_Mode [(On | Off)];
20377 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20378 Mode_Id : SPARK_Mode_Type;
20380 procedure Check_Pragma_Conformance
20381 (Context_Pragma : Node_Id;
20382 Entity : Entity_Id;
20383 Entity_Pragma : Node_Id);
20384 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20385 -- conformance of pragma N depending the following scenarios:
20387 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20388 -- compatible with the pragma Context_Pragma that was inherited
20389 -- from the context:
20390 -- * If the mode of Context_Pragma is ON, then the new mode can
20392 -- * If the mode of Context_Pragma is OFF, then the only allowed
20393 -- new mode is also OFF. Emit error if this is not the case.
20395 -- If Entity is not Empty, verify that pragma N is compatible with
20396 -- pragma Entity_Pragma that belongs to Entity.
20397 -- * If Entity_Pragma is Empty, always issue an error as this
20398 -- corresponds to the case where a previous section of Entity
20399 -- has no SPARK_Mode set.
20400 -- * If the mode of Entity_Pragma is ON, then the new mode can
20402 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20403 -- new mode is also OFF. Emit error if this is not the case.
20405 procedure Check_Library_Level_Entity (E : Entity_Id);
20406 -- Subsidiary to routines Process_xxx. Verify that the related
20407 -- entity E subject to pragma SPARK_Mode is library-level.
20409 procedure Process_Body (Decl : Node_Id);
20410 -- Verify the legality of pragma SPARK_Mode when it appears as the
20411 -- top of the body declarations of entry, package, protected unit,
20412 -- subprogram or task unit body denoted by Decl.
20414 procedure Process_Overloadable (Decl : Node_Id);
20415 -- Verify the legality of pragma SPARK_Mode when it applies to an
20416 -- entry or [generic] subprogram declaration denoted by Decl.
20418 procedure Process_Private_Part (Decl : Node_Id);
20419 -- Verify the legality of pragma SPARK_Mode when it appears at the
20420 -- top of the private declarations of a package spec, protected or
20421 -- task unit declaration denoted by Decl.
20423 procedure Process_Statement_Part (Decl : Node_Id);
20424 -- Verify the legality of pragma SPARK_Mode when it appears at the
20425 -- top of the statement sequence of a package body denoted by node
20428 procedure Process_Visible_Part (Decl : Node_Id);
20429 -- Verify the legality of pragma SPARK_Mode when it appears at the
20430 -- top of the visible declarations of a package spec, protected or
20431 -- task unit declaration denoted by Decl. The routine is also used
20432 -- on protected or task units declared without a definition.
20434 procedure Set_SPARK_Context;
20435 -- Subsidiary to routines Process_xxx. Set the global variables
20436 -- which represent the mode of the context from pragma N. Ensure
20437 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20439 ------------------------------
20440 -- Check_Pragma_Conformance --
20441 ------------------------------
20443 procedure Check_Pragma_Conformance
20444 (Context_Pragma : Node_Id;
20445 Entity : Entity_Id;
20446 Entity_Pragma : Node_Id)
20448 Err_Id : Entity_Id;
20452 -- The current pragma may appear without an argument. If this
20453 -- is the case, associate all error messages with the pragma
20456 if Present (Arg1) then
20462 -- The mode of the current pragma is compared against that of
20463 -- an enclosing context.
20465 if Present (Context_Pragma) then
20466 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20468 -- Issue an error if the new mode is less restrictive than
20469 -- that of the context.
20471 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20472 and then Get_SPARK_Mode_From_Annotation (N) = On
20475 ("cannot change SPARK_Mode from Off to On", Err_N);
20476 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20477 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20482 -- The mode of the current pragma is compared against that of
20483 -- an initial package, protected type, subprogram or task type
20486 if Present (Entity) then
20488 -- A simple protected or task type is transformed into an
20489 -- anonymous type whose name cannot be used to issue error
20490 -- messages. Recover the original entity of the type.
20492 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20495 (Original_Node (Unit_Declaration_Node (Entity)));
20500 -- Both the initial declaration and the completion carry
20501 -- SPARK_Mode pragmas.
20503 if Present (Entity_Pragma) then
20504 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20506 -- Issue an error if the new mode is less restrictive
20507 -- than that of the initial declaration.
20509 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20510 and then Get_SPARK_Mode_From_Annotation (N) = On
20512 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20513 Error_Msg_Sloc := Sloc (Entity_Pragma);
20515 ("\value Off was set for SPARK_Mode on&#",
20520 -- Otherwise the initial declaration lacks a SPARK_Mode
20521 -- pragma in which case the current pragma is illegal as
20522 -- it cannot "complete".
20525 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20526 Error_Msg_Sloc := Sloc (Err_Id);
20528 ("\no value was set for SPARK_Mode on&#",
20533 end Check_Pragma_Conformance;
20535 --------------------------------
20536 -- Check_Library_Level_Entity --
20537 --------------------------------
20539 procedure Check_Library_Level_Entity (E : Entity_Id) is
20540 procedure Add_Entity_To_Name_Buffer;
20541 -- Add the E_Kind of entity E to the name buffer
20543 -------------------------------
20544 -- Add_Entity_To_Name_Buffer --
20545 -------------------------------
20547 procedure Add_Entity_To_Name_Buffer is
20549 if Ekind_In (E, E_Entry, E_Entry_Family) then
20550 Add_Str_To_Name_Buffer ("entry");
20552 elsif Ekind_In (E, E_Generic_Package,
20556 Add_Str_To_Name_Buffer ("package");
20558 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20559 Add_Str_To_Name_Buffer ("protected type");
20561 elsif Ekind_In (E, E_Function,
20562 E_Generic_Function,
20563 E_Generic_Procedure,
20567 Add_Str_To_Name_Buffer ("subprogram");
20570 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20571 Add_Str_To_Name_Buffer ("task type");
20573 end Add_Entity_To_Name_Buffer;
20577 Msg_1 : constant String := "incorrect placement of pragma%";
20580 -- Start of processing for Check_Library_Level_Entity
20583 if not Is_Library_Level_Entity (E) then
20584 Error_Msg_Name_1 := Pname;
20585 Error_Msg_N (Fix_Error (Msg_1), N);
20588 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20589 Add_Entity_To_Name_Buffer;
20591 Msg_2 := Name_Find;
20592 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20596 end Check_Library_Level_Entity;
20602 procedure Process_Body (Decl : Node_Id) is
20603 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20604 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20607 -- Ignore pragma when applied to the special body created for
20608 -- inlining, recognized by its internal name _Parent.
20610 if Chars (Body_Id) = Name_uParent then
20614 Check_Library_Level_Entity (Body_Id);
20616 -- For entry bodies, verify the legality against:
20617 -- * The mode of the context
20618 -- * The mode of the spec (if any)
20620 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20622 -- A stand alone subprogram body
20624 if Body_Id = Spec_Id then
20625 Check_Pragma_Conformance
20626 (Context_Pragma => SPARK_Pragma (Body_Id),
20628 Entity_Pragma => Empty);
20630 -- An entry or subprogram body that completes a previous
20634 Check_Pragma_Conformance
20635 (Context_Pragma => SPARK_Pragma (Body_Id),
20637 Entity_Pragma => SPARK_Pragma (Spec_Id));
20641 Set_SPARK_Pragma (Body_Id, N);
20642 Set_SPARK_Pragma_Inherited (Body_Id, False);
20644 -- For package bodies, verify the legality against:
20645 -- * The mode of the context
20646 -- * The mode of the private part
20648 -- This case is separated from protected and task bodies
20649 -- because the statement part of the package body inherits
20650 -- the mode of the body declarations.
20652 elsif Nkind (Decl) = N_Package_Body then
20653 Check_Pragma_Conformance
20654 (Context_Pragma => SPARK_Pragma (Body_Id),
20656 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20659 Set_SPARK_Pragma (Body_Id, N);
20660 Set_SPARK_Pragma_Inherited (Body_Id, False);
20661 Set_SPARK_Aux_Pragma (Body_Id, N);
20662 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20664 -- For protected and task bodies, verify the legality against:
20665 -- * The mode of the context
20666 -- * The mode of the private part
20670 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
20672 Check_Pragma_Conformance
20673 (Context_Pragma => SPARK_Pragma (Body_Id),
20675 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20678 Set_SPARK_Pragma (Body_Id, N);
20679 Set_SPARK_Pragma_Inherited (Body_Id, False);
20683 --------------------------
20684 -- Process_Overloadable --
20685 --------------------------
20687 procedure Process_Overloadable (Decl : Node_Id) is
20688 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20689 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
20692 Check_Library_Level_Entity (Spec_Id);
20694 -- Verify the legality against:
20695 -- * The mode of the context
20697 Check_Pragma_Conformance
20698 (Context_Pragma => SPARK_Pragma (Spec_Id),
20700 Entity_Pragma => Empty);
20702 Set_SPARK_Pragma (Spec_Id, N);
20703 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20705 -- When the pragma applies to the anonymous object created for
20706 -- a single task type, decorate the type as well. This scenario
20707 -- arises when the single task type lacks a task definition,
20708 -- therefore there is no issue with respect to a potential
20709 -- pragma SPARK_Mode in the private part.
20711 -- task type Anon_Task_Typ;
20712 -- Obj : Anon_Task_Typ;
20713 -- pragma SPARK_Mode ...;
20715 if Is_Single_Task_Object (Spec_Id) then
20716 Set_SPARK_Pragma (Spec_Typ, N);
20717 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
20718 Set_SPARK_Aux_Pragma (Spec_Typ, N);
20719 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
20721 end Process_Overloadable;
20723 --------------------------
20724 -- Process_Private_Part --
20725 --------------------------
20727 procedure Process_Private_Part (Decl : Node_Id) is
20728 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20731 Check_Library_Level_Entity (Spec_Id);
20733 -- Verify the legality against:
20734 -- * The mode of the visible declarations
20736 Check_Pragma_Conformance
20737 (Context_Pragma => Empty,
20739 Entity_Pragma => SPARK_Pragma (Spec_Id));
20742 Set_SPARK_Aux_Pragma (Spec_Id, N);
20743 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
20744 end Process_Private_Part;
20746 ----------------------------
20747 -- Process_Statement_Part --
20748 ----------------------------
20750 procedure Process_Statement_Part (Decl : Node_Id) is
20751 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20754 Check_Library_Level_Entity (Body_Id);
20756 -- Verify the legality against:
20757 -- * The mode of the body declarations
20759 Check_Pragma_Conformance
20760 (Context_Pragma => Empty,
20762 Entity_Pragma => SPARK_Pragma (Body_Id));
20765 Set_SPARK_Aux_Pragma (Body_Id, N);
20766 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20767 end Process_Statement_Part;
20769 --------------------------
20770 -- Process_Visible_Part --
20771 --------------------------
20773 procedure Process_Visible_Part (Decl : Node_Id) is
20774 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20775 Obj_Id : Entity_Id;
20778 Check_Library_Level_Entity (Spec_Id);
20780 -- Verify the legality against:
20781 -- * The mode of the context
20783 Check_Pragma_Conformance
20784 (Context_Pragma => SPARK_Pragma (Spec_Id),
20786 Entity_Pragma => Empty);
20788 -- A task unit declared without a definition does not set the
20789 -- SPARK_Mode of the context because the task does not have any
20790 -- entries that could inherit the mode.
20792 if not Nkind_In (Decl, N_Single_Task_Declaration,
20793 N_Task_Type_Declaration)
20798 Set_SPARK_Pragma (Spec_Id, N);
20799 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20800 Set_SPARK_Aux_Pragma (Spec_Id, N);
20801 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20803 -- When the pragma applies to a single protected or task type,
20804 -- decorate the corresponding anonymous object as well.
20806 -- protected Anon_Prot_Typ is
20807 -- pragma SPARK_Mode ...;
20809 -- end Anon_Prot_Typ;
20811 -- Obj : Anon_Prot_Typ;
20813 if Is_Single_Concurrent_Type (Spec_Id) then
20814 Obj_Id := Anonymous_Object (Spec_Id);
20816 Set_SPARK_Pragma (Obj_Id, N);
20817 Set_SPARK_Pragma_Inherited (Obj_Id, False);
20819 end Process_Visible_Part;
20821 -----------------------
20822 -- Set_SPARK_Context --
20823 -----------------------
20825 procedure Set_SPARK_Context is
20827 SPARK_Mode := Mode_Id;
20828 SPARK_Mode_Pragma := N;
20830 if SPARK_Mode = On then
20831 Dynamic_Elaboration_Checks := False;
20833 end Set_SPARK_Context;
20841 -- Start of processing for Do_SPARK_Mode
20844 -- When a SPARK_Mode pragma appears inside an instantiation whose
20845 -- enclosing context has SPARK_Mode set to "off", the pragma has
20846 -- no semantic effect.
20848 if Ignore_Pragma_SPARK_Mode then
20849 Rewrite (N, Make_Null_Statement (Loc));
20855 Check_No_Identifiers;
20856 Check_At_Most_N_Arguments (1);
20858 -- Check the legality of the mode (no argument = ON)
20860 if Arg_Count = 1 then
20861 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20862 Mode := Chars (Get_Pragma_Arg (Arg1));
20867 Mode_Id := Get_SPARK_Mode_Type (Mode);
20868 Context := Parent (N);
20870 -- The pragma appears in a configuration pragmas file
20872 if No (Context) then
20873 Check_Valid_Configuration_Pragma;
20875 if Present (SPARK_Mode_Pragma) then
20876 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20877 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20883 -- The pragma acts as a configuration pragma in a compilation unit
20885 -- pragma SPARK_Mode ...;
20886 -- package Pack is ...;
20888 elsif Nkind (Context) = N_Compilation_Unit
20889 and then List_Containing (N) = Context_Items (Context)
20891 Check_Valid_Configuration_Pragma;
20894 -- Otherwise the placement of the pragma within the tree dictates
20895 -- its associated construct. Inspect the declarative list where
20896 -- the pragma resides to find a potential construct.
20900 while Present (Stmt) loop
20902 -- Skip prior pragmas, but check for duplicates. Note that
20903 -- this also takes care of pragmas generated for aspects.
20905 if Nkind (Stmt) = N_Pragma then
20906 if Pragma_Name (Stmt) = Pname then
20907 Error_Msg_Name_1 := Pname;
20908 Error_Msg_Sloc := Sloc (Stmt);
20909 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20913 -- The pragma applies to an expression function that has
20914 -- already been rewritten into a subprogram declaration.
20916 -- function Expr_Func return ... is (...);
20917 -- pragma SPARK_Mode ...;
20919 elsif Nkind (Stmt) = N_Subprogram_Declaration
20920 and then Nkind (Original_Node (Stmt)) =
20921 N_Expression_Function
20923 Process_Overloadable (Stmt);
20926 -- The pragma applies to the anonymous object created for a
20927 -- single concurrent type.
20929 -- protected type Anon_Prot_Typ ...;
20930 -- Obj : Anon_Prot_Typ;
20931 -- pragma SPARK_Mode ...;
20933 elsif Nkind (Stmt) = N_Object_Declaration
20934 and then Is_Single_Concurrent_Object
20935 (Defining_Entity (Stmt))
20937 Process_Overloadable (Stmt);
20940 -- Skip internally generated code
20942 elsif not Comes_From_Source (Stmt) then
20945 -- The pragma applies to an entry or [generic] subprogram
20949 -- pragma SPARK_Mode ...;
20952 -- procedure Proc ...;
20953 -- pragma SPARK_Mode ...;
20955 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
20956 N_Subprogram_Declaration)
20957 or else (Nkind (Stmt) = N_Entry_Declaration
20958 and then Is_Protected_Type
20959 (Scope (Defining_Entity (Stmt))))
20961 Process_Overloadable (Stmt);
20964 -- Otherwise the pragma does not apply to a legal construct
20965 -- or it does not appear at the top of a declarative or a
20966 -- statement list. Issue an error and stop the analysis.
20976 -- The pragma applies to a package or a subprogram that acts as
20977 -- a compilation unit.
20979 -- procedure Proc ...;
20980 -- pragma SPARK_Mode ...;
20982 if Nkind (Context) = N_Compilation_Unit_Aux then
20983 Context := Unit (Parent (Context));
20986 -- The pragma appears at the top of entry, package, protected
20987 -- unit, subprogram or task unit body declarations.
20989 -- entry Ent when ... is
20990 -- pragma SPARK_Mode ...;
20992 -- package body Pack is
20993 -- pragma SPARK_Mode ...;
20995 -- procedure Proc ... is
20996 -- pragma SPARK_Mode;
20998 -- protected body Prot is
20999 -- pragma SPARK_Mode ...;
21001 if Nkind_In (Context, N_Entry_Body,
21007 Process_Body (Context);
21009 -- The pragma appears at the top of the visible or private
21010 -- declaration of a package spec, protected or task unit.
21013 -- pragma SPARK_Mode ...;
21015 -- pragma SPARK_Mode ...;
21017 -- protected [type] Prot is
21018 -- pragma SPARK_Mode ...;
21020 -- pragma SPARK_Mode ...;
21022 elsif Nkind_In (Context, N_Package_Specification,
21023 N_Protected_Definition,
21026 if List_Containing (N) = Visible_Declarations (Context) then
21027 Process_Visible_Part (Parent (Context));
21029 Process_Private_Part (Parent (Context));
21032 -- The pragma appears at the top of package body statements
21034 -- package body Pack is
21036 -- pragma SPARK_Mode;
21038 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21039 and then Nkind (Parent (Context)) = N_Package_Body
21041 Process_Statement_Part (Parent (Context));
21043 -- The pragma appeared as an aspect of a [generic] subprogram
21044 -- declaration that acts as a compilation unit.
21047 -- procedure Proc ...;
21048 -- pragma SPARK_Mode ...;
21050 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21051 N_Subprogram_Declaration)
21053 Process_Overloadable (Context);
21055 -- The pragma does not apply to a legal construct, issue error
21063 --------------------------------
21064 -- Static_Elaboration_Desired --
21065 --------------------------------
21067 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21069 when Pragma_Static_Elaboration_Desired =>
21071 Check_At_Most_N_Arguments (1);
21073 if Is_Compilation_Unit (Current_Scope)
21074 and then Ekind (Current_Scope) = E_Package
21076 Set_Static_Elaboration_Desired (Current_Scope, True);
21078 Error_Pragma ("pragma% must apply to a library-level package");
21085 -- pragma Storage_Size (EXPRESSION);
21087 when Pragma_Storage_Size => Storage_Size : declare
21088 P : constant Node_Id := Parent (N);
21092 Check_No_Identifiers;
21093 Check_Arg_Count (1);
21095 -- The expression must be analyzed in the special manner described
21096 -- in "Handling of Default Expressions" in sem.ads.
21098 Arg := Get_Pragma_Arg (Arg1);
21099 Preanalyze_Spec_Expression (Arg, Any_Integer);
21101 if not Is_OK_Static_Expression (Arg) then
21102 Check_Restriction (Static_Storage_Size, Arg);
21105 if Nkind (P) /= N_Task_Definition then
21110 if Has_Storage_Size_Pragma (P) then
21111 Error_Pragma ("duplicate pragma% not allowed");
21113 Set_Has_Storage_Size_Pragma (P, True);
21116 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21124 -- pragma Storage_Unit (NUMERIC_LITERAL);
21126 -- Only permitted argument is System'Storage_Unit value
21128 when Pragma_Storage_Unit =>
21129 Check_No_Identifiers;
21130 Check_Arg_Count (1);
21131 Check_Arg_Is_Integer_Literal (Arg1);
21133 if Intval (Get_Pragma_Arg (Arg1)) /=
21134 UI_From_Int (Ttypes.System_Storage_Unit)
21136 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21138 ("the only allowed argument for pragma% is ^", Arg1);
21141 --------------------
21142 -- Stream_Convert --
21143 --------------------
21145 -- pragma Stream_Convert (
21146 -- [Entity =>] type_LOCAL_NAME,
21147 -- [Read =>] function_NAME,
21148 -- [Write =>] function NAME);
21150 when Pragma_Stream_Convert => Stream_Convert : declare
21152 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21153 -- Check that the given argument is the name of a local function
21154 -- of one argument that is not overloaded earlier in the current
21155 -- local scope. A check is also made that the argument is a
21156 -- function with one parameter.
21158 --------------------------------------
21159 -- Check_OK_Stream_Convert_Function --
21160 --------------------------------------
21162 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21166 Check_Arg_Is_Local_Name (Arg);
21167 Ent := Entity (Get_Pragma_Arg (Arg));
21169 if Has_Homonym (Ent) then
21171 ("argument for pragma% may not be overloaded", Arg);
21174 if Ekind (Ent) /= E_Function
21175 or else No (First_Formal (Ent))
21176 or else Present (Next_Formal (First_Formal (Ent)))
21179 ("argument for pragma% must be function of one argument",
21182 end Check_OK_Stream_Convert_Function;
21184 -- Start of processing for Stream_Convert
21188 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21189 Check_Arg_Count (3);
21190 Check_Optional_Identifier (Arg1, Name_Entity);
21191 Check_Optional_Identifier (Arg2, Name_Read);
21192 Check_Optional_Identifier (Arg3, Name_Write);
21193 Check_Arg_Is_Local_Name (Arg1);
21194 Check_OK_Stream_Convert_Function (Arg2);
21195 Check_OK_Stream_Convert_Function (Arg3);
21198 Typ : constant Entity_Id :=
21199 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21200 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21201 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21204 Check_First_Subtype (Arg1);
21206 -- Check for too early or too late. Note that we don't enforce
21207 -- the rule about primitive operations in this case, since, as
21208 -- is the case for explicit stream attributes themselves, these
21209 -- restrictions are not appropriate. Note that the chaining of
21210 -- the pragma by Rep_Item_Too_Late is actually the critical
21211 -- processing done for this pragma.
21213 if Rep_Item_Too_Early (Typ, N)
21215 Rep_Item_Too_Late (Typ, N, FOnly => True)
21220 -- Return if previous error
21222 if Etype (Typ) = Any_Type
21224 Etype (Read) = Any_Type
21226 Etype (Write) = Any_Type
21233 if Underlying_Type (Etype (Read)) /= Typ then
21235 ("incorrect return type for function&", Arg2);
21238 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21240 ("incorrect parameter type for function&", Arg3);
21243 if Underlying_Type (Etype (First_Formal (Read))) /=
21244 Underlying_Type (Etype (Write))
21247 ("result type of & does not match Read parameter type",
21251 end Stream_Convert;
21257 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21259 -- This is processed by the parser since some of the style checks
21260 -- take place during source scanning and parsing. This means that
21261 -- we don't need to issue error messages here.
21263 when Pragma_Style_Checks => Style_Checks : declare
21264 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21270 Check_No_Identifiers;
21272 -- Two argument form
21274 if Arg_Count = 2 then
21275 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21282 E_Id := Get_Pragma_Arg (Arg2);
21285 if not Is_Entity_Name (E_Id) then
21287 ("second argument of pragma% must be entity name",
21291 E := Entity (E_Id);
21293 if not Ignore_Style_Checks_Pragmas then
21298 Set_Suppress_Style_Checks
21299 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21300 exit when No (Homonym (E));
21307 -- One argument form
21310 Check_Arg_Count (1);
21312 if Nkind (A) = N_String_Literal then
21316 Slen : constant Natural := Natural (String_Length (S));
21317 Options : String (1 .. Slen);
21323 C := Get_String_Char (S, Pos (J));
21324 exit when not In_Character_Range (C);
21325 Options (J) := Get_Character (C);
21327 -- If at end of string, set options. As per discussion
21328 -- above, no need to check for errors, since we issued
21329 -- them in the parser.
21332 if not Ignore_Style_Checks_Pragmas then
21333 Set_Style_Check_Options (Options);
21343 elsif Nkind (A) = N_Identifier then
21344 if Chars (A) = Name_All_Checks then
21345 if not Ignore_Style_Checks_Pragmas then
21347 Set_GNAT_Style_Check_Options;
21349 Set_Default_Style_Check_Options;
21353 elsif Chars (A) = Name_On then
21354 if not Ignore_Style_Checks_Pragmas then
21355 Style_Check := True;
21358 elsif Chars (A) = Name_Off then
21359 if not Ignore_Style_Checks_Pragmas then
21360 Style_Check := False;
21371 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21373 when Pragma_Subtitle =>
21375 Check_Arg_Count (1);
21376 Check_Optional_Identifier (Arg1, Name_Subtitle);
21377 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21384 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21386 when Pragma_Suppress =>
21387 Process_Suppress_Unsuppress (Suppress_Case => True);
21393 -- pragma Suppress_All;
21395 -- The only check made here is that the pragma has no arguments.
21396 -- There are no placement rules, and the processing required (setting
21397 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21398 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21399 -- then creates and inserts a pragma Suppress (All_Checks).
21401 when Pragma_Suppress_All =>
21403 Check_Arg_Count (0);
21405 -------------------------
21406 -- Suppress_Debug_Info --
21407 -------------------------
21409 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21411 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21412 Nam_Id : Entity_Id;
21416 Check_Arg_Count (1);
21417 Check_Optional_Identifier (Arg1, Name_Entity);
21418 Check_Arg_Is_Local_Name (Arg1);
21420 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21422 -- A pragma that applies to a Ghost entity becomes Ghost for the
21423 -- purposes of legality checks and removal of ignored Ghost code.
21425 Mark_Pragma_As_Ghost (N, Nam_Id);
21426 Set_Debug_Info_Off (Nam_Id);
21427 end Suppress_Debug_Info;
21429 ----------------------------------
21430 -- Suppress_Exception_Locations --
21431 ----------------------------------
21433 -- pragma Suppress_Exception_Locations;
21435 when Pragma_Suppress_Exception_Locations =>
21437 Check_Arg_Count (0);
21438 Check_Valid_Configuration_Pragma;
21439 Exception_Locations_Suppressed := True;
21441 -----------------------------
21442 -- Suppress_Initialization --
21443 -----------------------------
21445 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21447 when Pragma_Suppress_Initialization => Suppress_Init : declare
21453 Check_Arg_Count (1);
21454 Check_Optional_Identifier (Arg1, Name_Entity);
21455 Check_Arg_Is_Local_Name (Arg1);
21457 E_Id := Get_Pragma_Arg (Arg1);
21459 if Etype (E_Id) = Any_Type then
21463 E := Entity (E_Id);
21465 -- A pragma that applies to a Ghost entity becomes Ghost for the
21466 -- purposes of legality checks and removal of ignored Ghost code.
21468 Mark_Pragma_As_Ghost (N, E);
21470 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21472 ("pragma% requires variable, type or subtype", Arg1);
21475 if Rep_Item_Too_Early (E, N)
21477 Rep_Item_Too_Late (E, N, FOnly => True)
21482 -- For incomplete/private type, set flag on full view
21484 if Is_Incomplete_Or_Private_Type (E) then
21485 if No (Full_View (Base_Type (E))) then
21487 ("argument of pragma% cannot be an incomplete type", Arg1);
21489 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21492 -- For first subtype, set flag on base type
21494 elsif Is_First_Subtype (E) then
21495 Set_Suppress_Initialization (Base_Type (E));
21497 -- For other than first subtype, set flag on subtype or variable
21500 Set_Suppress_Initialization (E);
21508 -- pragma System_Name (DIRECT_NAME);
21510 -- Syntax check: one argument, which must be the identifier GNAT or
21511 -- the identifier GCC, no other identifiers are acceptable.
21513 when Pragma_System_Name =>
21515 Check_No_Identifiers;
21516 Check_Arg_Count (1);
21517 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21519 -----------------------------
21520 -- Task_Dispatching_Policy --
21521 -----------------------------
21523 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21525 when Pragma_Task_Dispatching_Policy => declare
21529 Check_Ada_83_Warning;
21530 Check_Arg_Count (1);
21531 Check_No_Identifiers;
21532 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21533 Check_Valid_Configuration_Pragma;
21534 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21535 DP := Fold_Upper (Name_Buffer (1));
21537 if Task_Dispatching_Policy /= ' '
21538 and then Task_Dispatching_Policy /= DP
21540 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21542 ("task dispatching policy incompatible with policy#");
21544 -- Set new policy, but always preserve System_Location since we
21545 -- like the error message with the run time name.
21548 Task_Dispatching_Policy := DP;
21550 if Task_Dispatching_Policy_Sloc /= System_Location then
21551 Task_Dispatching_Policy_Sloc := Loc;
21560 -- pragma Task_Info (EXPRESSION);
21562 when Pragma_Task_Info => Task_Info : declare
21563 P : constant Node_Id := Parent (N);
21569 if Warn_On_Obsolescent_Feature then
21571 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21572 & "instead?j?", N);
21575 if Nkind (P) /= N_Task_Definition then
21576 Error_Pragma ("pragma% must appear in task definition");
21579 Check_No_Identifiers;
21580 Check_Arg_Count (1);
21582 Analyze_And_Resolve
21583 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21585 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21589 Ent := Defining_Identifier (Parent (P));
21591 -- Check duplicate pragma before we chain the pragma in the Rep
21592 -- Item chain of Ent.
21595 (Ent, Name_Task_Info, Check_Parents => False)
21597 Error_Pragma ("duplicate pragma% not allowed");
21600 Record_Rep_Item (Ent, N);
21607 -- pragma Task_Name (string_EXPRESSION);
21609 when Pragma_Task_Name => Task_Name : declare
21610 P : constant Node_Id := Parent (N);
21615 Check_No_Identifiers;
21616 Check_Arg_Count (1);
21618 Arg := Get_Pragma_Arg (Arg1);
21620 -- The expression is used in the call to Create_Task, and must be
21621 -- expanded there, not in the context of the current spec. It must
21622 -- however be analyzed to capture global references, in case it
21623 -- appears in a generic context.
21625 Preanalyze_And_Resolve (Arg, Standard_String);
21627 if Nkind (P) /= N_Task_Definition then
21631 Ent := Defining_Identifier (Parent (P));
21633 -- Check duplicate pragma before we chain the pragma in the Rep
21634 -- Item chain of Ent.
21637 (Ent, Name_Task_Name, Check_Parents => False)
21639 Error_Pragma ("duplicate pragma% not allowed");
21642 Record_Rep_Item (Ent, N);
21649 -- pragma Task_Storage (
21650 -- [Task_Type =>] LOCAL_NAME,
21651 -- [Top_Guard =>] static_integer_EXPRESSION);
21653 when Pragma_Task_Storage => Task_Storage : declare
21654 Args : Args_List (1 .. 2);
21655 Names : constant Name_List (1 .. 2) := (
21659 Task_Type : Node_Id renames Args (1);
21660 Top_Guard : Node_Id renames Args (2);
21666 Gather_Associations (Names, Args);
21668 if No (Task_Type) then
21670 ("missing task_type argument for pragma%");
21673 Check_Arg_Is_Local_Name (Task_Type);
21675 Ent := Entity (Task_Type);
21677 if not Is_Task_Type (Ent) then
21679 ("argument for pragma% must be task type", Task_Type);
21682 if No (Top_Guard) then
21684 ("pragma% takes two arguments", Task_Type);
21686 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
21689 Check_First_Subtype (Task_Type);
21691 if Rep_Item_Too_Late (Ent, N) then
21700 -- pragma Test_Case
21701 -- ([Name =>] Static_String_EXPRESSION
21702 -- ,[Mode =>] MODE_TYPE
21703 -- [, Requires => Boolean_EXPRESSION]
21704 -- [, Ensures => Boolean_EXPRESSION]);
21706 -- MODE_TYPE ::= Nominal | Robustness
21708 -- Characteristics:
21710 -- * Analysis - The annotation undergoes initial checks to verify
21711 -- the legal placement and context. Secondary checks preanalyze the
21714 -- Analyze_Test_Case_In_Decl_Part
21716 -- * Expansion - None.
21718 -- * Template - The annotation utilizes the generic template of the
21719 -- related subprogram when it is:
21721 -- aspect on subprogram declaration
21723 -- The annotation must prepare its own template when it is:
21725 -- pragma on subprogram declaration
21727 -- * Globals - Capture of global references must occur after full
21730 -- * Instance - The annotation is instantiated automatically when
21731 -- the related generic subprogram is instantiated except for the
21732 -- "pragma on subprogram declaration" case. In that scenario the
21733 -- annotation must instantiate itself.
21735 when Pragma_Test_Case => Test_Case : declare
21736 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
21737 -- Ensure that the contract of subprogram Subp_Id does not contain
21738 -- another Test_Case pragma with the same Name as the current one.
21740 -------------------------
21741 -- Check_Distinct_Name --
21742 -------------------------
21744 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
21745 Items : constant Node_Id := Contract (Subp_Id);
21746 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
21750 -- Inspect all Test_Case pragma of the related subprogram
21751 -- looking for one with a duplicate "Name" argument.
21753 if Present (Items) then
21754 Prag := Contract_Test_Cases (Items);
21755 while Present (Prag) loop
21756 if Pragma_Name (Prag) = Name_Test_Case
21758 and then String_Equal
21759 (Name, Get_Name_From_CTC_Pragma (Prag))
21761 Error_Msg_Sloc := Sloc (Prag);
21762 Error_Pragma ("name for pragma % is already used #");
21765 Prag := Next_Pragma (Prag);
21768 end Check_Distinct_Name;
21772 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
21775 Subp_Decl : Node_Id;
21776 Subp_Id : Entity_Id;
21778 -- Start of processing for Test_Case
21782 Check_At_Least_N_Arguments (2);
21783 Check_At_Most_N_Arguments (4);
21785 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
21789 Check_Optional_Identifier (Arg1, Name_Name);
21790 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21794 Check_Optional_Identifier (Arg2, Name_Mode);
21795 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
21797 -- Arguments "Requires" and "Ensures"
21799 if Present (Arg3) then
21800 if Present (Arg4) then
21801 Check_Identifier (Arg3, Name_Requires);
21802 Check_Identifier (Arg4, Name_Ensures);
21804 Check_Identifier_Is_One_Of
21805 (Arg3, Name_Requires, Name_Ensures);
21809 -- Pragma Test_Case must be associated with a subprogram declared
21810 -- in a library-level package. First determine whether the current
21811 -- compilation unit is a legal context.
21813 if Nkind_In (Pack_Decl, N_Package_Declaration,
21814 N_Generic_Package_Declaration)
21818 -- Otherwise the placement is illegal
21822 ("pragma % must be specified within a package declaration");
21826 Subp_Decl := Find_Related_Declaration_Or_Body (N);
21828 -- Find the enclosing context
21830 Context := Parent (Subp_Decl);
21832 if Present (Context) then
21833 Context := Parent (Context);
21836 -- Verify the placement of the pragma
21838 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
21840 ("pragma % cannot be applied to abstract subprogram");
21843 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
21844 Error_Pragma ("pragma % cannot be applied to entry");
21847 -- The context is a [generic] subprogram declared at the top level
21848 -- of the [generic] package unit.
21850 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
21851 N_Subprogram_Declaration)
21852 and then Present (Context)
21853 and then Nkind_In (Context, N_Generic_Package_Declaration,
21854 N_Package_Declaration)
21858 -- Otherwise the placement is illegal
21862 ("pragma % must be applied to a library-level subprogram "
21867 Subp_Id := Defining_Entity (Subp_Decl);
21869 -- Chain the pragma on the contract for further processing by
21870 -- Analyze_Test_Case_In_Decl_Part.
21872 Add_Contract_Item (N, Subp_Id);
21874 -- A pragma that applies to a Ghost entity becomes Ghost for the
21875 -- purposes of legality checks and removal of ignored Ghost code.
21877 Mark_Pragma_As_Ghost (N, Subp_Id);
21879 -- Preanalyze the original aspect argument "Name" for ASIS or for
21880 -- a generic subprogram to properly capture global references.
21882 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
21883 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
21885 if Present (Asp_Arg) then
21887 -- The argument appears with an identifier in association
21890 if Nkind (Asp_Arg) = N_Component_Association then
21891 Asp_Arg := Expression (Asp_Arg);
21894 Check_Expr_Is_OK_Static_Expression
21895 (Asp_Arg, Standard_String);
21899 -- Ensure that the all Test_Case pragmas of the related subprogram
21900 -- have distinct names.
21902 Check_Distinct_Name (Subp_Id);
21904 -- Fully analyze the pragma when it appears inside an entry
21905 -- or subprogram body because it cannot benefit from forward
21908 if Nkind_In (Subp_Decl, N_Entry_Body,
21910 N_Subprogram_Body_Stub)
21912 -- The legality checks of pragma Test_Case are affected by the
21913 -- SPARK mode in effect and the volatility of the context.
21914 -- Analyze all pragmas in a specific order.
21916 Analyze_If_Present (Pragma_SPARK_Mode);
21917 Analyze_If_Present (Pragma_Volatile_Function);
21918 Analyze_Test_Case_In_Decl_Part (N);
21922 --------------------------
21923 -- Thread_Local_Storage --
21924 --------------------------
21926 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21928 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
21934 Check_Arg_Count (1);
21935 Check_Optional_Identifier (Arg1, Name_Entity);
21936 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21938 Id := Get_Pragma_Arg (Arg1);
21941 if not Is_Entity_Name (Id)
21942 or else Ekind (Entity (Id)) /= E_Variable
21944 Error_Pragma_Arg ("local variable name required", Arg1);
21949 -- A pragma that applies to a Ghost entity becomes Ghost for the
21950 -- purposes of legality checks and removal of ignored Ghost code.
21952 Mark_Pragma_As_Ghost (N, E);
21954 if Rep_Item_Too_Early (E, N)
21956 Rep_Item_Too_Late (E, N)
21961 Set_Has_Pragma_Thread_Local_Storage (E);
21962 Set_Has_Gigi_Rep_Item (E);
21963 end Thread_Local_Storage;
21969 -- pragma Time_Slice (static_duration_EXPRESSION);
21971 when Pragma_Time_Slice => Time_Slice : declare
21977 Check_Arg_Count (1);
21978 Check_No_Identifiers;
21979 Check_In_Main_Program;
21980 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
21982 if not Error_Posted (Arg1) then
21984 while Present (Nod) loop
21985 if Nkind (Nod) = N_Pragma
21986 and then Pragma_Name (Nod) = Name_Time_Slice
21988 Error_Msg_Name_1 := Pname;
21989 Error_Msg_N ("duplicate pragma% not permitted", Nod);
21996 -- Process only if in main unit
21998 if Get_Source_Unit (Loc) = Main_Unit then
21999 Opt.Time_Slice_Set := True;
22000 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22002 if Val <= Ureal_0 then
22003 Opt.Time_Slice_Value := 0;
22005 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22006 Opt.Time_Slice_Value := 1_000_000_000;
22009 Opt.Time_Slice_Value :=
22010 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22019 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22021 -- TITLING_OPTION ::=
22022 -- [Title =>] STRING_LITERAL
22023 -- | [Subtitle =>] STRING_LITERAL
22025 when Pragma_Title => Title : declare
22026 Args : Args_List (1 .. 2);
22027 Names : constant Name_List (1 .. 2) := (
22033 Gather_Associations (Names, Args);
22036 for J in 1 .. 2 loop
22037 if Present (Args (J)) then
22038 Check_Arg_Is_OK_Static_Expression
22039 (Args (J), Standard_String);
22044 ----------------------------
22045 -- Type_Invariant[_Class] --
22046 ----------------------------
22048 -- pragma Type_Invariant[_Class]
22049 -- ([Entity =>] type_LOCAL_NAME,
22050 -- [Check =>] EXPRESSION);
22052 when Pragma_Type_Invariant |
22053 Pragma_Type_Invariant_Class =>
22054 Type_Invariant : declare
22055 I_Pragma : Node_Id;
22058 Check_Arg_Count (2);
22060 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22061 -- setting Class_Present for the Type_Invariant_Class case.
22063 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22064 I_Pragma := New_Copy (N);
22065 Set_Pragma_Identifier
22066 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22067 Rewrite (N, I_Pragma);
22068 Set_Analyzed (N, False);
22070 end Type_Invariant;
22072 ---------------------
22073 -- Unchecked_Union --
22074 ---------------------
22076 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22078 when Pragma_Unchecked_Union => Unchecked_Union : declare
22079 Assoc : constant Node_Id := Arg1;
22080 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22090 Check_No_Identifiers;
22091 Check_Arg_Count (1);
22092 Check_Arg_Is_Local_Name (Arg1);
22094 Find_Type (Type_Id);
22096 Typ := Entity (Type_Id);
22098 -- A pragma that applies to a Ghost entity becomes Ghost for the
22099 -- purposes of legality checks and removal of ignored Ghost code.
22101 Mark_Pragma_As_Ghost (N, Typ);
22104 or else Rep_Item_Too_Early (Typ, N)
22108 Typ := Underlying_Type (Typ);
22111 if Rep_Item_Too_Late (Typ, N) then
22115 Check_First_Subtype (Arg1);
22117 -- Note remaining cases are references to a type in the current
22118 -- declarative part. If we find an error, we post the error on
22119 -- the relevant type declaration at an appropriate point.
22121 if not Is_Record_Type (Typ) then
22122 Error_Msg_N ("unchecked union must be record type", Typ);
22125 elsif Is_Tagged_Type (Typ) then
22126 Error_Msg_N ("unchecked union must not be tagged", Typ);
22129 elsif not Has_Discriminants (Typ) then
22131 ("unchecked union must have one discriminant", Typ);
22134 -- Note: in previous versions of GNAT we used to check for limited
22135 -- types and give an error, but in fact the standard does allow
22136 -- Unchecked_Union on limited types, so this check was removed.
22138 -- Similarly, GNAT used to require that all discriminants have
22139 -- default values, but this is not mandated by the RM.
22141 -- Proceed with basic error checks completed
22144 Tdef := Type_Definition (Declaration_Node (Typ));
22145 Clist := Component_List (Tdef);
22147 -- Check presence of component list and variant part
22149 if No (Clist) or else No (Variant_Part (Clist)) then
22151 ("unchecked union must have variant part", Tdef);
22155 -- Check components
22157 Comp := First (Component_Items (Clist));
22158 while Present (Comp) loop
22159 Check_Component (Comp, Typ);
22163 -- Check variant part
22165 Vpart := Variant_Part (Clist);
22167 Variant := First (Variants (Vpart));
22168 while Present (Variant) loop
22169 Check_Variant (Variant, Typ);
22174 Set_Is_Unchecked_Union (Typ);
22175 Set_Convention (Typ, Convention_C);
22176 Set_Has_Unchecked_Union (Base_Type (Typ));
22177 Set_Is_Unchecked_Union (Base_Type (Typ));
22178 end Unchecked_Union;
22180 ------------------------
22181 -- Unimplemented_Unit --
22182 ------------------------
22184 -- pragma Unimplemented_Unit;
22186 -- Note: this only gives an error if we are generating code, or if
22187 -- we are in a generic library unit (where the pragma appears in the
22188 -- body, not in the spec).
22190 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22191 Cunitent : constant Entity_Id :=
22192 Cunit_Entity (Get_Source_Unit (Loc));
22193 Ent_Kind : constant Entity_Kind :=
22198 Check_Arg_Count (0);
22200 if Operating_Mode = Generate_Code
22201 or else Ent_Kind = E_Generic_Function
22202 or else Ent_Kind = E_Generic_Procedure
22203 or else Ent_Kind = E_Generic_Package
22205 Get_Name_String (Chars (Cunitent));
22206 Set_Casing (Mixed_Case);
22207 Write_Str (Name_Buffer (1 .. Name_Len));
22208 Write_Str (" is not supported in this configuration");
22210 raise Unrecoverable_Error;
22212 end Unimplemented_Unit;
22214 ------------------------
22215 -- Universal_Aliasing --
22216 ------------------------
22218 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22220 when Pragma_Universal_Aliasing => Universal_Alias : declare
22225 Check_Arg_Count (1);
22226 Check_Optional_Identifier (Arg2, Name_Entity);
22227 Check_Arg_Is_Local_Name (Arg1);
22228 E_Id := Entity (Get_Pragma_Arg (Arg1));
22230 if E_Id = Any_Type then
22232 elsif No (E_Id) or else not Is_Type (E_Id) then
22233 Error_Pragma_Arg ("pragma% requires type", Arg1);
22236 -- A pragma that applies to a Ghost entity becomes Ghost for the
22237 -- purposes of legality checks and removal of ignored Ghost code.
22239 Mark_Pragma_As_Ghost (N, E_Id);
22240 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22241 Record_Rep_Item (E_Id, N);
22242 end Universal_Alias;
22244 --------------------
22245 -- Universal_Data --
22246 --------------------
22248 -- pragma Universal_Data [(library_unit_NAME)];
22250 when Pragma_Universal_Data =>
22253 -- If this is a configuration pragma, then set the universal
22254 -- addressing option, otherwise confirm that the pragma satisfies
22255 -- the requirements of library unit pragma placement and leave it
22256 -- to the GNAAMP back end to detect the pragma (avoids transitive
22257 -- setting of the option due to withed units).
22259 if Is_Configuration_Pragma then
22260 Universal_Addressing_On_AAMP := True;
22262 Check_Valid_Library_Unit_Pragma;
22265 if not AAMP_On_Target then
22266 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22273 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22275 when Pragma_Unmodified => Unmodified : declare
22277 Arg_Expr : Node_Id;
22278 Arg_Id : Entity_Id;
22280 Ghost_Error_Posted : Boolean := False;
22281 -- Flag set when an error concerning the illegal mix of Ghost and
22282 -- non-Ghost variables is emitted.
22284 Ghost_Id : Entity_Id := Empty;
22285 -- The entity of the first Ghost variable encountered while
22286 -- processing the arguments of the pragma.
22290 Check_At_Least_N_Arguments (1);
22292 -- Loop through arguments
22295 while Present (Arg) loop
22296 Check_No_Identifier (Arg);
22298 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
22299 -- in fact generate reference, so that the entity will have a
22300 -- reference, which will inhibit any warnings about it not
22301 -- being referenced, and also properly show up in the ali file
22302 -- as a reference. But this reference is recorded before the
22303 -- Has_Pragma_Unreferenced flag is set, so that no warning is
22304 -- generated for this reference.
22306 Check_Arg_Is_Local_Name (Arg);
22307 Arg_Expr := Get_Pragma_Arg (Arg);
22309 if Is_Entity_Name (Arg_Expr) then
22310 Arg_Id := Entity (Arg_Expr);
22312 if Is_Assignable (Arg_Id) then
22313 Set_Has_Pragma_Unmodified (Arg_Id);
22315 -- A pragma that applies to a Ghost entity becomes Ghost
22316 -- for the purposes of legality checks and removal of
22317 -- ignored Ghost code.
22319 Mark_Pragma_As_Ghost (N, Arg_Id);
22321 -- Capture the entity of the first Ghost variable being
22322 -- processed for error detection purposes.
22324 if Is_Ghost_Entity (Arg_Id) then
22325 if No (Ghost_Id) then
22326 Ghost_Id := Arg_Id;
22329 -- Otherwise the variable is non-Ghost. It is illegal
22330 -- to mix references to Ghost and non-Ghost entities
22333 elsif Present (Ghost_Id)
22334 and then not Ghost_Error_Posted
22336 Ghost_Error_Posted := True;
22338 Error_Msg_Name_1 := Pname;
22340 ("pragma % cannot mention ghost and non-ghost "
22343 Error_Msg_Sloc := Sloc (Ghost_Id);
22344 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22346 Error_Msg_Sloc := Sloc (Arg_Id);
22347 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22350 -- Otherwise the pragma referenced an illegal entity
22354 ("pragma% can only be applied to a variable", Arg_Expr);
22366 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22368 -- or when used in a context clause:
22370 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22372 when Pragma_Unreferenced => Unreferenced : declare
22374 Arg_Expr : Node_Id;
22375 Arg_Id : Entity_Id;
22378 Ghost_Error_Posted : Boolean := False;
22379 -- Flag set when an error concerning the illegal mix of Ghost and
22380 -- non-Ghost names is emitted.
22382 Ghost_Id : Entity_Id := Empty;
22383 -- The entity of the first Ghost name encountered while processing
22384 -- the arguments of the pragma.
22388 Check_At_Least_N_Arguments (1);
22390 -- Check case of appearing within context clause
22392 if Is_In_Context_Clause then
22394 -- The arguments must all be units mentioned in a with clause
22395 -- in the same context clause. Note we already checked (in
22396 -- Par.Prag) that the arguments are either identifiers or
22397 -- selected components.
22400 while Present (Arg) loop
22401 Citem := First (List_Containing (N));
22402 while Citem /= N loop
22403 Arg_Expr := Get_Pragma_Arg (Arg);
22405 if Nkind (Citem) = N_With_Clause
22406 and then Same_Name (Name (Citem), Arg_Expr)
22408 Set_Has_Pragma_Unreferenced
22411 (Library_Unit (Citem))));
22412 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
22421 ("argument of pragma% is not withed unit", Arg);
22427 -- Case of not in list of context items
22431 while Present (Arg) loop
22432 Check_No_Identifier (Arg);
22434 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22435 -- will in fact generate reference, so that the entity will
22436 -- have a reference, which will inhibit any warnings about
22437 -- it not being referenced, and also properly show up in the
22438 -- ali file as a reference. But this reference is recorded
22439 -- before the Has_Pragma_Unreferenced flag is set, so that
22440 -- no warning is generated for this reference.
22442 Check_Arg_Is_Local_Name (Arg);
22443 Arg_Expr := Get_Pragma_Arg (Arg);
22445 if Is_Entity_Name (Arg_Expr) then
22446 Arg_Id := Entity (Arg_Expr);
22448 -- If the entity is overloaded, the pragma applies to the
22449 -- most recent overloading, as documented. In this case,
22450 -- name resolution does not generate a reference, so it
22451 -- must be done here explicitly.
22453 if Is_Overloaded (Arg_Expr) then
22454 Generate_Reference (Arg_Id, N);
22457 Set_Has_Pragma_Unreferenced (Arg_Id);
22459 -- A pragma that applies to a Ghost entity becomes Ghost
22460 -- for the purposes of legality checks and removal of
22461 -- ignored Ghost code.
22463 Mark_Pragma_As_Ghost (N, Arg_Id);
22465 -- Capture the entity of the first Ghost name being
22466 -- processed for error detection purposes.
22468 if Is_Ghost_Entity (Arg_Id) then
22469 if No (Ghost_Id) then
22470 Ghost_Id := Arg_Id;
22473 -- Otherwise the name is non-Ghost. It is illegal to mix
22474 -- references to Ghost and non-Ghost entities
22477 elsif Present (Ghost_Id)
22478 and then not Ghost_Error_Posted
22480 Ghost_Error_Posted := True;
22482 Error_Msg_Name_1 := Pname;
22484 ("pragma % cannot mention ghost and non-ghost names",
22487 Error_Msg_Sloc := Sloc (Ghost_Id);
22488 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22490 Error_Msg_Sloc := Sloc (Arg_Id);
22491 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22500 --------------------------
22501 -- Unreferenced_Objects --
22502 --------------------------
22504 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22506 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22508 Arg_Expr : Node_Id;
22509 Arg_Id : Entity_Id;
22511 Ghost_Error_Posted : Boolean := False;
22512 -- Flag set when an error concerning the illegal mix of Ghost and
22513 -- non-Ghost types is emitted.
22515 Ghost_Id : Entity_Id := Empty;
22516 -- The entity of the first Ghost type encountered while processing
22517 -- the arguments of the pragma.
22521 Check_At_Least_N_Arguments (1);
22524 while Present (Arg) loop
22525 Check_No_Identifier (Arg);
22526 Check_Arg_Is_Local_Name (Arg);
22527 Arg_Expr := Get_Pragma_Arg (Arg);
22529 if Is_Entity_Name (Arg_Expr) then
22530 Arg_Id := Entity (Arg_Expr);
22532 if Is_Type (Arg_Id) then
22533 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22535 -- A pragma that applies to a Ghost entity becomes Ghost
22536 -- for the purposes of legality checks and removal of
22537 -- ignored Ghost code.
22539 Mark_Pragma_As_Ghost (N, Arg_Id);
22541 -- Capture the entity of the first Ghost type being
22542 -- processed for error detection purposes.
22544 if Is_Ghost_Entity (Arg_Id) then
22545 if No (Ghost_Id) then
22546 Ghost_Id := Arg_Id;
22549 -- Otherwise the type is non-Ghost. It is illegal to mix
22550 -- references to Ghost and non-Ghost entities
22553 elsif Present (Ghost_Id)
22554 and then not Ghost_Error_Posted
22556 Ghost_Error_Posted := True;
22558 Error_Msg_Name_1 := Pname;
22560 ("pragma % cannot mention ghost and non-ghost types",
22563 Error_Msg_Sloc := Sloc (Ghost_Id);
22564 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22566 Error_Msg_Sloc := Sloc (Arg_Id);
22567 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22571 ("argument for pragma% must be type or subtype", Arg);
22575 ("argument for pragma% must be type or subtype", Arg);
22580 end Unreferenced_Objects;
22582 ------------------------------
22583 -- Unreserve_All_Interrupts --
22584 ------------------------------
22586 -- pragma Unreserve_All_Interrupts;
22588 when Pragma_Unreserve_All_Interrupts =>
22590 Check_Arg_Count (0);
22592 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22593 Unreserve_All_Interrupts := True;
22600 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22602 when Pragma_Unsuppress =>
22604 Process_Suppress_Unsuppress (Suppress_Case => False);
22606 ----------------------------
22607 -- Unevaluated_Use_Of_Old --
22608 ----------------------------
22610 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22612 when Pragma_Unevaluated_Use_Of_Old =>
22614 Check_Arg_Count (1);
22615 Check_No_Identifiers;
22616 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22618 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22619 -- a declarative part or a package spec.
22621 if not Is_Configuration_Pragma then
22622 Check_Is_In_Decl_Part_Or_Package_Spec;
22625 -- Store proper setting of Uneval_Old
22627 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22628 Uneval_Old := Fold_Upper (Name_Buffer (1));
22630 -------------------
22631 -- Use_VADS_Size --
22632 -------------------
22634 -- pragma Use_VADS_Size;
22636 when Pragma_Use_VADS_Size =>
22638 Check_Arg_Count (0);
22639 Check_Valid_Configuration_Pragma;
22640 Use_VADS_Size := True;
22642 ---------------------
22643 -- Validity_Checks --
22644 ---------------------
22646 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22648 when Pragma_Validity_Checks => Validity_Checks : declare
22649 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22655 Check_Arg_Count (1);
22656 Check_No_Identifiers;
22658 -- Pragma always active unless in CodePeer or GNATprove modes,
22659 -- which use a fixed configuration of validity checks.
22661 if not (CodePeer_Mode or GNATprove_Mode) then
22662 if Nkind (A) = N_String_Literal then
22666 Slen : constant Natural := Natural (String_Length (S));
22667 Options : String (1 .. Slen);
22671 -- Couldn't we use a for loop here over Options'Range???
22675 C := Get_String_Char (S, Pos (J));
22677 -- This is a weird test, it skips setting validity
22678 -- checks entirely if any element of S is out of
22679 -- range of Character, what is that about ???
22681 exit when not In_Character_Range (C);
22682 Options (J) := Get_Character (C);
22685 Set_Validity_Check_Options (Options);
22693 elsif Nkind (A) = N_Identifier then
22694 if Chars (A) = Name_All_Checks then
22695 Set_Validity_Check_Options ("a");
22696 elsif Chars (A) = Name_On then
22697 Validity_Checks_On := True;
22698 elsif Chars (A) = Name_Off then
22699 Validity_Checks_On := False;
22703 end Validity_Checks;
22709 -- pragma Volatile (LOCAL_NAME);
22711 when Pragma_Volatile =>
22712 Process_Atomic_Independent_Shared_Volatile;
22714 -------------------------
22715 -- Volatile_Components --
22716 -------------------------
22718 -- pragma Volatile_Components (array_LOCAL_NAME);
22720 -- Volatile is handled by the same circuit as Atomic_Components
22722 --------------------------
22723 -- Volatile_Full_Access --
22724 --------------------------
22726 -- pragma Volatile_Full_Access (LOCAL_NAME);
22728 when Pragma_Volatile_Full_Access =>
22730 Process_Atomic_Independent_Shared_Volatile;
22732 -----------------------
22733 -- Volatile_Function --
22734 -----------------------
22736 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22738 when Pragma_Volatile_Function => Volatile_Function : declare
22739 Over_Id : Entity_Id;
22740 Spec_Id : Entity_Id;
22741 Subp_Decl : Node_Id;
22745 Check_No_Identifiers;
22746 Check_At_Most_N_Arguments (1);
22749 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22751 -- Generic subprogram
22753 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22756 -- Body acts as spec
22758 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22759 and then No (Corresponding_Spec (Subp_Decl))
22763 -- Body stub acts as spec
22765 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22766 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22772 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22780 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22782 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22787 -- Chain the pragma on the contract for completeness
22789 Add_Contract_Item (N, Spec_Id);
22791 -- The legality checks of pragma Volatile_Function are affected by
22792 -- the SPARK mode in effect. Analyze all pragmas in a specific
22795 Analyze_If_Present (Pragma_SPARK_Mode);
22797 -- A pragma that applies to a Ghost entity becomes Ghost for the
22798 -- purposes of legality checks and removal of ignored Ghost code.
22800 Mark_Pragma_As_Ghost (N, Spec_Id);
22802 -- A volatile function cannot override a non-volatile function
22803 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22804 -- in New_Overloaded_Entity, however at that point the pragma has
22805 -- not been processed yet.
22807 Over_Id := Overridden_Operation (Spec_Id);
22809 if Present (Over_Id)
22810 and then not Is_Volatile_Function (Over_Id)
22813 ("incompatible volatile function values in effect", Spec_Id);
22815 Error_Msg_Sloc := Sloc (Over_Id);
22817 ("\& declared # with Volatile_Function value False",
22820 Error_Msg_Sloc := Sloc (Spec_Id);
22822 ("\overridden # with Volatile_Function value True",
22826 -- Analyze the Boolean expression (if any)
22828 if Present (Arg1) then
22829 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22831 end Volatile_Function;
22833 ----------------------
22834 -- Warning_As_Error --
22835 ----------------------
22837 -- pragma Warning_As_Error (static_string_EXPRESSION);
22839 when Pragma_Warning_As_Error =>
22841 Check_Arg_Count (1);
22842 Check_No_Identifiers;
22843 Check_Valid_Configuration_Pragma;
22845 if not Is_Static_String_Expression (Arg1) then
22847 ("argument of pragma% must be static string expression",
22850 -- OK static string expression
22853 Acquire_Warning_Match_String (Arg1);
22854 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
22855 Warnings_As_Errors (Warnings_As_Errors_Count) :=
22856 new String'(Name_Buffer (1 .. Name_Len));
22863 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22865 -- DETAILS ::= On | Off
22866 -- DETAILS ::= On | Off, local_NAME
22867 -- DETAILS ::= static_string_EXPRESSION
22868 -- DETAILS ::= On | Off, static_string_EXPRESSION
22870 -- TOOL_NAME ::= GNAT | GNATProve
22872 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22874 -- Note: If the first argument matches an allowed tool name, it is
22875 -- always considered to be a tool name, even if there is a string
22876 -- variable of that name.
22878 -- Note if the second argument of DETAILS is a local_NAME then the
22879 -- second form is always understood. If the intention is to use
22880 -- the fourth form, then you can write NAME & "" to force the
22881 -- intepretation as a static_string_EXPRESSION.
22883 when Pragma_Warnings => Warnings : declare
22884 Reason : String_Id;
22888 Check_At_Least_N_Arguments (1);
22890 -- See if last argument is labeled Reason. If so, make sure we
22891 -- have a string literal or a concatenation of string literals,
22892 -- and acquire the REASON string. Then remove the REASON argument
22893 -- by decreasing Num_Args by one; Remaining processing looks only
22894 -- at first Num_Args arguments).
22897 Last_Arg : constant Node_Id :=
22898 Last (Pragma_Argument_Associations (N));
22901 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22902 and then Chars (Last_Arg) = Name_Reason
22905 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22906 Reason := End_String;
22907 Arg_Count := Arg_Count - 1;
22909 -- Not allowed in compiler units (bootstrap issues)
22911 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22913 -- No REASON string, set null string as reason
22916 Reason := Null_String_Id;
22920 -- Now proceed with REASON taken care of and eliminated
22922 Check_No_Identifiers;
22924 -- If debug flag -gnatd.i is set, pragma is ignored
22926 if Debug_Flag_Dot_I then
22930 -- Process various forms of the pragma
22933 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22934 Shifted_Args : List_Id;
22937 -- See if first argument is a tool name, currently either
22938 -- GNAT or GNATprove. If so, either ignore the pragma if the
22939 -- tool used does not match, or continue as if no tool name
22940 -- was given otherwise, by shifting the arguments.
22942 if Nkind (Argx) = N_Identifier
22943 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22945 if Chars (Argx) = Name_Gnat then
22946 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22947 Rewrite (N, Make_Null_Statement (Loc));
22952 elsif Chars (Argx) = Name_Gnatprove then
22953 if not GNATprove_Mode then
22954 Rewrite (N, Make_Null_Statement (Loc));
22960 raise Program_Error;
22963 -- At this point, the pragma Warnings applies to the tool,
22964 -- so continue with shifted arguments.
22966 Arg_Count := Arg_Count - 1;
22968 if Arg_Count = 1 then
22969 Shifted_Args := New_List (New_Copy (Arg2));
22970 elsif Arg_Count = 2 then
22971 Shifted_Args := New_List (New_Copy (Arg2),
22973 elsif Arg_Count = 3 then
22974 Shifted_Args := New_List (New_Copy (Arg2),
22978 raise Program_Error;
22983 Chars => Name_Warnings,
22984 Pragma_Argument_Associations => Shifted_Args));
22989 -- One argument case
22991 if Arg_Count = 1 then
22993 -- On/Off one argument case was processed by parser
22995 if Nkind (Argx) = N_Identifier
22996 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23000 -- One argument case must be ON/OFF or static string expr
23002 elsif not Is_Static_String_Expression (Arg1) then
23004 ("argument of pragma% must be On/Off or static string "
23005 & "expression", Arg1);
23007 -- One argument string expression case
23011 Lit : constant Node_Id := Expr_Value_S (Argx);
23012 Str : constant String_Id := Strval (Lit);
23013 Len : constant Nat := String_Length (Str);
23021 while J <= Len loop
23022 C := Get_String_Char (Str, J);
23023 OK := In_Character_Range (C);
23026 Chr := Get_Character (C);
23028 -- Dash case: only -Wxxx is accepted
23035 C := Get_String_Char (Str, J);
23036 Chr := Get_Character (C);
23037 exit when Chr = 'W';
23042 elsif J < Len and then Chr = '.' then
23044 C := Get_String_Char (Str, J);
23045 Chr := Get_Character (C);
23047 if not Set_Dot_Warning_Switch (Chr) then
23049 ("invalid warning switch character "
23050 & '.' & Chr, Arg1);
23056 OK := Set_Warning_Switch (Chr);
23062 ("invalid warning switch character " & Chr,
23071 -- Two or more arguments (must be two)
23074 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23075 Check_Arg_Count (2);
23083 E_Id := Get_Pragma_Arg (Arg2);
23086 -- In the expansion of an inlined body, a reference to
23087 -- the formal may be wrapped in a conversion if the
23088 -- actual is a conversion. Retrieve the real entity name.
23090 if (In_Instance_Body or In_Inlined_Body)
23091 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23093 E_Id := Expression (E_Id);
23096 -- Entity name case
23098 if Is_Entity_Name (E_Id) then
23099 E := Entity (E_Id);
23106 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23109 -- For OFF case, make entry in warnings off
23110 -- pragma table for later processing. But we do
23111 -- not do that within an instance, since these
23112 -- warnings are about what is needed in the
23113 -- template, not an instance of it.
23115 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23116 and then Warn_On_Warnings_Off
23117 and then not In_Instance
23119 Warnings_Off_Pragmas.Append ((N, E, Reason));
23122 if Is_Enumeration_Type (E) then
23126 Lit := First_Literal (E);
23127 while Present (Lit) loop
23128 Set_Warnings_Off (Lit);
23129 Next_Literal (Lit);
23134 exit when No (Homonym (E));
23139 -- Error if not entity or static string expression case
23141 elsif not Is_Static_String_Expression (Arg2) then
23143 ("second argument of pragma% must be entity name "
23144 & "or static string expression", Arg2);
23146 -- Static string expression case
23149 Acquire_Warning_Match_String (Arg2);
23151 -- Note on configuration pragma case: If this is a
23152 -- configuration pragma, then for an OFF pragma, we
23153 -- just set Config True in the call, which is all
23154 -- that needs to be done. For the case of ON, this
23155 -- is normally an error, unless it is canceling the
23156 -- effect of a previous OFF pragma in the same file.
23157 -- In any other case, an error will be signalled (ON
23158 -- with no matching OFF).
23160 -- Note: We set Used if we are inside a generic to
23161 -- disable the test that the non-config case actually
23162 -- cancels a warning. That's because we can't be sure
23163 -- there isn't an instantiation in some other unit
23164 -- where a warning is suppressed.
23166 -- We could do a little better here by checking if the
23167 -- generic unit we are inside is public, but for now
23168 -- we don't bother with that refinement.
23170 if Chars (Argx) = Name_Off then
23171 Set_Specific_Warning_Off
23172 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23173 Config => Is_Configuration_Pragma,
23174 Used => Inside_A_Generic or else In_Instance);
23176 elsif Chars (Argx) = Name_On then
23177 Set_Specific_Warning_On
23178 (Loc, Name_Buffer (1 .. Name_Len), Err);
23182 ("??pragma Warnings On with no matching "
23183 & "Warnings Off", Loc);
23192 -------------------
23193 -- Weak_External --
23194 -------------------
23196 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23198 when Pragma_Weak_External => Weak_External : declare
23203 Check_Arg_Count (1);
23204 Check_Optional_Identifier (Arg1, Name_Entity);
23205 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23206 Ent := Entity (Get_Pragma_Arg (Arg1));
23208 if Rep_Item_Too_Early (Ent, N) then
23211 Ent := Underlying_Type (Ent);
23214 -- The only processing required is to link this item on to the
23215 -- list of rep items for the given entity. This is accomplished
23216 -- by the call to Rep_Item_Too_Late (when no error is detected
23217 -- and False is returned).
23219 if Rep_Item_Too_Late (Ent, N) then
23222 Set_Has_Gigi_Rep_Item (Ent);
23226 -----------------------------
23227 -- Wide_Character_Encoding --
23228 -----------------------------
23230 -- pragma Wide_Character_Encoding (IDENTIFIER);
23232 when Pragma_Wide_Character_Encoding =>
23235 -- Nothing to do, handled in parser. Note that we do not enforce
23236 -- configuration pragma placement, this pragma can appear at any
23237 -- place in the source, allowing mixed encodings within a single
23242 --------------------
23243 -- Unknown_Pragma --
23244 --------------------
23246 -- Should be impossible, since the case of an unknown pragma is
23247 -- separately processed before the case statement is entered.
23249 when Unknown_Pragma =>
23250 raise Program_Error;
23253 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23254 -- until AI is formally approved.
23256 -- Check_Order_Dependence;
23259 when Pragma_Exit => null;
23260 end Analyze_Pragma;
23262 ---------------------------------------------
23263 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23264 ---------------------------------------------
23266 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23268 Freeze_Id : Entity_Id := Empty)
23272 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23273 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23274 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23276 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23279 Disp_Typ : Entity_Id;
23280 Restore_Scope : Boolean := False;
23282 function Check_References (N : Node_Id) return Traverse_Result;
23283 -- Check that the expression does not mention non-primitives of
23284 -- the type, global objects of the type, or other illegalities
23285 -- described and implied by AI12-0113.
23287 ----------------------
23288 -- Check_References --
23289 ----------------------
23291 function Check_References (N : Node_Id) return Traverse_Result is
23293 if Nkind (N) = N_Function_Call
23294 and then Is_Entity_Name (Name (N))
23297 Func : constant Entity_Id := Entity (Name (N));
23301 -- An operation of the type must be a primitive.
23303 if No (Find_Dispatching_Type (Func)) then
23304 Form := First_Formal (Func);
23305 while Present (Form) loop
23306 if Etype (Form) = Disp_Typ then
23307 Error_Msg_NE ("operation in class-wide condition "
23308 & "must be primitive of&", N, Disp_Typ);
23310 Next_Formal (Form);
23313 -- A return object of the type is illegal as well.
23315 if Etype (Func) = Disp_Typ
23316 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23318 Error_Msg_NE ("operation in class-wide condition "
23319 & "must be primitive of&", N, Disp_Typ);
23324 elsif Is_Entity_Name (N)
23326 (Etype (N) = Disp_Typ
23327 or else Etype (N) = Class_Wide_Type (Disp_Typ))
23328 and then Ekind_In (Entity (N), E_Variable, E_Constant)
23331 ("object in class-wide condition must be formal of type&",
23334 elsif Nkind (N) = N_Explicit_Dereference
23335 and then (Etype (N) = Disp_Typ
23336 or else Etype (N) = Class_Wide_Type (Disp_Typ))
23337 and then (not Is_Entity_Name (Prefix (N))
23338 or else not Is_Formal (Entity (Prefix (N))))
23340 Error_Msg_NE ("operation in class-wide condition "
23341 & "must be primitive of&", N, Disp_Typ);
23345 end Check_References;
23347 procedure Check_Class_Wide_Condition is new
23348 Traverse_Proc (Check_References);
23350 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23353 -- Do not analyze the pragma multiple times
23355 if Is_Analyzed_Pragma (N) then
23359 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23360 -- analysis of the pragma, the Ghost mode at point of declaration and
23361 -- point of analysis may not necessarily be the same. Use the mode in
23362 -- effect at the point of declaration.
23364 Set_Ghost_Mode (N);
23366 -- Ensure that the subprogram and its formals are visible when analyzing
23367 -- the expression of the pragma.
23369 if not In_Open_Scopes (Spec_Id) then
23370 Restore_Scope := True;
23371 Push_Scope (Spec_Id);
23373 if Is_Generic_Subprogram (Spec_Id) then
23374 Install_Generic_Formals (Spec_Id);
23376 Install_Formals (Spec_Id);
23380 Errors := Serious_Errors_Detected;
23381 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23383 -- Emit a clarification message when the expression contains at least
23384 -- one undefined reference, possibly due to contract "freezing".
23386 if Errors /= Serious_Errors_Detected
23387 and then Present (Freeze_Id)
23388 and then Has_Undefined_Reference (Expr)
23390 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23393 if Class_Present (N) then
23395 -- Verify that a class-wide condition is legal, i.e. the operation is
23396 -- a primitive of a tagged type. Note that a generic subprogram is
23397 -- not a primitive operation.
23399 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23401 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23402 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23404 if From_Aspect_Specification (N) then
23406 ("aspect % can only be specified for a primitive operation "
23407 & "of a tagged type", Corresponding_Aspect (N));
23409 -- The pragma is a source construct
23413 ("pragma % can only be specified for a primitive operation "
23414 & "of a tagged type", N);
23418 -- Remaining semantic checks require a full tree traversal.
23420 Check_Class_Wide_Condition (Expr);
23425 if Restore_Scope then
23429 -- Currently it is not possible to inline pre/postconditions on a
23430 -- subprogram subject to pragma Inline_Always.
23432 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23433 Ghost_Mode := Save_Ghost_Mode;
23435 Set_Is_Analyzed_Pragma (N);
23436 end Analyze_Pre_Post_Condition_In_Decl_Part;
23438 ------------------------------------------
23439 -- Analyze_Refined_Depends_In_Decl_Part --
23440 ------------------------------------------
23442 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23443 Body_Inputs : Elist_Id := No_Elist;
23444 Body_Outputs : Elist_Id := No_Elist;
23445 -- The inputs and outputs of the subprogram body synthesized from pragma
23446 -- Refined_Depends.
23448 Dependencies : List_Id := No_List;
23450 -- The corresponding Depends pragma along with its clauses
23452 Matched_Items : Elist_Id := No_Elist;
23453 -- A list containing the entities of all successfully matched items
23454 -- found in pragma Depends.
23456 Refinements : List_Id := No_List;
23457 -- The clauses of pragma Refined_Depends
23459 Spec_Id : Entity_Id;
23460 -- The entity of the subprogram subject to pragma Refined_Depends
23462 Spec_Inputs : Elist_Id := No_Elist;
23463 Spec_Outputs : Elist_Id := No_Elist;
23464 -- The inputs and outputs of the subprogram spec synthesized from pragma
23467 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23468 -- Try to match a single dependency clause Dep_Clause against one or
23469 -- more refinement clauses found in list Refinements. Each successful
23470 -- match eliminates at least one refinement clause from Refinements.
23472 procedure Check_Output_States;
23473 -- Determine whether pragma Depends contains an output state with a
23474 -- visible refinement and if so, ensure that pragma Refined_Depends
23475 -- mentions all its constituents as outputs.
23477 procedure Normalize_Clauses (Clauses : List_Id);
23478 -- Given a list of dependence or refinement clauses Clauses, normalize
23479 -- each clause by creating multiple dependencies with exactly one input
23482 procedure Report_Extra_Clauses;
23483 -- Emit an error for each extra clause found in list Refinements
23485 -----------------------------
23486 -- Check_Dependency_Clause --
23487 -----------------------------
23489 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23490 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23491 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23493 function Is_In_Out_State_Clause return Boolean;
23494 -- Determine whether dependence clause Dep_Clause denotes an abstract
23495 -- state that depends on itself (State => State).
23497 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23498 -- Determine whether item Item denotes an abstract state with visible
23499 -- null refinement.
23501 procedure Match_Items
23502 (Dep_Item : Node_Id;
23503 Ref_Item : Node_Id;
23504 Matched : out Boolean);
23505 -- Try to match dependence item Dep_Item against refinement item
23506 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23507 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23508 -- the following conformance scenarios is in effect:
23509 -- 1) Both items denote null
23510 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23511 -- 3) Both items denote attribute 'Result
23512 -- 4) Both items denote the same object
23513 -- 5) Both items denote the same formal parameter
23514 -- 6) Both items denote the same current instance of a type
23515 -- 7) Both items denote the same discriminant
23516 -- 8) Dep_Item is an abstract state with visible null refinement
23517 -- and Ref_Item denotes null.
23518 -- 9) Dep_Item is an abstract state with visible null refinement
23519 -- and Ref_Item is Empty (special case).
23520 -- 10) Dep_Item is an abstract state with visible non-null
23521 -- refinement and Ref_Item denotes one of its constituents.
23522 -- 11) Dep_Item is an abstract state without a visible refinement
23523 -- and Ref_Item denotes the same state.
23524 -- When scenario 10 is in effect, the entity of the abstract state
23525 -- denoted by Dep_Item is added to list Refined_States.
23527 procedure Record_Item (Item_Id : Entity_Id);
23528 -- Store the entity of an item denoted by Item_Id in Matched_Items
23530 ----------------------------
23531 -- Is_In_Out_State_Clause --
23532 ----------------------------
23534 function Is_In_Out_State_Clause return Boolean is
23535 Dep_Input_Id : Entity_Id;
23536 Dep_Output_Id : Entity_Id;
23539 -- Detect the following clause:
23542 if Is_Entity_Name (Dep_Input)
23543 and then Is_Entity_Name (Dep_Output)
23545 -- Handle abstract views generated for limited with clauses
23547 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23548 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23551 Ekind (Dep_Input_Id) = E_Abstract_State
23552 and then Dep_Input_Id = Dep_Output_Id;
23556 end Is_In_Out_State_Clause;
23558 ---------------------------
23559 -- Is_Null_Refined_State --
23560 ---------------------------
23562 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23563 Item_Id : Entity_Id;
23566 if Is_Entity_Name (Item) then
23568 -- Handle abstract views generated for limited with clauses
23570 Item_Id := Available_View (Entity_Of (Item));
23573 Ekind (Item_Id) = E_Abstract_State
23574 and then Has_Null_Visible_Refinement (Item_Id);
23578 end Is_Null_Refined_State;
23584 procedure Match_Items
23585 (Dep_Item : Node_Id;
23586 Ref_Item : Node_Id;
23587 Matched : out Boolean)
23589 Dep_Item_Id : Entity_Id;
23590 Ref_Item_Id : Entity_Id;
23593 -- Assume that the two items do not match
23597 -- A null matches null or Empty (special case)
23599 if Nkind (Dep_Item) = N_Null
23600 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23604 -- Attribute 'Result matches attribute 'Result
23606 elsif Is_Attribute_Result (Dep_Item)
23607 and then Is_Attribute_Result (Dep_Item)
23611 -- Abstract states, current instances of concurrent types,
23612 -- discriminants, formal parameters and objects.
23614 elsif Is_Entity_Name (Dep_Item) then
23616 -- Handle abstract views generated for limited with clauses
23618 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23620 if Ekind (Dep_Item_Id) = E_Abstract_State then
23622 -- An abstract state with visible null refinement matches
23623 -- null or Empty (special case).
23625 if Has_Null_Visible_Refinement (Dep_Item_Id)
23626 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23628 Record_Item (Dep_Item_Id);
23631 -- An abstract state with visible non-null refinement
23632 -- matches one of its constituents.
23634 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23635 if Is_Entity_Name (Ref_Item) then
23636 Ref_Item_Id := Entity_Of (Ref_Item);
23638 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23641 and then Present (Encapsulating_State (Ref_Item_Id))
23642 and then Encapsulating_State (Ref_Item_Id) =
23645 Record_Item (Dep_Item_Id);
23650 -- An abstract state without a visible refinement matches
23653 elsif Is_Entity_Name (Ref_Item)
23654 and then Entity_Of (Ref_Item) = Dep_Item_Id
23656 Record_Item (Dep_Item_Id);
23660 -- A current instance of a concurrent type, discriminant,
23661 -- formal parameter or an object matches itself.
23663 elsif Is_Entity_Name (Ref_Item)
23664 and then Entity_Of (Ref_Item) = Dep_Item_Id
23666 Record_Item (Dep_Item_Id);
23676 procedure Record_Item (Item_Id : Entity_Id) is
23678 if not Contains (Matched_Items, Item_Id) then
23679 Append_New_Elmt (Item_Id, Matched_Items);
23685 Clause_Matched : Boolean := False;
23686 Dummy : Boolean := False;
23687 Inputs_Match : Boolean;
23688 Next_Ref_Clause : Node_Id;
23689 Outputs_Match : Boolean;
23690 Ref_Clause : Node_Id;
23691 Ref_Input : Node_Id;
23692 Ref_Output : Node_Id;
23694 -- Start of processing for Check_Dependency_Clause
23697 -- Do not perform this check in an instance because it was already
23698 -- performed successfully in the generic template.
23700 if Is_Generic_Instance (Spec_Id) then
23704 -- Examine all refinement clauses and compare them against the
23705 -- dependence clause.
23707 Ref_Clause := First (Refinements);
23708 while Present (Ref_Clause) loop
23709 Next_Ref_Clause := Next (Ref_Clause);
23711 -- Obtain the attributes of the current refinement clause
23713 Ref_Input := Expression (Ref_Clause);
23714 Ref_Output := First (Choices (Ref_Clause));
23716 -- The current refinement clause matches the dependence clause
23717 -- when both outputs match and both inputs match. See routine
23718 -- Match_Items for all possible conformance scenarios.
23720 -- Depends Dep_Output => Dep_Input
23724 -- Refined_Depends Ref_Output => Ref_Input
23727 (Dep_Item => Dep_Input,
23728 Ref_Item => Ref_Input,
23729 Matched => Inputs_Match);
23732 (Dep_Item => Dep_Output,
23733 Ref_Item => Ref_Output,
23734 Matched => Outputs_Match);
23736 -- An In_Out state clause may be matched against a refinement with
23737 -- a null input or null output as long as the non-null side of the
23738 -- relation contains a valid constituent of the In_Out_State.
23740 if Is_In_Out_State_Clause then
23742 -- Depends => (State => State)
23743 -- Refined_Depends => (null => Constit) -- OK
23746 and then not Outputs_Match
23747 and then Nkind (Ref_Output) = N_Null
23749 Outputs_Match := True;
23752 -- Depends => (State => State)
23753 -- Refined_Depends => (Constit => null) -- OK
23755 if not Inputs_Match
23756 and then Outputs_Match
23757 and then Nkind (Ref_Input) = N_Null
23759 Inputs_Match := True;
23763 -- The current refinement clause is legally constructed following
23764 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23765 -- the pool of candidates. The seach continues because a single
23766 -- dependence clause may have multiple matching refinements.
23768 if Inputs_Match and Outputs_Match then
23769 Clause_Matched := True;
23770 Remove (Ref_Clause);
23773 Ref_Clause := Next_Ref_Clause;
23776 -- Depending on the order or composition of refinement clauses, an
23777 -- In_Out state clause may not be directly refinable.
23779 -- Depends => ((Output, State) => (Input, State))
23780 -- Refined_State => (State => (Constit_1, Constit_2))
23781 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23783 -- Matching normalized clause (State => State) fails because there is
23784 -- no direct refinement capable of satisfying this relation. Another
23785 -- similar case arises when clauses (Constit_1 => Input) and (Output
23786 -- => Constit_2) are matched first, leaving no candidates for clause
23787 -- (State => State). Both scenarios are legal as long as one of the
23788 -- previous clauses mentioned a valid constituent of State.
23790 if not Clause_Matched
23791 and then Is_In_Out_State_Clause
23793 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23795 Clause_Matched := True;
23798 -- A clause where the input is an abstract state with visible null
23799 -- refinement is implicitly matched when the output has already been
23800 -- matched in a previous clause.
23802 -- Depends => (Output => State) -- implicitly OK
23803 -- Refined_State => (State => null)
23804 -- Refined_Depends => (Output => ...)
23806 if not Clause_Matched
23807 and then Is_Null_Refined_State (Dep_Input)
23808 and then Is_Entity_Name (Dep_Output)
23810 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23812 Clause_Matched := True;
23815 -- A clause where the output is an abstract state with visible null
23816 -- refinement is implicitly matched when the input has already been
23817 -- matched in a previous clause.
23819 -- Depends => (State => Input) -- implicitly OK
23820 -- Refined_State => (State => null)
23821 -- Refined_Depends => (... => Input)
23823 if not Clause_Matched
23824 and then Is_Null_Refined_State (Dep_Output)
23825 and then Is_Entity_Name (Dep_Input)
23827 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23829 Clause_Matched := True;
23832 -- At this point either all refinement clauses have been examined or
23833 -- pragma Refined_Depends contains a solitary null. Only an abstract
23834 -- state with null refinement can possibly match these cases.
23836 -- Depends => (State => null)
23837 -- Refined_State => (State => null)
23838 -- Refined_Depends => null -- OK
23840 if not Clause_Matched then
23842 (Dep_Item => Dep_Input,
23844 Matched => Inputs_Match);
23847 (Dep_Item => Dep_Output,
23849 Matched => Outputs_Match);
23851 Clause_Matched := Inputs_Match and Outputs_Match;
23854 -- If the contents of Refined_Depends are legal, then the current
23855 -- dependence clause should be satisfied either by an explicit match
23856 -- or by one of the special cases.
23858 if not Clause_Matched then
23860 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
23861 & "matching refinement in body"), Dep_Clause, Spec_Id);
23863 end Check_Dependency_Clause;
23865 -------------------------
23866 -- Check_Output_States --
23867 -------------------------
23869 procedure Check_Output_States is
23870 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23871 -- Determine whether all constituents of state State_Id with visible
23872 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23873 -- error if this is not the case.
23875 -----------------------------
23876 -- Check_Constituent_Usage --
23877 -----------------------------
23879 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23880 Constits : constant Elist_Id :=
23881 Refinement_Constituents (State_Id);
23882 Constit_Elmt : Elmt_Id;
23883 Constit_Id : Entity_Id;
23884 Posted : Boolean := False;
23887 if Present (Constits) then
23888 Constit_Elmt := First_Elmt (Constits);
23889 while Present (Constit_Elmt) loop
23890 Constit_Id := Node (Constit_Elmt);
23892 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23894 if Present (Body_Inputs)
23895 and then Appears_In (Body_Inputs, Constit_Id)
23897 Error_Msg_Name_1 := Chars (State_Id);
23899 ("constituent & of state % must act as output in "
23900 & "dependence refinement", N, Constit_Id);
23902 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23904 elsif No (Body_Outputs)
23905 or else not Appears_In (Body_Outputs, Constit_Id)
23910 ("output state & must be replaced by all its "
23911 & "constituents in dependence refinement",
23916 ("\constituent & is missing in output list",
23920 Next_Elmt (Constit_Elmt);
23923 end Check_Constituent_Usage;
23928 Item_Elmt : Elmt_Id;
23929 Item_Id : Entity_Id;
23931 -- Start of processing for Check_Output_States
23934 -- Do not perform this check in an instance because it was already
23935 -- performed successfully in the generic template.
23937 if Is_Generic_Instance (Spec_Id) then
23940 -- Inspect the outputs of pragma Depends looking for a state with a
23941 -- visible refinement.
23943 elsif Present (Spec_Outputs) then
23944 Item_Elmt := First_Elmt (Spec_Outputs);
23945 while Present (Item_Elmt) loop
23946 Item := Node (Item_Elmt);
23948 -- Deal with the mixed nature of the input and output lists
23950 if Nkind (Item) = N_Defining_Identifier then
23953 Item_Id := Available_View (Entity_Of (Item));
23956 if Ekind (Item_Id) = E_Abstract_State then
23958 -- The state acts as an input-output, skip it
23960 if Present (Spec_Inputs)
23961 and then Appears_In (Spec_Inputs, Item_Id)
23965 -- Ensure that all of the constituents are utilized as
23966 -- outputs in pragma Refined_Depends.
23968 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
23969 Check_Constituent_Usage (Item_Id);
23973 Next_Elmt (Item_Elmt);
23976 end Check_Output_States;
23978 -----------------------
23979 -- Normalize_Clauses --
23980 -----------------------
23982 procedure Normalize_Clauses (Clauses : List_Id) is
23983 procedure Normalize_Inputs (Clause : Node_Id);
23984 -- Normalize clause Clause by creating multiple clauses for each
23985 -- input item of Clause. It is assumed that Clause has exactly one
23986 -- output. The transformation is as follows:
23988 -- Output => (Input_1, Input_2) -- original
23990 -- Output => Input_1 -- normalizations
23991 -- Output => Input_2
23993 procedure Normalize_Outputs (Clause : Node_Id);
23994 -- Normalize clause Clause by creating multiple clause for each
23995 -- output item of Clause. The transformation is as follows:
23997 -- (Output_1, Output_2) => Input -- original
23999 -- Output_1 => Input -- normalization
24000 -- Output_2 => Input
24002 ----------------------
24003 -- Normalize_Inputs --
24004 ----------------------
24006 procedure Normalize_Inputs (Clause : Node_Id) is
24007 Inputs : constant Node_Id := Expression (Clause);
24008 Loc : constant Source_Ptr := Sloc (Clause);
24009 Output : constant List_Id := Choices (Clause);
24010 Last_Input : Node_Id;
24012 New_Clause : Node_Id;
24013 Next_Input : Node_Id;
24016 -- Normalization is performed only when the original clause has
24017 -- more than one input. Multiple inputs appear as an aggregate.
24019 if Nkind (Inputs) = N_Aggregate then
24020 Last_Input := Last (Expressions (Inputs));
24022 -- Create a new clause for each input
24024 Input := First (Expressions (Inputs));
24025 while Present (Input) loop
24026 Next_Input := Next (Input);
24028 -- Unhook the current input from the original input list
24029 -- because it will be relocated to a new clause.
24033 -- Special processing for the last input. At this point the
24034 -- original aggregate has been stripped down to one element.
24035 -- Replace the aggregate by the element itself.
24037 if Input = Last_Input then
24038 Rewrite (Inputs, Input);
24040 -- Generate a clause of the form:
24045 Make_Component_Association (Loc,
24046 Choices => New_Copy_List_Tree (Output),
24047 Expression => Input);
24049 -- The new clause contains replicated content that has
24050 -- already been analyzed, mark the clause as analyzed.
24052 Set_Analyzed (New_Clause);
24053 Insert_After (Clause, New_Clause);
24056 Input := Next_Input;
24059 end Normalize_Inputs;
24061 -----------------------
24062 -- Normalize_Outputs --
24063 -----------------------
24065 procedure Normalize_Outputs (Clause : Node_Id) is
24066 Inputs : constant Node_Id := Expression (Clause);
24067 Loc : constant Source_Ptr := Sloc (Clause);
24068 Outputs : constant Node_Id := First (Choices (Clause));
24069 Last_Output : Node_Id;
24070 New_Clause : Node_Id;
24071 Next_Output : Node_Id;
24075 -- Multiple outputs appear as an aggregate. Nothing to do when
24076 -- the clause has exactly one output.
24078 if Nkind (Outputs) = N_Aggregate then
24079 Last_Output := Last (Expressions (Outputs));
24081 -- Create a clause for each output. Note that each time a new
24082 -- clause is created, the original output list slowly shrinks
24083 -- until there is one item left.
24085 Output := First (Expressions (Outputs));
24086 while Present (Output) loop
24087 Next_Output := Next (Output);
24089 -- Unhook the output from the original output list as it
24090 -- will be relocated to a new clause.
24094 -- Special processing for the last output. At this point
24095 -- the original aggregate has been stripped down to one
24096 -- element. Replace the aggregate by the element itself.
24098 if Output = Last_Output then
24099 Rewrite (Outputs, Output);
24102 -- Generate a clause of the form:
24103 -- (Output => Inputs)
24106 Make_Component_Association (Loc,
24107 Choices => New_List (Output),
24108 Expression => New_Copy_Tree (Inputs));
24110 -- The new clause contains replicated content that has
24111 -- already been analyzed. There is not need to reanalyze
24114 Set_Analyzed (New_Clause);
24115 Insert_After (Clause, New_Clause);
24118 Output := Next_Output;
24121 end Normalize_Outputs;
24127 -- Start of processing for Normalize_Clauses
24130 Clause := First (Clauses);
24131 while Present (Clause) loop
24132 Normalize_Outputs (Clause);
24136 Clause := First (Clauses);
24137 while Present (Clause) loop
24138 Normalize_Inputs (Clause);
24141 end Normalize_Clauses;
24143 --------------------------
24144 -- Report_Extra_Clauses --
24145 --------------------------
24147 procedure Report_Extra_Clauses is
24151 -- Do not perform this check in an instance because it was already
24152 -- performed successfully in the generic template.
24154 if Is_Generic_Instance (Spec_Id) then
24157 elsif Present (Refinements) then
24158 Clause := First (Refinements);
24159 while Present (Clause) loop
24161 -- Do not complain about a null input refinement, since a null
24162 -- input legitimately matches anything.
24164 if Nkind (Clause) = N_Component_Association
24165 and then Nkind (Expression (Clause)) = N_Null
24171 ("unmatched or extra clause in dependence refinement",
24178 end Report_Extra_Clauses;
24182 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24183 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24184 Errors : constant Nat := Serious_Errors_Detected;
24190 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24193 -- Do not analyze the pragma multiple times
24195 if Is_Analyzed_Pragma (N) then
24199 Spec_Id := Unique_Defining_Entity (Body_Decl);
24201 -- Use the anonymous object as the proper spec when Refined_Depends
24202 -- applies to the body of a single task type. The object carries the
24203 -- proper Chars as well as all non-refined versions of pragmas.
24205 if Is_Single_Concurrent_Type (Spec_Id) then
24206 Spec_Id := Anonymous_Object (Spec_Id);
24209 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24211 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24212 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24214 if No (Depends) then
24216 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24217 & "& lacks aspect or pragma Depends"), N, Spec_Id);
24221 Deps := Expression (Get_Argument (Depends, Spec_Id));
24223 -- A null dependency relation renders the refinement useless because it
24224 -- cannot possibly mention abstract states with visible refinement. Note
24225 -- that the inverse is not true as states may be refined to null
24226 -- (SPARK RM 7.2.5(2)).
24228 if Nkind (Deps) = N_Null then
24230 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24231 & "depend on abstract state with visible refinement"), N, Spec_Id);
24235 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24236 -- This ensures that the categorization of all refined dependency items
24237 -- is consistent with their role.
24239 Analyze_Depends_In_Decl_Part (N);
24241 -- Do not match dependencies against refinements if Refined_Depends is
24242 -- illegal to avoid emitting misleading error.
24244 if Serious_Errors_Detected = Errors then
24246 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24247 -- the inputs and outputs of the subprogram spec and body to verify
24248 -- the use of states with visible refinement and their constituents.
24250 if No (Get_Pragma (Spec_Id, Pragma_Global))
24251 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24253 Collect_Subprogram_Inputs_Outputs
24254 (Subp_Id => Spec_Id,
24255 Synthesize => True,
24256 Subp_Inputs => Spec_Inputs,
24257 Subp_Outputs => Spec_Outputs,
24258 Global_Seen => Dummy);
24260 Collect_Subprogram_Inputs_Outputs
24261 (Subp_Id => Body_Id,
24262 Synthesize => True,
24263 Subp_Inputs => Body_Inputs,
24264 Subp_Outputs => Body_Outputs,
24265 Global_Seen => Dummy);
24267 -- For an output state with a visible refinement, ensure that all
24268 -- constituents appear as outputs in the dependency refinement.
24270 Check_Output_States;
24273 -- Matching is disabled in ASIS because clauses are not normalized as
24274 -- this is a tree altering activity similar to expansion.
24280 -- Multiple dependency clauses appear as component associations of an
24281 -- aggregate. Note that the clauses are copied because the algorithm
24282 -- modifies them and this should not be visible in Depends.
24284 pragma Assert (Nkind (Deps) = N_Aggregate);
24285 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24286 Normalize_Clauses (Dependencies);
24288 Refs := Expression (Get_Argument (N, Spec_Id));
24290 if Nkind (Refs) = N_Null then
24291 Refinements := No_List;
24293 -- Multiple dependency clauses appear as component associations of an
24294 -- aggregate. Note that the clauses are copied because the algorithm
24295 -- modifies them and this should not be visible in Refined_Depends.
24297 else pragma Assert (Nkind (Refs) = N_Aggregate);
24298 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24299 Normalize_Clauses (Refinements);
24302 -- At this point the clauses of pragmas Depends and Refined_Depends
24303 -- have been normalized into simple dependencies between one output
24304 -- and one input. Examine all clauses of pragma Depends looking for
24305 -- matching clauses in pragma Refined_Depends.
24307 Clause := First (Dependencies);
24308 while Present (Clause) loop
24309 Check_Dependency_Clause (Clause);
24313 if Serious_Errors_Detected = Errors then
24314 Report_Extra_Clauses;
24319 Set_Is_Analyzed_Pragma (N);
24320 end Analyze_Refined_Depends_In_Decl_Part;
24322 -----------------------------------------
24323 -- Analyze_Refined_Global_In_Decl_Part --
24324 -----------------------------------------
24326 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24328 -- The corresponding Global pragma
24330 Has_In_State : Boolean := False;
24331 Has_In_Out_State : Boolean := False;
24332 Has_Out_State : Boolean := False;
24333 Has_Proof_In_State : Boolean := False;
24334 -- These flags are set when the corresponding Global pragma has a state
24335 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24338 Has_Null_State : Boolean := False;
24339 -- This flag is set when the corresponding Global pragma has at least
24340 -- one state with a null refinement.
24342 In_Constits : Elist_Id := No_Elist;
24343 In_Out_Constits : Elist_Id := No_Elist;
24344 Out_Constits : Elist_Id := No_Elist;
24345 Proof_In_Constits : Elist_Id := No_Elist;
24346 -- These lists contain the entities of all Input, In_Out, Output and
24347 -- Proof_In constituents that appear in Refined_Global and participate
24348 -- in state refinement.
24350 In_Items : Elist_Id := No_Elist;
24351 In_Out_Items : Elist_Id := No_Elist;
24352 Out_Items : Elist_Id := No_Elist;
24353 Proof_In_Items : Elist_Id := No_Elist;
24354 -- These list contain the entities of all Input, In_Out, Output and
24355 -- Proof_In items defined in the corresponding Global pragma.
24357 Spec_Id : Entity_Id;
24358 -- The entity of the subprogram subject to pragma Refined_Global
24360 States : Elist_Id := No_Elist;
24361 -- A list of all states with visible refinement found in pragma Global
24363 procedure Check_In_Out_States;
24364 -- Determine whether the corresponding Global pragma mentions In_Out
24365 -- states with visible refinement and if so, ensure that one of the
24366 -- following completions apply to the constituents of the state:
24367 -- 1) there is at least one constituent of mode In_Out
24368 -- 2) there is at least one Input and one Output constituent
24369 -- 3) not all constituents are present and one of them is of mode
24371 -- This routine may remove elements from In_Constits, In_Out_Constits,
24372 -- Out_Constits and Proof_In_Constits.
24374 procedure Check_Input_States;
24375 -- Determine whether the corresponding Global pragma mentions Input
24376 -- states with visible refinement and if so, ensure that at least one of
24377 -- its constituents appears as an Input item in Refined_Global.
24378 -- This routine may remove elements from In_Constits, In_Out_Constits,
24379 -- Out_Constits and Proof_In_Constits.
24381 procedure Check_Output_States;
24382 -- Determine whether the corresponding Global pragma mentions Output
24383 -- states with visible refinement and if so, ensure that all of its
24384 -- constituents appear as Output items in Refined_Global.
24385 -- This routine may remove elements from In_Constits, In_Out_Constits,
24386 -- Out_Constits and Proof_In_Constits.
24388 procedure Check_Proof_In_States;
24389 -- Determine whether the corresponding Global pragma mentions Proof_In
24390 -- states with visible refinement and if so, ensure that at least one of
24391 -- its constituents appears as a Proof_In item in Refined_Global.
24392 -- This routine may remove elements from In_Constits, In_Out_Constits,
24393 -- Out_Constits and Proof_In_Constits.
24395 procedure Check_Refined_Global_List
24397 Global_Mode : Name_Id := Name_Input);
24398 -- Verify the legality of a single global list declaration. Global_Mode
24399 -- denotes the current mode in effect.
24401 procedure Collect_Global_Items
24403 Mode : Name_Id := Name_Input);
24404 -- Gather all input, in out, output and Proof_In items from node List
24405 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24406 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24407 -- and Has_Proof_In_State are set when there is at least one abstract
24408 -- state with visible refinement available in the corresponding mode.
24409 -- Flag Has_Null_State is set when at least state has a null refinement.
24410 -- Mode enotes the current global mode in effect.
24412 function Present_Then_Remove
24414 Item : Entity_Id) return Boolean;
24415 -- Search List for a particular entity Item. If Item has been found,
24416 -- remove it from List. This routine is used to strip lists In_Constits,
24417 -- In_Out_Constits and Out_Constits of valid constituents.
24419 procedure Report_Extra_Constituents;
24420 -- Emit an error for each constituent found in lists In_Constits,
24421 -- In_Out_Constits and Out_Constits.
24423 -------------------------
24424 -- Check_In_Out_States --
24425 -------------------------
24427 procedure Check_In_Out_States is
24428 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24429 -- Determine whether one of the following coverage scenarios is in
24431 -- 1) there is at least one constituent of mode In_Out or Output
24432 -- 2) there is at least one pair of constituents with modes Input
24433 -- and Output, or Proof_In and Output.
24434 -- 3) there is at least one constituent of mode Output and not all
24435 -- constituents are present.
24436 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24438 -----------------------------
24439 -- Check_Constituent_Usage --
24440 -----------------------------
24442 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24443 Constits : constant Elist_Id :=
24444 Refinement_Constituents (State_Id);
24445 Constit_Elmt : Elmt_Id;
24446 Constit_Id : Entity_Id;
24447 Has_Missing : Boolean := False;
24448 In_Out_Seen : Boolean := False;
24449 Input_Seen : Boolean := False;
24450 Output_Seen : Boolean := False;
24451 Proof_In_Seen : Boolean := False;
24454 -- Process all the constituents of the state and note their modes
24455 -- within the global refinement.
24457 if Present (Constits) then
24458 Constit_Elmt := First_Elmt (Constits);
24459 while Present (Constit_Elmt) loop
24460 Constit_Id := Node (Constit_Elmt);
24462 if Present_Then_Remove (In_Constits, Constit_Id) then
24463 Input_Seen := True;
24465 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24466 In_Out_Seen := True;
24468 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24469 Output_Seen := True;
24471 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24473 Proof_In_Seen := True;
24476 Has_Missing := True;
24479 Next_Elmt (Constit_Elmt);
24483 -- An In_Out constituent is a valid completion
24485 if In_Out_Seen then
24488 -- A pair of one Input/Proof_In and one Output constituent is a
24489 -- valid completion.
24491 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24494 elsif Output_Seen then
24496 -- A single Output constituent is a valid completion only when
24497 -- some of the other constituents are missing.
24499 if Has_Missing then
24502 -- Otherwise all constituents are of mode Output
24506 ("global refinement of state & must include at least one "
24507 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24511 -- The state lacks a completion
24513 elsif not Input_Seen
24514 and not In_Out_Seen
24515 and not Output_Seen
24516 and not Proof_In_Seen
24519 ("missing global refinement of state &", N, State_Id);
24521 -- Otherwise the state has a malformed completion where at least
24522 -- one of the constituents has a different mode.
24526 ("global refinement of state & redefines the mode of its "
24527 & "constituents", N, State_Id);
24529 end Check_Constituent_Usage;
24533 Item_Elmt : Elmt_Id;
24534 Item_Id : Entity_Id;
24536 -- Start of processing for Check_In_Out_States
24539 -- Do not perform this check in an instance because it was already
24540 -- performed successfully in the generic template.
24542 if Is_Generic_Instance (Spec_Id) then
24545 -- Inspect the In_Out items of the corresponding Global pragma
24546 -- looking for a state with a visible refinement.
24548 elsif Has_In_Out_State and then Present (In_Out_Items) then
24549 Item_Elmt := First_Elmt (In_Out_Items);
24550 while Present (Item_Elmt) loop
24551 Item_Id := Node (Item_Elmt);
24553 -- Ensure that one of the three coverage variants is satisfied
24555 if Ekind (Item_Id) = E_Abstract_State
24556 and then Has_Non_Null_Visible_Refinement (Item_Id)
24558 Check_Constituent_Usage (Item_Id);
24561 Next_Elmt (Item_Elmt);
24564 end Check_In_Out_States;
24566 ------------------------
24567 -- Check_Input_States --
24568 ------------------------
24570 procedure Check_Input_States is
24571 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24572 -- Determine whether at least one constituent of state State_Id with
24573 -- visible refinement is used and has mode Input. Ensure that the
24574 -- remaining constituents do not have In_Out or Output modes. Emit an
24575 -- error if this is not the case (SPARK RM 7.2.4(5)).
24577 -----------------------------
24578 -- Check_Constituent_Usage --
24579 -----------------------------
24581 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24582 Constits : constant Elist_Id :=
24583 Refinement_Constituents (State_Id);
24584 Constit_Elmt : Elmt_Id;
24585 Constit_Id : Entity_Id;
24586 In_Seen : Boolean := False;
24589 if Present (Constits) then
24590 Constit_Elmt := First_Elmt (Constits);
24591 while Present (Constit_Elmt) loop
24592 Constit_Id := Node (Constit_Elmt);
24594 -- At least one of the constituents appears as an Input
24596 if Present_Then_Remove (In_Constits, Constit_Id) then
24599 -- A Proof_In constituent can refine an Input state as long
24600 -- as there is at least one Input constituent present.
24602 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24606 -- The constituent appears in the global refinement, but has
24607 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24609 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24610 or else Present_Then_Remove (Out_Constits, Constit_Id)
24612 Error_Msg_Name_1 := Chars (State_Id);
24614 ("constituent & of state % must have mode `Input` in "
24615 & "global refinement", N, Constit_Id);
24618 Next_Elmt (Constit_Elmt);
24622 -- Not one of the constituents appeared as Input
24624 if not In_Seen then
24626 ("global refinement of state & must include at least one "
24627 & "constituent of mode `Input`", N, State_Id);
24629 end Check_Constituent_Usage;
24633 Item_Elmt : Elmt_Id;
24634 Item_Id : Entity_Id;
24636 -- Start of processing for Check_Input_States
24639 -- Do not perform this check in an instance because it was already
24640 -- performed successfully in the generic template.
24642 if Is_Generic_Instance (Spec_Id) then
24645 -- Inspect the Input items of the corresponding Global pragma looking
24646 -- for a state with a visible refinement.
24648 elsif Has_In_State and then Present (In_Items) then
24649 Item_Elmt := First_Elmt (In_Items);
24650 while Present (Item_Elmt) loop
24651 Item_Id := Node (Item_Elmt);
24653 -- Ensure that at least one of the constituents is utilized and
24654 -- is of mode Input.
24656 if Ekind (Item_Id) = E_Abstract_State
24657 and then Has_Non_Null_Visible_Refinement (Item_Id)
24659 Check_Constituent_Usage (Item_Id);
24662 Next_Elmt (Item_Elmt);
24665 end Check_Input_States;
24667 -------------------------
24668 -- Check_Output_States --
24669 -------------------------
24671 procedure Check_Output_States is
24672 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24673 -- Determine whether all constituents of state State_Id with visible
24674 -- refinement are used and have mode Output. Emit an error if this is
24675 -- not the case (SPARK RM 7.2.4(5)).
24677 -----------------------------
24678 -- Check_Constituent_Usage --
24679 -----------------------------
24681 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24682 Constits : constant Elist_Id :=
24683 Refinement_Constituents (State_Id);
24684 Constit_Elmt : Elmt_Id;
24685 Constit_Id : Entity_Id;
24686 Posted : Boolean := False;
24689 if Present (Constits) then
24690 Constit_Elmt := First_Elmt (Constits);
24691 while Present (Constit_Elmt) loop
24692 Constit_Id := Node (Constit_Elmt);
24694 if Present_Then_Remove (Out_Constits, Constit_Id) then
24697 -- The constituent appears in the global refinement, but has
24698 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24700 elsif Present_Then_Remove (In_Constits, Constit_Id)
24701 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24702 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24704 Error_Msg_Name_1 := Chars (State_Id);
24706 ("constituent & of state % must have mode `Output` in "
24707 & "global refinement", N, Constit_Id);
24709 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24715 ("`Output` state & must be replaced by all its "
24716 & "constituents in global refinement", N, State_Id);
24720 ("\constituent & is missing in output list",
24724 Next_Elmt (Constit_Elmt);
24727 end Check_Constituent_Usage;
24731 Item_Elmt : Elmt_Id;
24732 Item_Id : Entity_Id;
24734 -- Start of processing for Check_Output_States
24737 -- Do not perform this check in an instance because it was already
24738 -- performed successfully in the generic template.
24740 if Is_Generic_Instance (Spec_Id) then
24743 -- Inspect the Output items of the corresponding Global pragma
24744 -- looking for a state with a visible refinement.
24746 elsif Has_Out_State and then Present (Out_Items) then
24747 Item_Elmt := First_Elmt (Out_Items);
24748 while Present (Item_Elmt) loop
24749 Item_Id := Node (Item_Elmt);
24751 -- Ensure that all of the constituents are utilized and they
24752 -- have mode Output.
24754 if Ekind (Item_Id) = E_Abstract_State
24755 and then Has_Non_Null_Visible_Refinement (Item_Id)
24757 Check_Constituent_Usage (Item_Id);
24760 Next_Elmt (Item_Elmt);
24763 end Check_Output_States;
24765 ---------------------------
24766 -- Check_Proof_In_States --
24767 ---------------------------
24769 procedure Check_Proof_In_States is
24770 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24771 -- Determine whether at least one constituent of state State_Id with
24772 -- visible refinement is used and has mode Proof_In. Ensure that the
24773 -- remaining constituents do not have Input, In_Out or Output modes.
24774 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24776 -----------------------------
24777 -- Check_Constituent_Usage --
24778 -----------------------------
24780 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24781 Constits : constant Elist_Id :=
24782 Refinement_Constituents (State_Id);
24783 Constit_Elmt : Elmt_Id;
24784 Constit_Id : Entity_Id;
24785 Proof_In_Seen : Boolean := False;
24788 if Present (Constits) then
24789 Constit_Elmt := First_Elmt (Constits);
24790 while Present (Constit_Elmt) loop
24791 Constit_Id := Node (Constit_Elmt);
24793 -- At least one of the constituents appears as Proof_In
24795 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24796 Proof_In_Seen := True;
24798 -- The constituent appears in the global refinement, but has
24799 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24801 elsif Present_Then_Remove (In_Constits, Constit_Id)
24802 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24803 or else Present_Then_Remove (Out_Constits, Constit_Id)
24805 Error_Msg_Name_1 := Chars (State_Id);
24807 ("constituent & of state % must have mode `Proof_In` "
24808 & "in global refinement", N, Constit_Id);
24811 Next_Elmt (Constit_Elmt);
24815 -- Not one of the constituents appeared as Proof_In
24817 if not Proof_In_Seen then
24819 ("global refinement of state & must include at least one "
24820 & "constituent of mode `Proof_In`", N, State_Id);
24822 end Check_Constituent_Usage;
24826 Item_Elmt : Elmt_Id;
24827 Item_Id : Entity_Id;
24829 -- Start of processing for Check_Proof_In_States
24832 -- Do not perform this check in an instance because it was already
24833 -- performed successfully in the generic template.
24835 if Is_Generic_Instance (Spec_Id) then
24838 -- Inspect the Proof_In items of the corresponding Global pragma
24839 -- looking for a state with a visible refinement.
24841 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
24842 Item_Elmt := First_Elmt (Proof_In_Items);
24843 while Present (Item_Elmt) loop
24844 Item_Id := Node (Item_Elmt);
24846 -- Ensure that at least one of the constituents is utilized and
24847 -- is of mode Proof_In
24849 if Ekind (Item_Id) = E_Abstract_State
24850 and then Has_Non_Null_Visible_Refinement (Item_Id)
24852 Check_Constituent_Usage (Item_Id);
24855 Next_Elmt (Item_Elmt);
24858 end Check_Proof_In_States;
24860 -------------------------------
24861 -- Check_Refined_Global_List --
24862 -------------------------------
24864 procedure Check_Refined_Global_List
24866 Global_Mode : Name_Id := Name_Input)
24868 procedure Check_Refined_Global_Item
24870 Global_Mode : Name_Id);
24871 -- Verify the legality of a single global item declaration. Parameter
24872 -- Global_Mode denotes the current mode in effect.
24874 -------------------------------
24875 -- Check_Refined_Global_Item --
24876 -------------------------------
24878 procedure Check_Refined_Global_Item
24880 Global_Mode : Name_Id)
24882 Item_Id : constant Entity_Id := Entity_Of (Item);
24884 procedure Inconsistent_Mode_Error (Expect : Name_Id);
24885 -- Issue a common error message for all mode mismatches. Expect
24886 -- denotes the expected mode.
24888 -----------------------------
24889 -- Inconsistent_Mode_Error --
24890 -----------------------------
24892 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
24895 ("global item & has inconsistent modes", Item, Item_Id);
24897 Error_Msg_Name_1 := Global_Mode;
24898 Error_Msg_Name_2 := Expect;
24899 SPARK_Msg_N ("\expected mode %, found mode %", Item);
24900 end Inconsistent_Mode_Error;
24902 -- Start of processing for Check_Refined_Global_Item
24905 -- When the state or object acts as a constituent of another
24906 -- state with a visible refinement, collect it for the state
24907 -- completeness checks performed later on. Note that the item
24908 -- acts as a constituent only when the encapsulating state is
24909 -- present in pragma Global.
24911 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
24912 and then Present (Encapsulating_State (Item_Id))
24913 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
24914 and then Contains (States, Encapsulating_State (Item_Id))
24916 if Global_Mode = Name_Input then
24917 Append_New_Elmt (Item_Id, In_Constits);
24919 elsif Global_Mode = Name_In_Out then
24920 Append_New_Elmt (Item_Id, In_Out_Constits);
24922 elsif Global_Mode = Name_Output then
24923 Append_New_Elmt (Item_Id, Out_Constits);
24925 elsif Global_Mode = Name_Proof_In then
24926 Append_New_Elmt (Item_Id, Proof_In_Constits);
24929 -- When not a constituent, ensure that both occurrences of the
24930 -- item in pragmas Global and Refined_Global match.
24932 elsif Contains (In_Items, Item_Id) then
24933 if Global_Mode /= Name_Input then
24934 Inconsistent_Mode_Error (Name_Input);
24937 elsif Contains (In_Out_Items, Item_Id) then
24938 if Global_Mode /= Name_In_Out then
24939 Inconsistent_Mode_Error (Name_In_Out);
24942 elsif Contains (Out_Items, Item_Id) then
24943 if Global_Mode /= Name_Output then
24944 Inconsistent_Mode_Error (Name_Output);
24947 elsif Contains (Proof_In_Items, Item_Id) then
24950 -- The item does not appear in the corresponding Global pragma,
24951 -- it must be an extra (SPARK RM 7.2.4(3)).
24954 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
24956 end Check_Refined_Global_Item;
24962 -- Start of processing for Check_Refined_Global_List
24965 -- Do not perform this check in an instance because it was already
24966 -- performed successfully in the generic template.
24968 if Is_Generic_Instance (Spec_Id) then
24971 elsif Nkind (List) = N_Null then
24974 -- Single global item declaration
24976 elsif Nkind_In (List, N_Expanded_Name,
24978 N_Selected_Component)
24980 Check_Refined_Global_Item (List, Global_Mode);
24982 -- Simple global list or moded global list declaration
24984 elsif Nkind (List) = N_Aggregate then
24986 -- The declaration of a simple global list appear as a collection
24989 if Present (Expressions (List)) then
24990 Item := First (Expressions (List));
24991 while Present (Item) loop
24992 Check_Refined_Global_Item (Item, Global_Mode);
24996 -- The declaration of a moded global list appears as a collection
24997 -- of component associations where individual choices denote
25000 elsif Present (Component_Associations (List)) then
25001 Item := First (Component_Associations (List));
25002 while Present (Item) loop
25003 Check_Refined_Global_List
25004 (List => Expression (Item),
25005 Global_Mode => Chars (First (Choices (Item))));
25013 raise Program_Error;
25019 raise Program_Error;
25021 end Check_Refined_Global_List;
25023 --------------------------
25024 -- Collect_Global_Items --
25025 --------------------------
25027 procedure Collect_Global_Items
25029 Mode : Name_Id := Name_Input)
25031 procedure Collect_Global_Item
25033 Item_Mode : Name_Id);
25034 -- Add a single item to the appropriate list. Item_Mode denotes the
25035 -- current mode in effect.
25037 -------------------------
25038 -- Collect_Global_Item --
25039 -------------------------
25041 procedure Collect_Global_Item
25043 Item_Mode : Name_Id)
25045 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25046 -- The above handles abstract views of variables and states built
25047 -- for limited with clauses.
25050 -- Signal that the global list contains at least one abstract
25051 -- state with a visible refinement. Note that the refinement may
25052 -- be null in which case there are no constituents.
25054 if Ekind (Item_Id) = E_Abstract_State then
25055 if Has_Null_Visible_Refinement (Item_Id) then
25056 Has_Null_State := True;
25058 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25059 Append_New_Elmt (Item_Id, States);
25061 if Item_Mode = Name_Input then
25062 Has_In_State := True;
25063 elsif Item_Mode = Name_In_Out then
25064 Has_In_Out_State := True;
25065 elsif Item_Mode = Name_Output then
25066 Has_Out_State := True;
25067 elsif Item_Mode = Name_Proof_In then
25068 Has_Proof_In_State := True;
25073 -- Add the item to the proper list
25075 if Item_Mode = Name_Input then
25076 Append_New_Elmt (Item_Id, In_Items);
25077 elsif Item_Mode = Name_In_Out then
25078 Append_New_Elmt (Item_Id, In_Out_Items);
25079 elsif Item_Mode = Name_Output then
25080 Append_New_Elmt (Item_Id, Out_Items);
25081 elsif Item_Mode = Name_Proof_In then
25082 Append_New_Elmt (Item_Id, Proof_In_Items);
25084 end Collect_Global_Item;
25090 -- Start of processing for Collect_Global_Items
25093 if Nkind (List) = N_Null then
25096 -- Single global item declaration
25098 elsif Nkind_In (List, N_Expanded_Name,
25100 N_Selected_Component)
25102 Collect_Global_Item (List, Mode);
25104 -- Single global list or moded global list declaration
25106 elsif Nkind (List) = N_Aggregate then
25108 -- The declaration of a simple global list appear as a collection
25111 if Present (Expressions (List)) then
25112 Item := First (Expressions (List));
25113 while Present (Item) loop
25114 Collect_Global_Item (Item, Mode);
25118 -- The declaration of a moded global list appears as a collection
25119 -- of component associations where individual choices denote mode.
25121 elsif Present (Component_Associations (List)) then
25122 Item := First (Component_Associations (List));
25123 while Present (Item) loop
25124 Collect_Global_Items
25125 (List => Expression (Item),
25126 Mode => Chars (First (Choices (Item))));
25134 raise Program_Error;
25137 -- To accomodate partial decoration of disabled SPARK features, this
25138 -- routine may be called with illegal input. If this is the case, do
25139 -- not raise Program_Error.
25144 end Collect_Global_Items;
25146 -------------------------
25147 -- Present_Then_Remove --
25148 -------------------------
25150 function Present_Then_Remove
25152 Item : Entity_Id) return Boolean
25157 if Present (List) then
25158 Elmt := First_Elmt (List);
25159 while Present (Elmt) loop
25160 if Node (Elmt) = Item then
25161 Remove_Elmt (List, Elmt);
25170 end Present_Then_Remove;
25172 -------------------------------
25173 -- Report_Extra_Constituents --
25174 -------------------------------
25176 procedure Report_Extra_Constituents is
25177 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25178 -- Emit an error for every element of List
25180 ---------------------------------------
25181 -- Report_Extra_Constituents_In_List --
25182 ---------------------------------------
25184 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25185 Constit_Elmt : Elmt_Id;
25188 if Present (List) then
25189 Constit_Elmt := First_Elmt (List);
25190 while Present (Constit_Elmt) loop
25191 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25192 Next_Elmt (Constit_Elmt);
25195 end Report_Extra_Constituents_In_List;
25197 -- Start of processing for Report_Extra_Constituents
25200 -- Do not perform this check in an instance because it was already
25201 -- performed successfully in the generic template.
25203 if Is_Generic_Instance (Spec_Id) then
25207 Report_Extra_Constituents_In_List (In_Constits);
25208 Report_Extra_Constituents_In_List (In_Out_Constits);
25209 Report_Extra_Constituents_In_List (Out_Constits);
25210 Report_Extra_Constituents_In_List (Proof_In_Constits);
25212 end Report_Extra_Constituents;
25216 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25217 Errors : constant Nat := Serious_Errors_Detected;
25220 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25223 -- Do not analyze the pragma multiple times
25225 if Is_Analyzed_Pragma (N) then
25229 Spec_Id := Unique_Defining_Entity (Body_Decl);
25231 -- Use the anonymous object as the proper spec when Refined_Global
25232 -- applies to the body of a single task type. The object carries the
25233 -- proper Chars as well as all non-refined versions of pragmas.
25235 if Is_Single_Concurrent_Type (Spec_Id) then
25236 Spec_Id := Anonymous_Object (Spec_Id);
25239 Global := Get_Pragma (Spec_Id, Pragma_Global);
25240 Items := Expression (Get_Argument (N, Spec_Id));
25242 -- The subprogram declaration lacks pragma Global. This renders
25243 -- Refined_Global useless as there is nothing to refine.
25245 if No (Global) then
25247 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25248 & "& lacks aspect or pragma Global"), N, Spec_Id);
25252 -- Extract all relevant items from the corresponding Global pragma
25254 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25256 -- Package and subprogram bodies are instantiated individually in
25257 -- a separate compiler pass. Due to this mode of instantiation, the
25258 -- refinement of a state may no longer be visible when a subprogram
25259 -- body contract is instantiated. Since the generic template is legal,
25260 -- do not perform this check in the instance to circumvent this oddity.
25262 if Is_Generic_Instance (Spec_Id) then
25265 -- Non-instance case
25268 -- The corresponding Global pragma must mention at least one state
25269 -- witha visible refinement at the point Refined_Global is processed.
25270 -- States with null refinements need Refined_Global pragma
25271 -- (SPARK RM 7.2.4(2)).
25273 if not Has_In_State
25274 and then not Has_In_Out_State
25275 and then not Has_Out_State
25276 and then not Has_Proof_In_State
25277 and then not Has_Null_State
25280 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25281 & "depend on abstract state with visible refinement"),
25285 -- The global refinement of inputs and outputs cannot be null when
25286 -- the corresponding Global pragma contains at least one item except
25287 -- in the case where we have states with null refinements.
25289 elsif Nkind (Items) = N_Null
25291 (Present (In_Items)
25292 or else Present (In_Out_Items)
25293 or else Present (Out_Items)
25294 or else Present (Proof_In_Items))
25295 and then not Has_Null_State
25298 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25299 & "global items"), N, Spec_Id);
25304 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25305 -- This ensures that the categorization of all refined global items is
25306 -- consistent with their role.
25308 Analyze_Global_In_Decl_Part (N);
25310 -- Perform all refinement checks with respect to completeness and mode
25313 if Serious_Errors_Detected = Errors then
25314 Check_Refined_Global_List (Items);
25317 -- For Input states with visible refinement, at least one constituent
25318 -- must be used as an Input in the global refinement.
25320 if Serious_Errors_Detected = Errors then
25321 Check_Input_States;
25324 -- Verify all possible completion variants for In_Out states with
25325 -- visible refinement.
25327 if Serious_Errors_Detected = Errors then
25328 Check_In_Out_States;
25331 -- For Output states with visible refinement, all constituents must be
25332 -- used as Outputs in the global refinement.
25334 if Serious_Errors_Detected = Errors then
25335 Check_Output_States;
25338 -- For Proof_In states with visible refinement, at least one constituent
25339 -- must be used as Proof_In in the global refinement.
25341 if Serious_Errors_Detected = Errors then
25342 Check_Proof_In_States;
25345 -- Emit errors for all constituents that belong to other states with
25346 -- visible refinement that do not appear in Global.
25348 if Serious_Errors_Detected = Errors then
25349 Report_Extra_Constituents;
25353 Set_Is_Analyzed_Pragma (N);
25354 end Analyze_Refined_Global_In_Decl_Part;
25356 ----------------------------------------
25357 -- Analyze_Refined_State_In_Decl_Part --
25358 ----------------------------------------
25360 procedure Analyze_Refined_State_In_Decl_Part
25362 Freeze_Id : Entity_Id := Empty)
25364 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
25365 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25366 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
25368 Available_States : Elist_Id := No_Elist;
25369 -- A list of all abstract states defined in the package declaration that
25370 -- are available for refinement. The list is used to report unrefined
25373 Body_States : Elist_Id := No_Elist;
25374 -- A list of all hidden states that appear in the body of the related
25375 -- package. The list is used to report unused hidden states.
25377 Constituents_Seen : Elist_Id := No_Elist;
25378 -- A list that contains all constituents processed so far. The list is
25379 -- used to detect multiple uses of the same constituent.
25381 Freeze_Posted : Boolean := False;
25382 -- A flag that controls the output of a freezing-related error (see use
25385 Refined_States_Seen : Elist_Id := No_Elist;
25386 -- A list that contains all refined states processed so far. The list is
25387 -- used to detect duplicate refinements.
25389 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25390 -- Perform full analysis of a single refinement clause
25392 procedure Report_Unrefined_States (States : Elist_Id);
25393 -- Emit errors for all unrefined abstract states found in list States
25395 -------------------------------
25396 -- Analyze_Refinement_Clause --
25397 -------------------------------
25399 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25400 AR_Constit : Entity_Id := Empty;
25401 AW_Constit : Entity_Id := Empty;
25402 ER_Constit : Entity_Id := Empty;
25403 EW_Constit : Entity_Id := Empty;
25404 -- The entities of external constituents that contain one of the
25405 -- following enabled properties: Async_Readers, Async_Writers,
25406 -- Effective_Reads and Effective_Writes.
25408 External_Constit_Seen : Boolean := False;
25409 -- Flag used to mark when at least one external constituent is part
25410 -- of the state refinement.
25412 Non_Null_Seen : Boolean := False;
25413 Null_Seen : Boolean := False;
25414 -- Flags used to detect multiple uses of null in a single clause or a
25415 -- mixture of null and non-null constituents.
25417 Part_Of_Constits : Elist_Id := No_Elist;
25418 -- A list of all candidate constituents subject to indicator Part_Of
25419 -- where the encapsulating state is the current state.
25422 State_Id : Entity_Id;
25423 -- The current state being refined
25425 procedure Analyze_Constituent (Constit : Node_Id);
25426 -- Perform full analysis of a single constituent
25428 procedure Check_External_Property
25429 (Prop_Nam : Name_Id;
25431 Constit : Entity_Id);
25432 -- Determine whether a property denoted by name Prop_Nam is present
25433 -- in the refined state. Emit an error if this is not the case. Flag
25434 -- Enabled should be set when the property applies to the refined
25435 -- state. Constit denotes the constituent (if any) which introduces
25436 -- the property in the refinement.
25438 procedure Match_State;
25439 -- Determine whether the state being refined appears in list
25440 -- Available_States. Emit an error when attempting to re-refine the
25441 -- state or when the state is not defined in the package declaration,
25442 -- otherwise remove the state from Available_States.
25444 procedure Report_Unused_Constituents (Constits : Elist_Id);
25445 -- Emit errors for all unused Part_Of constituents in list Constits
25447 -------------------------
25448 -- Analyze_Constituent --
25449 -------------------------
25451 procedure Analyze_Constituent (Constit : Node_Id) is
25452 procedure Match_Constituent (Constit_Id : Entity_Id);
25453 -- Determine whether constituent Constit denoted by its entity
25454 -- Constit_Id appears in Body_States. Emit an error when the
25455 -- constituent is not a valid hidden state of the related package
25456 -- or when it is used more than once. Otherwise remove the
25457 -- constituent from Body_States.
25459 -----------------------
25460 -- Match_Constituent --
25461 -----------------------
25463 procedure Match_Constituent (Constit_Id : Entity_Id) is
25464 procedure Collect_Constituent;
25465 -- Verify the legality of constituent Constit_Id and add it to
25466 -- the refinements of State_Id.
25468 -------------------------
25469 -- Collect_Constituent --
25470 -------------------------
25472 procedure Collect_Constituent is
25473 Constits : Elist_Id;
25476 -- The Ghost policy in effect at the point of abstract state
25477 -- declaration and constituent must match (SPARK RM 6.9(15))
25479 Check_Ghost_Refinement
25480 (State, State_Id, Constit, Constit_Id);
25482 -- A synchronized state must be refined by a synchronized
25483 -- object or another synchronized state (SPARK RM 9.6).
25485 if Is_Synchronized_State (State_Id)
25486 and then not Is_Synchronized_Object (Constit_Id)
25487 and then not Is_Synchronized_State (Constit_Id)
25490 ("constituent of synchronized state & must be "
25491 & "synchronized", Constit, State_Id);
25494 -- Add the constituent to the list of processed items to aid
25495 -- with the detection of duplicates.
25497 Append_New_Elmt (Constit_Id, Constituents_Seen);
25499 -- Collect the constituent in the list of refinement items
25500 -- and establish a relation between the refined state and
25503 Constits := Refinement_Constituents (State_Id);
25505 if No (Constits) then
25506 Constits := New_Elmt_List;
25507 Set_Refinement_Constituents (State_Id, Constits);
25510 Append_Elmt (Constit_Id, Constits);
25511 Set_Encapsulating_State (Constit_Id, State_Id);
25513 -- The state has at least one legal constituent, mark the
25514 -- start of the refinement region. The region ends when the
25515 -- body declarations end (see routine Analyze_Declarations).
25517 Set_Has_Visible_Refinement (State_Id);
25519 -- When the constituent is external, save its relevant
25520 -- property for further checks.
25522 if Async_Readers_Enabled (Constit_Id) then
25523 AR_Constit := Constit_Id;
25524 External_Constit_Seen := True;
25527 if Async_Writers_Enabled (Constit_Id) then
25528 AW_Constit := Constit_Id;
25529 External_Constit_Seen := True;
25532 if Effective_Reads_Enabled (Constit_Id) then
25533 ER_Constit := Constit_Id;
25534 External_Constit_Seen := True;
25537 if Effective_Writes_Enabled (Constit_Id) then
25538 EW_Constit := Constit_Id;
25539 External_Constit_Seen := True;
25541 end Collect_Constituent;
25545 State_Elmt : Elmt_Id;
25547 -- Start of processing for Match_Constituent
25550 -- Detect a duplicate use of a constituent
25552 if Contains (Constituents_Seen, Constit_Id) then
25554 ("duplicate use of constituent &", Constit, Constit_Id);
25558 -- The constituent is subject to a Part_Of indicator
25560 if Present (Encapsulating_State (Constit_Id)) then
25561 if Encapsulating_State (Constit_Id) = State_Id then
25562 Remove (Part_Of_Constits, Constit_Id);
25563 Collect_Constituent;
25565 -- The constituent is part of another state and is used
25566 -- incorrectly in the refinement of the current state.
25569 Error_Msg_Name_1 := Chars (State_Id);
25571 ("& cannot act as constituent of state %",
25572 Constit, Constit_Id);
25574 ("\Part_Of indicator specifies encapsulator &",
25575 Constit, Encapsulating_State (Constit_Id));
25578 -- The only other source of legal constituents is the body
25579 -- state space of the related package.
25582 if Present (Body_States) then
25583 State_Elmt := First_Elmt (Body_States);
25584 while Present (State_Elmt) loop
25586 -- Consume a valid constituent to signal that it has
25587 -- been encountered.
25589 if Node (State_Elmt) = Constit_Id then
25590 Remove_Elmt (Body_States, State_Elmt);
25591 Collect_Constituent;
25595 Next_Elmt (State_Elmt);
25599 -- Constants are part of the hidden state of a package, but
25600 -- the compiler cannot determine whether they have variable
25601 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25602 -- hidden state. Accept the constant quietly even if it is
25603 -- a visible state or lacks a Part_Of indicator.
25605 if Ekind (Constit_Id) = E_Constant then
25606 Collect_Constituent;
25608 -- If we get here, then the constituent is not a hidden
25609 -- state of the related package and may not be used in a
25610 -- refinement (SPARK RM 7.2.2(9)).
25613 Error_Msg_Name_1 := Chars (Spec_Id);
25615 ("cannot use & in refinement, constituent is not a "
25616 & "hidden state of package %", Constit, Constit_Id);
25619 end Match_Constituent;
25623 Constit_Id : Entity_Id;
25624 Constits : Elist_Id;
25626 -- Start of processing for Analyze_Constituent
25629 -- Detect multiple uses of null in a single refinement clause or a
25630 -- mixture of null and non-null constituents.
25632 if Nkind (Constit) = N_Null then
25635 ("multiple null constituents not allowed", Constit);
25637 elsif Non_Null_Seen then
25639 ("cannot mix null and non-null constituents", Constit);
25644 -- Collect the constituent in the list of refinement items
25646 Constits := Refinement_Constituents (State_Id);
25648 if No (Constits) then
25649 Constits := New_Elmt_List;
25650 Set_Refinement_Constituents (State_Id, Constits);
25653 Append_Elmt (Constit, Constits);
25655 -- The state has at least one legal constituent, mark the
25656 -- start of the refinement region. The region ends when the
25657 -- body declarations end (see Analyze_Declarations).
25659 Set_Has_Visible_Refinement (State_Id);
25662 -- Non-null constituents
25665 Non_Null_Seen := True;
25669 ("cannot mix null and non-null constituents", Constit);
25673 Resolve_State (Constit);
25675 -- Ensure that the constituent denotes a valid state or a
25676 -- whole object (SPARK RM 7.2.2(5)).
25678 if Is_Entity_Name (Constit) then
25679 Constit_Id := Entity_Of (Constit);
25681 -- When a constituent is declared after a subprogram body
25682 -- that caused "freezing" of the related contract where
25683 -- pragma Refined_State resides, the constituent appears
25684 -- undefined and carries Any_Id as its entity.
25686 -- package body Pack
25687 -- with Refined_State => (State => Constit)
25690 -- with Refined_Global => (Input => Constit)
25698 if Constit_Id = Any_Id then
25699 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25701 -- Emit a specialized info message when the contract of
25702 -- the related package body was "frozen" by another body.
25703 -- Note that it is not possible to precisely identify why
25704 -- the constituent is undefined because it is not visible
25705 -- when pragma Refined_State is analyzed. This message is
25706 -- a reasonable approximation.
25708 if Present (Freeze_Id) and then not Freeze_Posted then
25709 Freeze_Posted := True;
25711 Error_Msg_Name_1 := Chars (Body_Id);
25712 Error_Msg_Sloc := Sloc (Freeze_Id);
25714 ("body & declared # freezes the contract of %",
25717 ("\all constituents must be declared before body #",
25720 -- A misplaced constituent is a critical error because
25721 -- pragma Refined_Depends or Refined_Global depends on
25722 -- the proper link between a state and a constituent.
25723 -- Stop the compilation, as this leads to a multitude
25724 -- of misleading cascaded errors.
25726 raise Program_Error;
25729 -- The constituent is a valid state or object
25731 elsif Ekind_In (Constit_Id, E_Abstract_State,
25735 Match_Constituent (Constit_Id);
25737 -- The variable may eventually become a constituent of a
25738 -- single protected/task type. Record the reference now
25739 -- and verify its legality when analyzing the contract of
25740 -- the variable (SPARK RM 9.3).
25742 if Ekind (Constit_Id) = E_Variable then
25743 Record_Possible_Part_Of_Reference
25744 (Var_Id => Constit_Id,
25748 -- Otherwise the constituent is illegal
25752 ("constituent & must denote object or state",
25753 Constit, Constit_Id);
25756 -- The constituent is illegal
25759 SPARK_Msg_N ("malformed constituent", Constit);
25762 end Analyze_Constituent;
25764 -----------------------------
25765 -- Check_External_Property --
25766 -----------------------------
25768 procedure Check_External_Property
25769 (Prop_Nam : Name_Id;
25771 Constit : Entity_Id)
25774 -- The property is missing in the declaration of the state, but
25775 -- a constituent is introducing it in the state refinement
25776 -- (SPARK RM 7.2.8(2)).
25778 if not Enabled and then Present (Constit) then
25779 Error_Msg_Name_1 := Prop_Nam;
25780 Error_Msg_Name_2 := Chars (State_Id);
25782 ("constituent & introduces external property % in refinement "
25783 & "of state %", State, Constit);
25785 Error_Msg_Sloc := Sloc (State_Id);
25787 ("\property is missing in abstract state declaration #",
25790 end Check_External_Property;
25796 procedure Match_State is
25797 State_Elmt : Elmt_Id;
25800 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25802 if Contains (Refined_States_Seen, State_Id) then
25804 ("duplicate refinement of state &", State, State_Id);
25808 -- Inspect the abstract states defined in the package declaration
25809 -- looking for a match.
25811 State_Elmt := First_Elmt (Available_States);
25812 while Present (State_Elmt) loop
25814 -- A valid abstract state is being refined in the body. Add
25815 -- the state to the list of processed refined states to aid
25816 -- with the detection of duplicate refinements. Remove the
25817 -- state from Available_States to signal that it has already
25820 if Node (State_Elmt) = State_Id then
25821 Append_New_Elmt (State_Id, Refined_States_Seen);
25822 Remove_Elmt (Available_States, State_Elmt);
25826 Next_Elmt (State_Elmt);
25829 -- If we get here, we are refining a state that is not defined in
25830 -- the package declaration.
25832 Error_Msg_Name_1 := Chars (Spec_Id);
25834 ("cannot refine state, & is not defined in package %",
25838 --------------------------------
25839 -- Report_Unused_Constituents --
25840 --------------------------------
25842 procedure Report_Unused_Constituents (Constits : Elist_Id) is
25843 Constit_Elmt : Elmt_Id;
25844 Constit_Id : Entity_Id;
25845 Posted : Boolean := False;
25848 if Present (Constits) then
25849 Constit_Elmt := First_Elmt (Constits);
25850 while Present (Constit_Elmt) loop
25851 Constit_Id := Node (Constit_Elmt);
25853 -- Generate an error message of the form:
25855 -- state ... has unused Part_Of constituents
25856 -- abstract state ... defined at ...
25857 -- constant ... defined at ...
25858 -- variable ... defined at ...
25863 ("state & has unused Part_Of constituents",
25867 Error_Msg_Sloc := Sloc (Constit_Id);
25869 if Ekind (Constit_Id) = E_Abstract_State then
25871 ("\abstract state & defined #", State, Constit_Id);
25873 elsif Ekind (Constit_Id) = E_Constant then
25875 ("\constant & defined #", State, Constit_Id);
25878 pragma Assert (Ekind (Constit_Id) = E_Variable);
25879 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
25882 Next_Elmt (Constit_Elmt);
25885 end Report_Unused_Constituents;
25887 -- Local declarations
25889 Body_Ref : Node_Id;
25890 Body_Ref_Elmt : Elmt_Id;
25892 Extra_State : Node_Id;
25894 -- Start of processing for Analyze_Refinement_Clause
25897 -- A refinement clause appears as a component association where the
25898 -- sole choice is the state and the expressions are the constituents.
25899 -- This is a syntax error, always report.
25901 if Nkind (Clause) /= N_Component_Association then
25902 Error_Msg_N ("malformed state refinement clause", Clause);
25906 -- Analyze the state name of a refinement clause
25908 State := First (Choices (Clause));
25911 Resolve_State (State);
25913 -- Ensure that the state name denotes a valid abstract state that is
25914 -- defined in the spec of the related package.
25916 if Is_Entity_Name (State) then
25917 State_Id := Entity_Of (State);
25919 -- When the abstract state is undefined, it appears as Any_Id. Do
25920 -- not continue with the analysis of the clause.
25922 if State_Id = Any_Id then
25925 -- Catch any attempts to re-refine a state or refine a state that
25926 -- is not defined in the package declaration.
25928 elsif Ekind (State_Id) = E_Abstract_State then
25932 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
25936 -- References to a state with visible refinement are illegal.
25937 -- When nested packages are involved, detecting such references is
25938 -- tricky because pragma Refined_State is analyzed later than the
25939 -- offending pragma Depends or Global. References that occur in
25940 -- such nested context are stored in a list. Emit errors for all
25941 -- references found in Body_References (SPARK RM 6.1.4(8)).
25943 if Present (Body_References (State_Id)) then
25944 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
25945 while Present (Body_Ref_Elmt) loop
25946 Body_Ref := Node (Body_Ref_Elmt);
25948 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
25949 Error_Msg_Sloc := Sloc (State);
25950 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
25952 Next_Elmt (Body_Ref_Elmt);
25956 -- The state name is illegal. This is a syntax error, always report.
25959 Error_Msg_N ("malformed state name in refinement clause", State);
25963 -- A refinement clause may only refine one state at a time
25965 Extra_State := Next (State);
25967 if Present (Extra_State) then
25969 ("refinement clause cannot cover multiple states", Extra_State);
25972 -- Replicate the Part_Of constituents of the refined state because
25973 -- the algorithm will consume items.
25975 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
25977 -- Analyze all constituents of the refinement. Multiple constituents
25978 -- appear as an aggregate.
25980 Constit := Expression (Clause);
25982 if Nkind (Constit) = N_Aggregate then
25983 if Present (Component_Associations (Constit)) then
25985 ("constituents of refinement clause must appear in "
25986 & "positional form", Constit);
25988 else pragma Assert (Present (Expressions (Constit)));
25989 Constit := First (Expressions (Constit));
25990 while Present (Constit) loop
25991 Analyze_Constituent (Constit);
25996 -- Various forms of a single constituent. Note that these may include
25997 -- malformed constituents.
26000 Analyze_Constituent (Constit);
26003 -- Verify that external constituents do not introduce new external
26004 -- property in the state refinement (SPARK RM 7.2.8(2)).
26006 if Is_External_State (State_Id) then
26007 Check_External_Property
26008 (Prop_Nam => Name_Async_Readers,
26009 Enabled => Async_Readers_Enabled (State_Id),
26010 Constit => AR_Constit);
26012 Check_External_Property
26013 (Prop_Nam => Name_Async_Writers,
26014 Enabled => Async_Writers_Enabled (State_Id),
26015 Constit => AW_Constit);
26017 Check_External_Property
26018 (Prop_Nam => Name_Effective_Reads,
26019 Enabled => Effective_Reads_Enabled (State_Id),
26020 Constit => ER_Constit);
26022 Check_External_Property
26023 (Prop_Nam => Name_Effective_Writes,
26024 Enabled => Effective_Writes_Enabled (State_Id),
26025 Constit => EW_Constit);
26027 -- When a refined state is not external, it should not have external
26028 -- constituents (SPARK RM 7.2.8(1)).
26030 elsif External_Constit_Seen then
26032 ("non-external state & cannot contain external constituents in "
26033 & "refinement", State, State_Id);
26036 -- Ensure that all Part_Of candidate constituents have been mentioned
26037 -- in the refinement clause.
26039 Report_Unused_Constituents (Part_Of_Constits);
26040 end Analyze_Refinement_Clause;
26042 -----------------------------
26043 -- Report_Unrefined_States --
26044 -----------------------------
26046 procedure Report_Unrefined_States (States : Elist_Id) is
26047 State_Elmt : Elmt_Id;
26050 if Present (States) then
26051 State_Elmt := First_Elmt (States);
26052 while Present (State_Elmt) loop
26054 ("abstract state & must be refined", Node (State_Elmt));
26056 Next_Elmt (State_Elmt);
26059 end Report_Unrefined_States;
26061 -- Local declarations
26063 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26066 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26069 -- Do not analyze the pragma multiple times
26071 if Is_Analyzed_Pragma (N) then
26075 -- Replicate the abstract states declared by the package because the
26076 -- matching algorithm will consume states.
26078 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26080 -- Gather all abstract states and objects declared in the visible
26081 -- state space of the package body. These items must be utilized as
26082 -- constituents in a state refinement.
26084 Body_States := Collect_Body_States (Body_Id);
26086 -- Multiple non-null state refinements appear as an aggregate
26088 if Nkind (Clauses) = N_Aggregate then
26089 if Present (Expressions (Clauses)) then
26091 ("state refinements must appear as component associations",
26094 else pragma Assert (Present (Component_Associations (Clauses)));
26095 Clause := First (Component_Associations (Clauses));
26096 while Present (Clause) loop
26097 Analyze_Refinement_Clause (Clause);
26102 -- Various forms of a single state refinement. Note that these may
26103 -- include malformed refinements.
26106 Analyze_Refinement_Clause (Clauses);
26109 -- List all abstract states that were left unrefined
26111 Report_Unrefined_States (Available_States);
26113 Set_Is_Analyzed_Pragma (N);
26114 end Analyze_Refined_State_In_Decl_Part;
26116 ------------------------------------
26117 -- Analyze_Test_Case_In_Decl_Part --
26118 ------------------------------------
26120 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26121 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26122 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26124 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26125 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26126 -- denoted by Arg_Nam.
26128 ------------------------------
26129 -- Preanalyze_Test_Case_Arg --
26130 ------------------------------
26132 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26136 -- Preanalyze the original aspect argument for ASIS or for a generic
26137 -- subprogram to properly capture global references.
26139 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26143 Arg_Nam => Arg_Nam,
26144 From_Aspect => True);
26146 if Present (Arg) then
26147 Preanalyze_Assert_Expression
26148 (Expression (Arg), Standard_Boolean);
26152 Arg := Test_Case_Arg (N, Arg_Nam);
26154 if Present (Arg) then
26155 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26157 end Preanalyze_Test_Case_Arg;
26161 Restore_Scope : Boolean := False;
26163 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26166 -- Do not analyze the pragma multiple times
26168 if Is_Analyzed_Pragma (N) then
26172 -- Ensure that the formal parameters are visible when analyzing all
26173 -- clauses. This falls out of the general rule of aspects pertaining
26174 -- to subprogram declarations.
26176 if not In_Open_Scopes (Spec_Id) then
26177 Restore_Scope := True;
26178 Push_Scope (Spec_Id);
26180 if Is_Generic_Subprogram (Spec_Id) then
26181 Install_Generic_Formals (Spec_Id);
26183 Install_Formals (Spec_Id);
26187 Preanalyze_Test_Case_Arg (Name_Requires);
26188 Preanalyze_Test_Case_Arg (Name_Ensures);
26190 if Restore_Scope then
26194 -- Currently it is not possible to inline pre/postconditions on a
26195 -- subprogram subject to pragma Inline_Always.
26197 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26199 Set_Is_Analyzed_Pragma (N);
26200 end Analyze_Test_Case_In_Decl_Part;
26206 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26211 if Present (List) then
26212 Elmt := First_Elmt (List);
26213 while Present (Elmt) loop
26214 if Nkind (Node (Elmt)) = N_Defining_Identifier then
26217 Id := Entity_Of (Node (Elmt));
26220 if Id = Item_Id then
26231 -----------------------------------
26232 -- Build_Pragma_Check_Equivalent --
26233 -----------------------------------
26235 function Build_Pragma_Check_Equivalent
26237 Subp_Id : Entity_Id := Empty;
26238 Inher_Id : Entity_Id := Empty) return Node_Id
26241 -- List containing the following mappings
26242 -- * Formal parameters of inherited subprogram Inher_Id and subprogram
26245 -- * The dispatching type of Inher_Id and the dispatching type of
26248 -- * Primitives of the dispatching type of Inher_Id and primitives of
26249 -- the dispatching type of Subp_Id.
26251 function Replace_Entity (N : Node_Id) return Traverse_Result;
26252 -- Replace reference to formal of inherited operation or to primitive
26253 -- operation of root type, with corresponding entity for derived type.
26255 function Suppress_Reference (N : Node_Id) return Traverse_Result;
26256 -- Detect whether node N references a formal parameter subject to
26257 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26258 -- to False to suppress the generation of a reference when analyzing
26261 --------------------
26262 -- Replace_Entity --
26263 --------------------
26265 function Replace_Entity (N : Node_Id) return Traverse_Result is
26270 if Nkind (N) = N_Identifier
26271 and then Present (Entity (N))
26273 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26275 (Nkind (Parent (N)) /= N_Attribute_Reference
26276 or else Attribute_Name (Parent (N)) /= Name_Class)
26278 -- The replacement does not apply to dispatching calls within the
26279 -- condition, but only to calls whose static tag is that of the
26282 if Is_Subprogram (Entity (N))
26283 and then Nkind (Parent (N)) = N_Function_Call
26284 and then Present (Controlling_Argument (Parent (N)))
26289 -- Loop to find out if entity has a renaming
26292 Elmt := First_Elmt (Map);
26293 while Present (Elmt) loop
26294 if Node (Elmt) = Entity (N) then
26295 New_E := Node (Next_Elmt (Elmt));
26302 if Present (New_E) then
26303 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26306 -- Check that there are no calls left to abstract operations
26307 -- if the current subprogram is not abstract.
26309 if Nkind (Parent (N)) = N_Function_Call
26310 and then N = Name (Parent (N))
26311 and then not Is_Abstract_Subprogram (Subp_Id)
26312 and then Is_Abstract_Subprogram (Entity (N))
26314 Error_Msg_Sloc := Sloc (Current_Scope);
26316 ("cannot call abstract subprogram in inherited condition "
26317 & "for&#", N, Current_Scope);
26320 -- The whole expression will be reanalyzed
26322 elsif Nkind (N) in N_Has_Etype then
26323 Set_Analyzed (N, False);
26327 end Replace_Entity;
26329 ------------------------
26330 -- Suppress_Reference --
26331 ------------------------
26333 function Suppress_Reference (N : Node_Id) return Traverse_Result is
26334 Formal : Entity_Id;
26337 if Is_Entity_Name (N) and then Present (Entity (N)) then
26338 Formal := Entity (N);
26340 -- The formal parameter is subject to pragma Unreferenced.
26341 -- Prevent the generation of a reference by resetting the
26342 -- Comes_From_Source flag.
26344 if Is_Formal (Formal)
26345 and then Has_Pragma_Unreferenced (Formal)
26347 Set_Comes_From_Source (N, False);
26352 end Suppress_Reference;
26354 procedure Replace_Condition_Entities is
26355 new Traverse_Proc (Replace_Entity);
26357 procedure Suppress_References is
26358 new Traverse_Proc (Suppress_Reference);
26362 Loc : constant Source_Ptr := Sloc (Prag);
26363 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26364 Check_Prag : Node_Id;
26365 Inher_Formal : Entity_Id;
26368 Subp_Formal : Entity_Id;
26370 -- Start of processing for Build_Pragma_Check_Equivalent
26375 -- When the pre- or postcondition is inherited, map the formals of the
26376 -- inherited subprogram to those of the current subprogram. In addition,
26377 -- map primitive operations of the parent type into the corresponding
26378 -- primitive operations of the descendant.
26380 if Present (Inher_Id) then
26381 pragma Assert (Present (Subp_Id));
26383 Map := New_Elmt_List;
26385 -- Create a mapping <inherited formal> => <subprogram formal>
26387 Inher_Formal := First_Formal (Inher_Id);
26388 Subp_Formal := First_Formal (Subp_Id);
26389 while Present (Inher_Formal) and then Present (Subp_Formal) loop
26390 Append_Elmt (Inher_Formal, Map);
26391 Append_Elmt (Subp_Formal, Map);
26393 Next_Formal (Inher_Formal);
26394 Next_Formal (Subp_Formal);
26397 -- Map primitive operations of the parent type to the corresponding
26398 -- operations of the descendant. Note that the descendant type may
26399 -- not be frozen yet, so we cannot use the dispatch table directly.
26401 -- Note : the construction of the map involves a full traversal of
26402 -- the list of primitive operations, as well as a scan of the
26403 -- declarations in the scope of the operation. Given that class-wide
26404 -- conditions are typically short expressions, it might be much more
26405 -- efficient to collect the identifiers in the expression first, and
26406 -- then determine the ones that have to be mapped. Optimization ???
26408 Primitive_Mapping : declare
26409 function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
26410 -- Given the controlling type of the overridden operation and a
26411 -- primitive of the current type, find the corresponding operation
26412 -- of the parent type.
26414 -------------------------
26415 -- Overridden_Ancestor --
26416 -------------------------
26418 function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
26419 Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26425 -- Locate the ancestor subprogram with the proper controlling
26428 while Present (Overridden_Operation (Anc)) loop
26429 Anc := Overridden_Operation (Anc);
26430 exit when Find_Dispatching_Type (Anc) = Par;
26434 end Overridden_Ancestor;
26438 Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26439 Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
26441 Old_Elmt : Elmt_Id;
26442 Old_Prim : Entity_Id;
26445 -- Start of processing for Primitive_Mapping
26448 Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
26450 -- Look for primitive operations of the current type that have
26451 -- overridden an operation of the type related to the original
26452 -- class-wide precondition. There may be several intermediate
26453 -- overridings between them.
26455 while Present (Decl) loop
26457 N_Subprogram_Declaration, N_Abstract_Subprogram_Declaration)
26459 Prim := Defining_Entity (Decl);
26461 if Is_Subprogram (Prim)
26462 and then Present (Overridden_Operation (Prim))
26463 and then Find_Dispatching_Type (Prim) = Typ
26465 Old_Prim := Overridden_Ancestor (Prim);
26467 Append_Elmt (Old_Prim, Map);
26468 Append_Elmt (Prim, Map);
26475 -- Now examine inherited operations. These do not override, but
26476 -- have an alias, which is the entity used in a call. In turn
26477 -- that alias may be inherited or comes from source, in which
26478 -- case it may override an earlier operation. We only need to
26479 -- examine inherited functions, that may appear within the
26480 -- inherited expression.
26482 Prim := First_Entity (Scope (Subp_Id));
26483 while Present (Prim) loop
26484 if not Comes_From_Source (Prim)
26485 and then Ekind (Prim) = E_Function
26486 and then Present (Alias (Prim))
26488 Old_Prim := Alias (Prim);
26490 if Comes_From_Source (Old_Prim) then
26491 Old_Prim := Overridden_Ancestor (Old_Prim);
26494 while Present (Alias (Old_Prim))
26495 and then Scope (Old_Prim) /= Scope (Inher_Id)
26497 Old_Prim := Alias (Old_Prim);
26499 if Comes_From_Source (Old_Prim) then
26500 Old_Prim := Overridden_Ancestor (Old_Prim);
26506 Append_Elmt (Old_Prim, Map);
26507 Append_Elmt (Prim, Map);
26510 Next_Entity (Prim);
26513 -- If the parent operation is an interface operation, the
26514 -- overriding indicator is not present. Instead, we get from
26515 -- the interface operation the primitive of the current type
26516 -- that implements it.
26518 if Is_Interface (Old_Typ) then
26519 Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
26520 while Present (Old_Elmt) loop
26521 Old_Prim := Node (Old_Elmt);
26522 Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
26524 if Present (Prim) then
26525 Append_Elmt (Old_Prim, Map);
26526 Append_Elmt (Prim, Map);
26529 Next_Elmt (Old_Elmt);
26533 if Map /= No_Elist then
26534 Append_Elmt (Old_Typ, Map);
26535 Append_Elmt (Typ, Map);
26537 end Primitive_Mapping;
26540 -- Copy the original pragma while performing substitutions (if
26543 Check_Prag := New_Copy_Tree (Source => Prag);
26545 if Map /= No_Elist then
26546 Replace_Condition_Entities (Check_Prag);
26549 -- Mark the pragma as being internally generated and reset the Analyzed
26552 Set_Analyzed (Check_Prag, False);
26553 Set_Comes_From_Source (Check_Prag, False);
26554 Set_Class_Present (Check_Prag, False);
26556 -- The tree of the original pragma may contain references to the
26557 -- formal parameters of the related subprogram. At the same time
26558 -- the corresponding body may mark the formals as unreferenced:
26560 -- procedure Proc (Formal : ...)
26561 -- with Pre => Formal ...;
26563 -- procedure Proc (Formal : ...) is
26564 -- pragma Unreferenced (Formal);
26567 -- This creates problems because all pragma Check equivalents are
26568 -- analyzed at the end of the body declarations. Since all source
26569 -- references have already been accounted for, reset any references
26570 -- to such formals in the generated pragma Check equivalent.
26572 Suppress_References (Check_Prag);
26574 if Present (Corresponding_Aspect (Prag)) then
26575 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26580 -- Convert the copy into pragma Check by correcting the name and adding
26581 -- a check_kind argument.
26583 Set_Pragma_Identifier
26584 (Check_Prag, Make_Identifier (Loc, Name_Check));
26586 Prepend_To (Pragma_Argument_Associations (Check_Prag),
26587 Make_Pragma_Argument_Association (Loc,
26588 Expression => Make_Identifier (Loc, Nam)));
26590 -- Update the error message when the pragma is inherited
26592 if Present (Inher_Id) then
26593 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26595 if Chars (Msg_Arg) = Name_Message then
26596 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26598 -- Insert "inherited" to improve the error message
26600 if Name_Buffer (1 .. 8) = "failed p" then
26601 Insert_Str_In_Name_Buffer ("inherited ", 8);
26602 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26608 end Build_Pragma_Check_Equivalent;
26610 -----------------------------
26611 -- Check_Applicable_Policy --
26612 -----------------------------
26614 procedure Check_Applicable_Policy (N : Node_Id) is
26618 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26621 -- No effect if not valid assertion kind name
26623 if not Is_Valid_Assertion_Kind (Ename) then
26627 -- Loop through entries in check policy list
26629 PP := Opt.Check_Policy_List;
26630 while Present (PP) loop
26632 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26633 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26637 or else Pnm = Name_Assertion
26638 or else (Pnm = Name_Statement_Assertions
26639 and then Nam_In (Ename, Name_Assert,
26640 Name_Assert_And_Cut,
26642 Name_Loop_Invariant,
26643 Name_Loop_Variant))
26645 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26648 when Name_Off | Name_Ignore =>
26649 Set_Is_Ignored (N, True);
26650 Set_Is_Checked (N, False);
26652 when Name_On | Name_Check =>
26653 Set_Is_Checked (N, True);
26654 Set_Is_Ignored (N, False);
26656 when Name_Disable =>
26657 Set_Is_Ignored (N, True);
26658 Set_Is_Checked (N, False);
26659 Set_Is_Disabled (N, True);
26661 -- That should be exhaustive, the null here is a defence
26662 -- against a malformed tree from previous errors.
26671 PP := Next_Pragma (PP);
26675 -- If there are no specific entries that matched, then we let the
26676 -- setting of assertions govern. Note that this provides the needed
26677 -- compatibility with the RM for the cases of assertion, invariant,
26678 -- precondition, predicate, and postcondition.
26680 if Assertions_Enabled then
26681 Set_Is_Checked (N, True);
26682 Set_Is_Ignored (N, False);
26684 Set_Is_Checked (N, False);
26685 Set_Is_Ignored (N, True);
26687 end Check_Applicable_Policy;
26689 -------------------------------
26690 -- Check_External_Properties --
26691 -------------------------------
26693 procedure Check_External_Properties
26701 -- All properties enabled
26703 if AR and AW and ER and EW then
26706 -- Async_Readers + Effective_Writes
26707 -- Async_Readers + Async_Writers + Effective_Writes
26709 elsif AR and EW and not ER then
26712 -- Async_Writers + Effective_Reads
26713 -- Async_Readers + Async_Writers + Effective_Reads
26715 elsif AW and ER and not EW then
26718 -- Async_Readers + Async_Writers
26720 elsif AR and AW and not ER and not EW then
26725 elsif AR and not AW and not ER and not EW then
26730 elsif AW and not AR and not ER and not EW then
26735 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26738 end Check_External_Properties;
26744 function Check_Kind (Nam : Name_Id) return Name_Id is
26748 -- Loop through entries in check policy list
26750 PP := Opt.Check_Policy_List;
26751 while Present (PP) loop
26753 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26754 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26758 or else (Pnm = Name_Assertion
26759 and then Is_Valid_Assertion_Kind (Nam))
26760 or else (Pnm = Name_Statement_Assertions
26761 and then Nam_In (Nam, Name_Assert,
26762 Name_Assert_And_Cut,
26764 Name_Loop_Invariant,
26765 Name_Loop_Variant))
26767 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26768 when Name_On | Name_Check =>
26770 when Name_Off | Name_Ignore =>
26771 return Name_Ignore;
26772 when Name_Disable =>
26773 return Name_Disable;
26775 raise Program_Error;
26779 PP := Next_Pragma (PP);
26784 -- If there are no specific entries that matched, then we let the
26785 -- setting of assertions govern. Note that this provides the needed
26786 -- compatibility with the RM for the cases of assertion, invariant,
26787 -- precondition, predicate, and postcondition.
26789 if Assertions_Enabled then
26792 return Name_Ignore;
26796 ---------------------------
26797 -- Check_Missing_Part_Of --
26798 ---------------------------
26800 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26801 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26802 -- Determine whether a package denoted by Pack_Id declares at least one
26805 -----------------------
26806 -- Has_Visible_State --
26807 -----------------------
26809 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26810 Item_Id : Entity_Id;
26813 -- Traverse the entity chain of the package trying to find at least
26814 -- one visible abstract state, variable or a package [instantiation]
26815 -- that declares a visible state.
26817 Item_Id := First_Entity (Pack_Id);
26818 while Present (Item_Id)
26819 and then not In_Private_Part (Item_Id)
26821 -- Do not consider internally generated items
26823 if not Comes_From_Source (Item_Id) then
26826 -- A visible state has been found
26828 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26831 -- Recursively peek into nested packages and instantiations
26833 elsif Ekind (Item_Id) = E_Package
26834 and then Has_Visible_State (Item_Id)
26839 Next_Entity (Item_Id);
26843 end Has_Visible_State;
26847 Pack_Id : Entity_Id;
26848 Placement : State_Space_Kind;
26850 -- Start of processing for Check_Missing_Part_Of
26853 -- Do not consider abstract states, variables or package instantiations
26854 -- coming from an instance as those always inherit the Part_Of indicator
26855 -- of the instance itself.
26857 if In_Instance then
26860 -- Do not consider internally generated entities as these can never
26861 -- have a Part_Of indicator.
26863 elsif not Comes_From_Source (Item_Id) then
26866 -- Perform these checks only when SPARK_Mode is enabled as they will
26867 -- interfere with standard Ada rules and produce false positives.
26869 elsif SPARK_Mode /= On then
26872 -- Do not consider constants, because the compiler cannot accurately
26873 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26874 -- act as a hidden state of a package.
26876 elsif Ekind (Item_Id) = E_Constant then
26880 -- Find where the abstract state, variable or package instantiation
26881 -- lives with respect to the state space.
26883 Find_Placement_In_State_Space
26884 (Item_Id => Item_Id,
26885 Placement => Placement,
26886 Pack_Id => Pack_Id);
26888 -- Items that appear in a non-package construct (subprogram, block, etc)
26889 -- do not require a Part_Of indicator because they can never act as a
26892 if Placement = Not_In_Package then
26895 -- An item declared in the body state space of a package always act as a
26896 -- constituent and does not need explicit Part_Of indicator.
26898 elsif Placement = Body_State_Space then
26901 -- In general an item declared in the visible state space of a package
26902 -- does not require a Part_Of indicator. The only exception is when the
26903 -- related package is a private child unit in which case Part_Of must
26904 -- denote a state in the parent unit or in one of its descendants.
26906 elsif Placement = Visible_State_Space then
26907 if Is_Child_Unit (Pack_Id)
26908 and then Is_Private_Descendant (Pack_Id)
26910 -- A package instantiation does not need a Part_Of indicator when
26911 -- the related generic template has no visible state.
26913 if Ekind (Item_Id) = E_Package
26914 and then Is_Generic_Instance (Item_Id)
26915 and then not Has_Visible_State (Item_Id)
26919 -- All other cases require Part_Of
26923 ("indicator Part_Of is required in this context "
26924 & "(SPARK RM 7.2.6(3))", Item_Id);
26925 Error_Msg_Name_1 := Chars (Pack_Id);
26927 ("\& is declared in the visible part of private child "
26928 & "unit %", Item_Id);
26932 -- When the item appears in the private state space of a packge, it must
26933 -- be a part of some state declared by the said package.
26935 else pragma Assert (Placement = Private_State_Space);
26937 -- The related package does not declare a state, the item cannot act
26938 -- as a Part_Of constituent.
26940 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26943 -- A package instantiation does not need a Part_Of indicator when the
26944 -- related generic template has no visible state.
26946 elsif Ekind (Pack_Id) = E_Package
26947 and then Is_Generic_Instance (Pack_Id)
26948 and then not Has_Visible_State (Pack_Id)
26952 -- All other cases require Part_Of
26956 ("indicator Part_Of is required in this context "
26957 & "(SPARK RM 7.2.6(2))", Item_Id);
26958 Error_Msg_Name_1 := Chars (Pack_Id);
26960 ("\& is declared in the private part of package %", Item_Id);
26963 end Check_Missing_Part_Of;
26965 ---------------------------------------------------
26966 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26967 ---------------------------------------------------
26969 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26971 Spec_Id : Entity_Id)
26974 if Warn_On_Redundant_Constructs
26975 and then Has_Pragma_Inline_Always (Spec_Id)
26977 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
26979 if From_Aspect_Specification (Prag) then
26981 ("aspect % not enforced on inlined subprogram &?r?",
26982 Corresponding_Aspect (Prag), Spec_Id);
26985 ("pragma % not enforced on inlined subprogram &?r?",
26989 end Check_Postcondition_Use_In_Inlined_Subprogram;
26991 -------------------------------------
26992 -- Check_State_And_Constituent_Use --
26993 -------------------------------------
26995 procedure Check_State_And_Constituent_Use
26996 (States : Elist_Id;
26997 Constits : Elist_Id;
27000 function Find_Encapsulating_State
27001 (Constit_Id : Entity_Id) return Entity_Id;
27002 -- Given the entity of a constituent, try to find a corresponding
27003 -- encapsulating state that appears in the same context. The routine
27004 -- returns Empty is no such state is found.
27006 ------------------------------
27007 -- Find_Encapsulating_State --
27008 ------------------------------
27010 function Find_Encapsulating_State
27011 (Constit_Id : Entity_Id) return Entity_Id
27013 State_Id : Entity_Id;
27016 -- Since a constituent may be part of a larger constituent set, climb
27017 -- the encapsulating state chain looking for a state that appears in
27018 -- the same context.
27020 State_Id := Encapsulating_State (Constit_Id);
27021 while Present (State_Id) loop
27022 if Contains (States, State_Id) then
27026 State_Id := Encapsulating_State (State_Id);
27030 end Find_Encapsulating_State;
27034 Constit_Elmt : Elmt_Id;
27035 Constit_Id : Entity_Id;
27036 State_Id : Entity_Id;
27038 -- Start of processing for Check_State_And_Constituent_Use
27041 -- Nothing to do if there are no states or constituents
27043 if No (States) or else No (Constits) then
27047 -- Inspect the list of constituents and try to determine whether its
27048 -- encapsulating state is in list States.
27050 Constit_Elmt := First_Elmt (Constits);
27051 while Present (Constit_Elmt) loop
27052 Constit_Id := Node (Constit_Elmt);
27054 -- Determine whether the constituent is part of an encapsulating
27055 -- state that appears in the same context and if this is the case,
27056 -- emit an error (SPARK RM 7.2.6(7)).
27058 State_Id := Find_Encapsulating_State (Constit_Id);
27060 if Present (State_Id) then
27061 Error_Msg_Name_1 := Chars (Constit_Id);
27063 ("cannot mention state & and its constituent % in the same "
27064 & "context", Context, State_Id);
27068 Next_Elmt (Constit_Elmt);
27070 end Check_State_And_Constituent_Use;
27072 ---------------------------------------------
27073 -- Collect_Inherited_Class_Wide_Conditions --
27074 ---------------------------------------------
27076 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27077 Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
27078 Prags : constant Node_Id := Contract (Parent_Subp);
27079 In_Spec_Expr : Boolean;
27080 Installed : Boolean;
27082 New_Prag : Node_Id;
27085 Installed := False;
27087 -- Iterate over the contract of the overridden subprogram to find all
27088 -- inherited class-wide pre- and postconditions.
27090 if Present (Prags) then
27091 Prag := Pre_Post_Conditions (Prags);
27093 while Present (Prag) loop
27094 if Nam_In (Pragma_Name (Prag), Name_Precondition,
27095 Name_Postcondition)
27096 and then Class_Present (Prag)
27098 -- The generated pragma must be analyzed in the context of
27099 -- the subprogram, to make its formals visible. In addition,
27100 -- we must inhibit freezing and full analysis because the
27101 -- controlling type of the subprogram is not frozen yet, and
27102 -- may have further primitives.
27104 if not Installed then
27107 Install_Formals (Subp);
27108 In_Spec_Expr := In_Spec_Expression;
27109 In_Spec_Expression := True;
27113 Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp);
27114 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27115 Preanalyze (New_Prag);
27117 -- Prevent further analysis in subsequent processing of the
27118 -- current list of declarations
27120 Set_Analyzed (New_Prag);
27123 Prag := Next_Pragma (Prag);
27127 In_Spec_Expression := In_Spec_Expr;
27131 end Collect_Inherited_Class_Wide_Conditions;
27133 ---------------------------------------
27134 -- Collect_Subprogram_Inputs_Outputs --
27135 ---------------------------------------
27137 procedure Collect_Subprogram_Inputs_Outputs
27138 (Subp_Id : Entity_Id;
27139 Synthesize : Boolean := False;
27140 Subp_Inputs : in out Elist_Id;
27141 Subp_Outputs : in out Elist_Id;
27142 Global_Seen : out Boolean)
27144 procedure Collect_Dependency_Clause (Clause : Node_Id);
27145 -- Collect all relevant items from a dependency clause
27147 procedure Collect_Global_List
27149 Mode : Name_Id := Name_Input);
27150 -- Collect all relevant items from a global list
27152 -------------------------------
27153 -- Collect_Dependency_Clause --
27154 -------------------------------
27156 procedure Collect_Dependency_Clause (Clause : Node_Id) is
27157 procedure Collect_Dependency_Item
27159 Is_Input : Boolean);
27160 -- Add an item to the proper subprogram input or output collection
27162 -----------------------------
27163 -- Collect_Dependency_Item --
27164 -----------------------------
27166 procedure Collect_Dependency_Item
27168 Is_Input : Boolean)
27173 -- Nothing to collect when the item is null
27175 if Nkind (Item) = N_Null then
27178 -- Ditto for attribute 'Result
27180 elsif Is_Attribute_Result (Item) then
27183 -- Multiple items appear as an aggregate
27185 elsif Nkind (Item) = N_Aggregate then
27186 Extra := First (Expressions (Item));
27187 while Present (Extra) loop
27188 Collect_Dependency_Item (Extra, Is_Input);
27192 -- Otherwise this is a solitary item
27196 Append_New_Elmt (Item, Subp_Inputs);
27198 Append_New_Elmt (Item, Subp_Outputs);
27201 end Collect_Dependency_Item;
27203 -- Start of processing for Collect_Dependency_Clause
27206 if Nkind (Clause) = N_Null then
27209 -- A dependency cause appears as component association
27211 elsif Nkind (Clause) = N_Component_Association then
27212 Collect_Dependency_Item
27213 (Item => Expression (Clause),
27216 Collect_Dependency_Item
27217 (Item => First (Choices (Clause)),
27218 Is_Input => False);
27220 -- To accomodate partial decoration of disabled SPARK features, this
27221 -- routine may be called with illegal input. If this is the case, do
27222 -- not raise Program_Error.
27227 end Collect_Dependency_Clause;
27229 -------------------------
27230 -- Collect_Global_List --
27231 -------------------------
27233 procedure Collect_Global_List
27235 Mode : Name_Id := Name_Input)
27237 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27238 -- Add an item to the proper subprogram input or output collection
27240 -------------------------
27241 -- Collect_Global_Item --
27242 -------------------------
27244 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27246 if Nam_In (Mode, Name_In_Out, Name_Input) then
27247 Append_New_Elmt (Item, Subp_Inputs);
27250 if Nam_In (Mode, Name_In_Out, Name_Output) then
27251 Append_New_Elmt (Item, Subp_Outputs);
27253 end Collect_Global_Item;
27260 -- Start of processing for Collect_Global_List
27263 if Nkind (List) = N_Null then
27266 -- Single global item declaration
27268 elsif Nkind_In (List, N_Expanded_Name,
27270 N_Selected_Component)
27272 Collect_Global_Item (List, Mode);
27274 -- Simple global list or moded global list declaration
27276 elsif Nkind (List) = N_Aggregate then
27277 if Present (Expressions (List)) then
27278 Item := First (Expressions (List));
27279 while Present (Item) loop
27280 Collect_Global_Item (Item, Mode);
27285 Assoc := First (Component_Associations (List));
27286 while Present (Assoc) loop
27287 Collect_Global_List
27288 (List => Expression (Assoc),
27289 Mode => Chars (First (Choices (Assoc))));
27294 -- To accomodate partial decoration of disabled SPARK features, this
27295 -- routine may be called with illegal input. If this is the case, do
27296 -- not raise Program_Error.
27301 end Collect_Global_List;
27308 Formal : Entity_Id;
27310 Spec_Id : Entity_Id;
27311 Subp_Decl : Node_Id;
27314 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27317 Global_Seen := False;
27319 -- Process all formal parameters of entries, [generic] subprograms, and
27322 if Ekind_In (Subp_Id, E_Entry,
27325 E_Generic_Function,
27326 E_Generic_Procedure,
27330 Subp_Decl := Unit_Declaration_Node (Subp_Id);
27331 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27333 -- Process all [generic] formal parameters
27335 Formal := First_Entity (Spec_Id);
27336 while Present (Formal) loop
27337 if Ekind_In (Formal, E_Generic_In_Parameter,
27338 E_In_Out_Parameter,
27341 Append_New_Elmt (Formal, Subp_Inputs);
27344 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27345 E_In_Out_Parameter,
27348 Append_New_Elmt (Formal, Subp_Outputs);
27350 -- Out parameters can act as inputs when the related type is
27351 -- tagged, unconstrained array, unconstrained record, or record
27352 -- with unconstrained components.
27354 if Ekind (Formal) = E_Out_Parameter
27355 and then Is_Unconstrained_Or_Tagged_Item (Formal)
27357 Append_New_Elmt (Formal, Subp_Inputs);
27361 Next_Entity (Formal);
27364 -- Otherwise the input denotes a task type, a task body, or the
27365 -- anonymous object created for a single task type.
27367 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27368 or else Is_Single_Task_Object (Subp_Id)
27370 Subp_Decl := Declaration_Node (Subp_Id);
27371 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27374 -- When processing an entry, subprogram or task body, look for pragmas
27375 -- Refined_Depends and Refined_Global as they specify the inputs and
27378 if Is_Entry_Body (Subp_Id)
27379 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27381 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27382 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27384 -- Subprogram declaration or stand alone body case, look for pragmas
27385 -- Depends and Global
27388 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27389 Global := Get_Pragma (Spec_Id, Pragma_Global);
27392 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27393 -- because it provides finer granularity of inputs and outputs.
27395 if Present (Global) then
27396 Global_Seen := True;
27397 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27399 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27400 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27401 -- the inputs and outputs from [Refined_]Depends.
27403 elsif Synthesize and then Present (Depends) then
27404 Clauses := Expression (Get_Argument (Depends, Spec_Id));
27406 -- Multiple dependency clauses appear as an aggregate
27408 if Nkind (Clauses) = N_Aggregate then
27409 Clause := First (Component_Associations (Clauses));
27410 while Present (Clause) loop
27411 Collect_Dependency_Clause (Clause);
27415 -- Otherwise this is a single dependency clause
27418 Collect_Dependency_Clause (Clauses);
27422 -- The current instance of a protected type acts as a formal parameter
27423 -- of mode IN for functions and IN OUT for entries and procedures
27424 -- (SPARK RM 6.1.4).
27426 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27427 Typ := Scope (Spec_Id);
27429 -- Use the anonymous object when the type is single protected
27431 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27432 Typ := Anonymous_Object (Typ);
27435 Append_New_Elmt (Typ, Subp_Inputs);
27437 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27438 Append_New_Elmt (Typ, Subp_Outputs);
27441 -- The current instance of a task type acts as a formal parameter of
27442 -- mode IN OUT (SPARK RM 6.1.4).
27444 elsif Ekind (Spec_Id) = E_Task_Type then
27447 -- Use the anonymous object when the type is single task
27449 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27450 Typ := Anonymous_Object (Typ);
27453 Append_New_Elmt (Typ, Subp_Inputs);
27454 Append_New_Elmt (Typ, Subp_Outputs);
27456 elsif Is_Single_Task_Object (Spec_Id) then
27457 Append_New_Elmt (Spec_Id, Subp_Inputs);
27458 Append_New_Elmt (Spec_Id, Subp_Outputs);
27460 end Collect_Subprogram_Inputs_Outputs;
27462 ---------------------------
27463 -- Contract_Freeze_Error --
27464 ---------------------------
27466 procedure Contract_Freeze_Error
27467 (Contract_Id : Entity_Id;
27468 Freeze_Id : Entity_Id)
27471 Error_Msg_Name_1 := Chars (Contract_Id);
27472 Error_Msg_Sloc := Sloc (Freeze_Id);
27475 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27477 ("\all contractual items must be declared before body #", Contract_Id);
27478 end Contract_Freeze_Error;
27480 ---------------------------------
27481 -- Delay_Config_Pragma_Analyze --
27482 ---------------------------------
27484 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27486 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27487 Name_Priority_Specific_Dispatching);
27488 end Delay_Config_Pragma_Analyze;
27490 -----------------------
27491 -- Duplication_Error --
27492 -----------------------
27494 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27495 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27496 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27499 Error_Msg_Sloc := Sloc (Prev);
27500 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27502 -- Emit a precise message to distinguish between source pragmas and
27503 -- pragmas generated from aspects. The ordering of the two pragmas is
27507 -- Prag -- duplicate
27509 -- No error is emitted when both pragmas come from aspects because this
27510 -- is already detected by the general aspect analysis mechanism.
27512 if Prag_From_Asp and Prev_From_Asp then
27514 elsif Prag_From_Asp then
27515 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27516 elsif Prev_From_Asp then
27517 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27519 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27521 end Duplication_Error;
27523 --------------------------
27524 -- Find_Related_Context --
27525 --------------------------
27527 function Find_Related_Context
27529 Do_Checks : Boolean := False) return Node_Id
27534 Stmt := Prev (Prag);
27535 while Present (Stmt) loop
27537 -- Skip prior pragmas, but check for duplicates
27539 if Nkind (Stmt) = N_Pragma then
27540 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27546 -- Skip internally generated code
27548 elsif not Comes_From_Source (Stmt) then
27550 -- The anonymous object created for a single concurrent type is a
27551 -- suitable context.
27553 if Nkind (Stmt) = N_Object_Declaration
27554 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27559 -- Return the current source construct
27569 end Find_Related_Context;
27571 --------------------------------------
27572 -- Find_Related_Declaration_Or_Body --
27573 --------------------------------------
27575 function Find_Related_Declaration_Or_Body
27577 Do_Checks : Boolean := False) return Node_Id
27579 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27581 procedure Expression_Function_Error;
27582 -- Emit an error concerning pragma Prag that illegaly applies to an
27583 -- expression function.
27585 -------------------------------
27586 -- Expression_Function_Error --
27587 -------------------------------
27589 procedure Expression_Function_Error is
27591 Error_Msg_Name_1 := Prag_Nam;
27593 -- Emit a precise message to distinguish between source pragmas and
27594 -- pragmas generated from aspects.
27596 if From_Aspect_Specification (Prag) then
27598 ("aspect % cannot apply to a stand alone expression function",
27602 ("pragma % cannot apply to a stand alone expression function",
27605 end Expression_Function_Error;
27609 Context : constant Node_Id := Parent (Prag);
27612 Look_For_Body : constant Boolean :=
27613 Nam_In (Prag_Nam, Name_Refined_Depends,
27614 Name_Refined_Global,
27615 Name_Refined_Post);
27616 -- Refinement pragmas must be associated with a subprogram body [stub]
27618 -- Start of processing for Find_Related_Declaration_Or_Body
27621 Stmt := Prev (Prag);
27622 while Present (Stmt) loop
27624 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27625 -- by splitting a complex pre/postcondition are not considered to
27628 if Nkind (Stmt) = N_Pragma then
27630 and then not Split_PPC (Stmt)
27631 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27638 -- Emit an error when a refinement pragma appears on an expression
27639 -- function without a completion.
27642 and then Look_For_Body
27643 and then Nkind (Stmt) = N_Subprogram_Declaration
27644 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27645 and then not Has_Completion (Defining_Entity (Stmt))
27647 Expression_Function_Error;
27650 -- The refinement pragma applies to a subprogram body stub
27652 elsif Look_For_Body
27653 and then Nkind (Stmt) = N_Subprogram_Body_Stub
27657 -- Skip internally generated code
27659 elsif not Comes_From_Source (Stmt) then
27661 -- The anonymous object created for a single concurrent type is a
27662 -- suitable context.
27664 if Nkind (Stmt) = N_Object_Declaration
27665 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27669 elsif Nkind (Stmt) = N_Subprogram_Declaration then
27671 -- The subprogram declaration is an internally generated spec
27672 -- for an expression function.
27674 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27677 -- The subprogram is actually an instance housed within an
27678 -- anonymous wrapper package.
27680 elsif Present (Generic_Parent (Specification (Stmt))) then
27685 -- Return the current construct which is either a subprogram body,
27686 -- a subprogram declaration or is illegal.
27695 -- If we fall through, then the pragma was either the first declaration
27696 -- or it was preceded by other pragmas and no source constructs.
27698 -- The pragma is associated with a library-level subprogram
27700 if Nkind (Context) = N_Compilation_Unit_Aux then
27701 return Unit (Parent (Context));
27703 -- The pragma appears inside the declarations of an entry body
27705 elsif Nkind (Context) = N_Entry_Body then
27708 -- The pragma appears inside the statements of a subprogram body. This
27709 -- placement is the result of subprogram contract expansion.
27711 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27712 return Parent (Context);
27714 -- The pragma appears inside the declarative part of a subprogram body
27716 elsif Nkind (Context) = N_Subprogram_Body then
27719 -- The pragma appears inside the declarative part of a task body
27721 elsif Nkind (Context) = N_Task_Body then
27724 -- The pragma is a byproduct of aspect expansion, return the related
27725 -- context of the original aspect. This case has a lower priority as
27726 -- the above circuitry pinpoints precisely the related context.
27728 elsif Present (Corresponding_Aspect (Prag)) then
27729 return Parent (Corresponding_Aspect (Prag));
27731 -- No candidate subprogram [body] found
27736 end Find_Related_Declaration_Or_Body;
27738 ----------------------------------
27739 -- Find_Related_Package_Or_Body --
27740 ----------------------------------
27742 function Find_Related_Package_Or_Body
27744 Do_Checks : Boolean := False) return Node_Id
27746 Context : constant Node_Id := Parent (Prag);
27747 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27751 Stmt := Prev (Prag);
27752 while Present (Stmt) loop
27754 -- Skip prior pragmas, but check for duplicates
27756 if Nkind (Stmt) = N_Pragma then
27757 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27763 -- Skip internally generated code
27765 elsif not Comes_From_Source (Stmt) then
27766 if Nkind (Stmt) = N_Subprogram_Declaration then
27768 -- The subprogram declaration is an internally generated spec
27769 -- for an expression function.
27771 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27774 -- The subprogram is actually an instance housed within an
27775 -- anonymous wrapper package.
27777 elsif Present (Generic_Parent (Specification (Stmt))) then
27782 -- Return the current source construct which is illegal
27791 -- If we fall through, then the pragma was either the first declaration
27792 -- or it was preceded by other pragmas and no source constructs.
27794 -- The pragma is associated with a package. The immediate context in
27795 -- this case is the specification of the package.
27797 if Nkind (Context) = N_Package_Specification then
27798 return Parent (Context);
27800 -- The pragma appears in the declarations of a package body
27802 elsif Nkind (Context) = N_Package_Body then
27805 -- The pragma appears in the statements of a package body
27807 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27808 and then Nkind (Parent (Context)) = N_Package_Body
27810 return Parent (Context);
27812 -- The pragma is a byproduct of aspect expansion, return the related
27813 -- context of the original aspect. This case has a lower priority as
27814 -- the above circuitry pinpoints precisely the related context.
27816 elsif Present (Corresponding_Aspect (Prag)) then
27817 return Parent (Corresponding_Aspect (Prag));
27819 -- No candidate packge [body] found
27824 end Find_Related_Package_Or_Body;
27830 function Get_Argument
27832 Context_Id : Entity_Id := Empty) return Node_Id
27834 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27837 -- Use the expression of the original aspect when compiling for ASIS or
27838 -- when analyzing the template of a generic unit. In both cases the
27839 -- aspect's tree must be decorated to allow for ASIS queries or to save
27840 -- the global references in the generic context.
27842 if From_Aspect_Specification (Prag)
27843 and then (ASIS_Mode or else (Present (Context_Id)
27844 and then Is_Generic_Unit (Context_Id)))
27846 return Corresponding_Aspect (Prag);
27848 -- Otherwise use the expression of the pragma
27850 elsif Present (Args) then
27851 return First (Args);
27858 -------------------------
27859 -- Get_Base_Subprogram --
27860 -------------------------
27862 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27863 Result : Entity_Id;
27866 -- Follow subprogram renaming chain
27870 if Is_Subprogram (Result)
27872 Nkind (Parent (Declaration_Node (Result))) =
27873 N_Subprogram_Renaming_Declaration
27874 and then Present (Alias (Result))
27876 Result := Alias (Result);
27880 end Get_Base_Subprogram;
27882 -----------------------
27883 -- Get_SPARK_Mode_Type --
27884 -----------------------
27886 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27888 if N = Name_On then
27890 elsif N = Name_Off then
27893 -- Any other argument is illegal
27896 raise Program_Error;
27898 end Get_SPARK_Mode_Type;
27900 ------------------------------------
27901 -- Get_SPARK_Mode_From_Annotation --
27902 ------------------------------------
27904 function Get_SPARK_Mode_From_Annotation
27905 (N : Node_Id) return SPARK_Mode_Type
27910 if Nkind (N) = N_Aspect_Specification then
27911 Mode := Expression (N);
27913 else pragma Assert (Nkind (N) = N_Pragma);
27914 Mode := First (Pragma_Argument_Associations (N));
27916 if Present (Mode) then
27917 Mode := Get_Pragma_Arg (Mode);
27921 -- Aspect or pragma SPARK_Mode specifies an explicit mode
27923 if Present (Mode) then
27924 if Nkind (Mode) = N_Identifier then
27925 return Get_SPARK_Mode_Type (Chars (Mode));
27927 -- In case of a malformed aspect or pragma, return the default None
27933 -- Otherwise the lack of an expression defaults SPARK_Mode to On
27938 end Get_SPARK_Mode_From_Annotation;
27940 ---------------------------
27941 -- Has_Extra_Parentheses --
27942 ---------------------------
27944 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
27948 -- The aggregate should not have an expression list because a clause
27949 -- is always interpreted as a component association. The only way an
27950 -- expression list can sneak in is by adding extra parentheses around
27951 -- the individual clauses:
27953 -- Depends (Output => Input) -- proper form
27954 -- Depends ((Output => Input)) -- extra parentheses
27956 -- Since the extra parentheses are not allowed by the syntax of the
27957 -- pragma, flag them now to avoid emitting misleading errors down the
27960 if Nkind (Clause) = N_Aggregate
27961 and then Present (Expressions (Clause))
27963 Expr := First (Expressions (Clause));
27964 while Present (Expr) loop
27966 -- A dependency clause surrounded by extra parentheses appears
27967 -- as an aggregate of component associations with an optional
27968 -- Paren_Count set.
27970 if Nkind (Expr) = N_Aggregate
27971 and then Present (Component_Associations (Expr))
27974 ("dependency clause contains extra parentheses", Expr);
27976 -- Otherwise the expression is a malformed construct
27979 SPARK_Msg_N ("malformed dependency clause", Expr);
27989 end Has_Extra_Parentheses;
27995 procedure Initialize is
28006 Dummy := Dummy + 1;
28009 -----------------------------
28010 -- Is_Config_Static_String --
28011 -----------------------------
28013 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28015 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28016 -- This is an internal recursive function that is just like the outer
28017 -- function except that it adds the string to the name buffer rather
28018 -- than placing the string in the name buffer.
28020 ------------------------------
28021 -- Add_Config_Static_String --
28022 ------------------------------
28024 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28031 if Nkind (N) = N_Op_Concat then
28032 if Add_Config_Static_String (Left_Opnd (N)) then
28033 N := Right_Opnd (N);
28039 if Nkind (N) /= N_String_Literal then
28040 Error_Msg_N ("string literal expected for pragma argument", N);
28044 for J in 1 .. String_Length (Strval (N)) loop
28045 C := Get_String_Char (Strval (N), J);
28047 if not In_Character_Range (C) then
28049 ("string literal contains invalid wide character",
28050 Sloc (N) + 1 + Source_Ptr (J));
28054 Add_Char_To_Name_Buffer (Get_Character (C));
28059 end Add_Config_Static_String;
28061 -- Start of processing for Is_Config_Static_String
28066 return Add_Config_Static_String (Arg);
28067 end Is_Config_Static_String;
28069 ---------------------
28070 -- Is_CCT_Instance --
28071 ---------------------
28073 function Is_CCT_Instance
28074 (Ref_Id : Entity_Id;
28075 Context_Id : Entity_Id) return Boolean
28081 -- When the reference denotes a single protected type, the context is
28082 -- either a protected subprogram or its body.
28084 if Is_Single_Protected_Object (Ref_Id) then
28085 Typ := Scope (Context_Id);
28088 Ekind (Typ) = E_Protected_Type
28089 and then Present (Anonymous_Object (Typ))
28090 and then Anonymous_Object (Typ) = Ref_Id;
28092 -- When the reference denotes a single task type, the context is either
28093 -- the same type or if inside the body, the anonymous task type.
28095 elsif Is_Single_Task_Object (Ref_Id) then
28096 if Ekind (Context_Id) = E_Task_Type then
28098 Present (Anonymous_Object (Context_Id))
28099 and then Anonymous_Object (Context_Id) = Ref_Id;
28101 return Ref_Id = Context_Id;
28104 -- Otherwise the reference denotes a protected or a task type. Climb the
28105 -- scope chain looking for an enclosing concurrent type that matches the
28106 -- referenced entity.
28109 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28111 S := Current_Scope;
28112 while Present (S) and then S /= Standard_Standard loop
28113 if Ekind_In (S, E_Protected_Type, E_Task_Type)
28114 and then S = Ref_Id
28124 end Is_CCT_Instance;
28126 -------------------------------
28127 -- Is_Elaboration_SPARK_Mode --
28128 -------------------------------
28130 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28133 (Nkind (N) = N_Pragma
28134 and then Pragma_Name (N) = Name_SPARK_Mode
28135 and then Is_List_Member (N));
28137 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28138 -- appears in the statement part of the body.
28141 Present (Parent (N))
28142 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28143 and then List_Containing (N) = Statements (Parent (N))
28144 and then Present (Parent (Parent (N)))
28145 and then Nkind (Parent (Parent (N))) = N_Package_Body;
28146 end Is_Elaboration_SPARK_Mode;
28148 -----------------------
28149 -- Is_Enabled_Pragma --
28150 -----------------------
28152 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28156 if Present (Prag) then
28157 Arg := First (Pragma_Argument_Associations (Prag));
28159 if Present (Arg) then
28160 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28162 -- The lack of a Boolean argument automatically enables the pragma
28168 -- The pragma is missing, therefore it is not enabled
28173 end Is_Enabled_Pragma;
28175 -----------------------------------------
28176 -- Is_Non_Significant_Pragma_Reference --
28177 -----------------------------------------
28179 -- This function makes use of the following static table which indicates
28180 -- whether appearance of some name in a given pragma is to be considered
28181 -- as a reference for the purposes of warnings about unreferenced objects.
28183 -- -1 indicates that appearence in any argument is significant
28184 -- 0 indicates that appearance in any argument is not significant
28185 -- +n indicates that appearance as argument n is significant, but all
28186 -- other arguments are not significant
28187 -- 9n arguments from n on are significant, before n insignificant
28189 Sig_Flags : constant array (Pragma_Id) of Int :=
28190 (Pragma_Abort_Defer => -1,
28191 Pragma_Abstract_State => -1,
28192 Pragma_Ada_83 => -1,
28193 Pragma_Ada_95 => -1,
28194 Pragma_Ada_05 => -1,
28195 Pragma_Ada_2005 => -1,
28196 Pragma_Ada_12 => -1,
28197 Pragma_Ada_2012 => -1,
28198 Pragma_All_Calls_Remote => -1,
28199 Pragma_Allow_Integer_Address => -1,
28200 Pragma_Annotate => 93,
28201 Pragma_Assert => -1,
28202 Pragma_Assert_And_Cut => -1,
28203 Pragma_Assertion_Policy => 0,
28204 Pragma_Assume => -1,
28205 Pragma_Assume_No_Invalid_Values => 0,
28206 Pragma_Async_Readers => 0,
28207 Pragma_Async_Writers => 0,
28208 Pragma_Asynchronous => 0,
28209 Pragma_Atomic => 0,
28210 Pragma_Atomic_Components => 0,
28211 Pragma_Attach_Handler => -1,
28212 Pragma_Attribute_Definition => 92,
28213 Pragma_Check => -1,
28214 Pragma_Check_Float_Overflow => 0,
28215 Pragma_Check_Name => 0,
28216 Pragma_Check_Policy => 0,
28217 Pragma_CPP_Class => 0,
28218 Pragma_CPP_Constructor => 0,
28219 Pragma_CPP_Virtual => 0,
28220 Pragma_CPP_Vtable => 0,
28222 Pragma_C_Pass_By_Copy => 0,
28223 Pragma_Comment => -1,
28224 Pragma_Common_Object => 0,
28225 Pragma_Compile_Time_Error => -1,
28226 Pragma_Compile_Time_Warning => -1,
28227 Pragma_Compiler_Unit => -1,
28228 Pragma_Compiler_Unit_Warning => -1,
28229 Pragma_Complete_Representation => 0,
28230 Pragma_Complex_Representation => 0,
28231 Pragma_Component_Alignment => 0,
28232 Pragma_Constant_After_Elaboration => 0,
28233 Pragma_Contract_Cases => -1,
28234 Pragma_Controlled => 0,
28235 Pragma_Convention => 0,
28236 Pragma_Convention_Identifier => 0,
28237 Pragma_Debug => -1,
28238 Pragma_Debug_Policy => 0,
28239 Pragma_Detect_Blocking => 0,
28240 Pragma_Default_Initial_Condition => -1,
28241 Pragma_Default_Scalar_Storage_Order => 0,
28242 Pragma_Default_Storage_Pool => 0,
28243 Pragma_Depends => -1,
28244 Pragma_Disable_Atomic_Synchronization => 0,
28245 Pragma_Discard_Names => 0,
28246 Pragma_Dispatching_Domain => -1,
28247 Pragma_Effective_Reads => 0,
28248 Pragma_Effective_Writes => 0,
28249 Pragma_Elaborate => 0,
28250 Pragma_Elaborate_All => 0,
28251 Pragma_Elaborate_Body => 0,
28252 Pragma_Elaboration_Checks => 0,
28253 Pragma_Eliminate => 0,
28254 Pragma_Enable_Atomic_Synchronization => 0,
28255 Pragma_Export => -1,
28256 Pragma_Export_Function => -1,
28257 Pragma_Export_Object => -1,
28258 Pragma_Export_Procedure => -1,
28259 Pragma_Export_Value => -1,
28260 Pragma_Export_Valued_Procedure => -1,
28261 Pragma_Extend_System => -1,
28262 Pragma_Extensions_Allowed => 0,
28263 Pragma_Extensions_Visible => 0,
28264 Pragma_External => -1,
28265 Pragma_Favor_Top_Level => 0,
28266 Pragma_External_Name_Casing => 0,
28267 Pragma_Fast_Math => 0,
28268 Pragma_Finalize_Storage_Only => 0,
28270 Pragma_Global => -1,
28271 Pragma_Ident => -1,
28272 Pragma_Ignore_Pragma => 0,
28273 Pragma_Implementation_Defined => -1,
28274 Pragma_Implemented => -1,
28275 Pragma_Implicit_Packing => 0,
28276 Pragma_Import => 93,
28277 Pragma_Import_Function => 0,
28278 Pragma_Import_Object => 0,
28279 Pragma_Import_Procedure => 0,
28280 Pragma_Import_Valued_Procedure => 0,
28281 Pragma_Independent => 0,
28282 Pragma_Independent_Components => 0,
28283 Pragma_Initial_Condition => -1,
28284 Pragma_Initialize_Scalars => 0,
28285 Pragma_Initializes => -1,
28286 Pragma_Inline => 0,
28287 Pragma_Inline_Always => 0,
28288 Pragma_Inline_Generic => 0,
28289 Pragma_Inspection_Point => -1,
28290 Pragma_Interface => 92,
28291 Pragma_Interface_Name => 0,
28292 Pragma_Interrupt_Handler => -1,
28293 Pragma_Interrupt_Priority => -1,
28294 Pragma_Interrupt_State => -1,
28295 Pragma_Invariant => -1,
28296 Pragma_Keep_Names => 0,
28297 Pragma_License => 0,
28298 Pragma_Link_With => -1,
28299 Pragma_Linker_Alias => -1,
28300 Pragma_Linker_Constructor => -1,
28301 Pragma_Linker_Destructor => -1,
28302 Pragma_Linker_Options => -1,
28303 Pragma_Linker_Section => 0,
28305 Pragma_Lock_Free => 0,
28306 Pragma_Locking_Policy => 0,
28307 Pragma_Loop_Invariant => -1,
28308 Pragma_Loop_Optimize => 0,
28309 Pragma_Loop_Variant => -1,
28310 Pragma_Machine_Attribute => -1,
28312 Pragma_Main_Storage => -1,
28313 Pragma_Memory_Size => 0,
28314 Pragma_No_Return => 0,
28315 Pragma_No_Body => 0,
28316 Pragma_No_Elaboration_Code_All => 0,
28317 Pragma_No_Inline => 0,
28318 Pragma_No_Run_Time => -1,
28319 Pragma_No_Strict_Aliasing => -1,
28320 Pragma_No_Tagged_Streams => 0,
28321 Pragma_Normalize_Scalars => 0,
28322 Pragma_Obsolescent => 0,
28323 Pragma_Optimize => 0,
28324 Pragma_Optimize_Alignment => 0,
28325 Pragma_Overflow_Mode => 0,
28326 Pragma_Overriding_Renamings => 0,
28327 Pragma_Ordered => 0,
28330 Pragma_Part_Of => 0,
28331 Pragma_Partition_Elaboration_Policy => 0,
28332 Pragma_Passive => 0,
28333 Pragma_Persistent_BSS => 0,
28334 Pragma_Polling => 0,
28335 Pragma_Prefix_Exception_Messages => 0,
28337 Pragma_Postcondition => -1,
28338 Pragma_Post_Class => -1,
28340 Pragma_Precondition => -1,
28341 Pragma_Predicate => -1,
28342 Pragma_Predicate_Failure => -1,
28343 Pragma_Preelaborable_Initialization => -1,
28344 Pragma_Preelaborate => 0,
28345 Pragma_Pre_Class => -1,
28346 Pragma_Priority => -1,
28347 Pragma_Priority_Specific_Dispatching => 0,
28348 Pragma_Profile => 0,
28349 Pragma_Profile_Warnings => 0,
28350 Pragma_Propagate_Exceptions => 0,
28351 Pragma_Provide_Shift_Operators => 0,
28352 Pragma_Psect_Object => 0,
28354 Pragma_Pure_Function => 0,
28355 Pragma_Queuing_Policy => 0,
28356 Pragma_Rational => 0,
28357 Pragma_Ravenscar => 0,
28358 Pragma_Refined_Depends => -1,
28359 Pragma_Refined_Global => -1,
28360 Pragma_Refined_Post => -1,
28361 Pragma_Refined_State => -1,
28362 Pragma_Relative_Deadline => 0,
28363 Pragma_Remote_Access_Type => -1,
28364 Pragma_Remote_Call_Interface => -1,
28365 Pragma_Remote_Types => -1,
28366 Pragma_Restricted_Run_Time => 0,
28367 Pragma_Restriction_Warnings => 0,
28368 Pragma_Restrictions => 0,
28369 Pragma_Reviewable => -1,
28370 Pragma_Short_Circuit_And_Or => 0,
28371 Pragma_Share_Generic => 0,
28372 Pragma_Shared => 0,
28373 Pragma_Shared_Passive => 0,
28374 Pragma_Short_Descriptors => 0,
28375 Pragma_Simple_Storage_Pool_Type => 0,
28376 Pragma_Source_File_Name => 0,
28377 Pragma_Source_File_Name_Project => 0,
28378 Pragma_Source_Reference => 0,
28379 Pragma_SPARK_Mode => 0,
28380 Pragma_Storage_Size => -1,
28381 Pragma_Storage_Unit => 0,
28382 Pragma_Static_Elaboration_Desired => 0,
28383 Pragma_Stream_Convert => 0,
28384 Pragma_Style_Checks => 0,
28385 Pragma_Subtitle => 0,
28386 Pragma_Suppress => 0,
28387 Pragma_Suppress_Exception_Locations => 0,
28388 Pragma_Suppress_All => 0,
28389 Pragma_Suppress_Debug_Info => 0,
28390 Pragma_Suppress_Initialization => 0,
28391 Pragma_System_Name => 0,
28392 Pragma_Task_Dispatching_Policy => 0,
28393 Pragma_Task_Info => -1,
28394 Pragma_Task_Name => -1,
28395 Pragma_Task_Storage => -1,
28396 Pragma_Test_Case => -1,
28397 Pragma_Thread_Local_Storage => -1,
28398 Pragma_Time_Slice => -1,
28400 Pragma_Type_Invariant => -1,
28401 Pragma_Type_Invariant_Class => -1,
28402 Pragma_Unchecked_Union => 0,
28403 Pragma_Unimplemented_Unit => 0,
28404 Pragma_Universal_Aliasing => 0,
28405 Pragma_Universal_Data => 0,
28406 Pragma_Unmodified => 0,
28407 Pragma_Unreferenced => 0,
28408 Pragma_Unreferenced_Objects => 0,
28409 Pragma_Unreserve_All_Interrupts => 0,
28410 Pragma_Unsuppress => 0,
28411 Pragma_Unevaluated_Use_Of_Old => 0,
28412 Pragma_Use_VADS_Size => 0,
28413 Pragma_Validity_Checks => 0,
28414 Pragma_Volatile => 0,
28415 Pragma_Volatile_Components => 0,
28416 Pragma_Volatile_Full_Access => 0,
28417 Pragma_Volatile_Function => 0,
28418 Pragma_Warning_As_Error => 0,
28419 Pragma_Warnings => 0,
28420 Pragma_Weak_External => 0,
28421 Pragma_Wide_Character_Encoding => 0,
28422 Unknown_Pragma => 0);
28424 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28430 function Arg_No return Nat;
28431 -- Returns an integer showing what argument we are in. A value of
28432 -- zero means we are not in any of the arguments.
28438 function Arg_No return Nat is
28443 A := First (Pragma_Argument_Associations (Parent (P)));
28457 -- Start of processing for Non_Significant_Pragma_Reference
28462 if Nkind (P) /= N_Pragma_Argument_Association then
28466 Id := Get_Pragma_Id (Parent (P));
28467 C := Sig_Flags (Id);
28482 return AN < (C - 90);
28488 end Is_Non_Significant_Pragma_Reference;
28490 ------------------------------
28491 -- Is_Pragma_String_Literal --
28492 ------------------------------
28494 -- This function returns true if the corresponding pragma argument is a
28495 -- static string expression. These are the only cases in which string
28496 -- literals can appear as pragma arguments. We also allow a string literal
28497 -- as the first argument to pragma Assert (although it will of course
28498 -- always generate a type error).
28500 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28501 Pragn : constant Node_Id := Parent (Par);
28502 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28503 Pname : constant Name_Id := Pragma_Name (Pragn);
28509 N := First (Assoc);
28516 if Pname = Name_Assert then
28519 elsif Pname = Name_Export then
28522 elsif Pname = Name_Ident then
28525 elsif Pname = Name_Import then
28528 elsif Pname = Name_Interface_Name then
28531 elsif Pname = Name_Linker_Alias then
28534 elsif Pname = Name_Linker_Section then
28537 elsif Pname = Name_Machine_Attribute then
28540 elsif Pname = Name_Source_File_Name then
28543 elsif Pname = Name_Source_Reference then
28546 elsif Pname = Name_Title then
28549 elsif Pname = Name_Subtitle then
28555 end Is_Pragma_String_Literal;
28557 ---------------------------
28558 -- Is_Private_SPARK_Mode --
28559 ---------------------------
28561 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28564 (Nkind (N) = N_Pragma
28565 and then Pragma_Name (N) = Name_SPARK_Mode
28566 and then Is_List_Member (N));
28568 -- For pragma SPARK_Mode to be private, it has to appear in the private
28569 -- declarations of a package.
28572 Present (Parent (N))
28573 and then Nkind (Parent (N)) = N_Package_Specification
28574 and then List_Containing (N) = Private_Declarations (Parent (N));
28575 end Is_Private_SPARK_Mode;
28577 -------------------------------------
28578 -- Is_Unconstrained_Or_Tagged_Item --
28579 -------------------------------------
28581 function Is_Unconstrained_Or_Tagged_Item
28582 (Item : Entity_Id) return Boolean
28584 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28585 -- Determine whether record type Typ has at least one unconstrained
28588 ---------------------------------
28589 -- Has_Unconstrained_Component --
28590 ---------------------------------
28592 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28596 Comp := First_Component (Typ);
28597 while Present (Comp) loop
28598 if Is_Unconstrained_Or_Tagged_Item (Comp) then
28602 Next_Component (Comp);
28606 end Has_Unconstrained_Component;
28610 Typ : constant Entity_Id := Etype (Item);
28612 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28615 if Is_Tagged_Type (Typ) then
28618 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28621 elsif Is_Record_Type (Typ) then
28622 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28625 return Has_Unconstrained_Component (Typ);
28628 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28634 end Is_Unconstrained_Or_Tagged_Item;
28636 -----------------------------
28637 -- Is_Valid_Assertion_Kind --
28638 -----------------------------
28640 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28647 Name_Assertion_Policy |
28648 Name_Static_Predicate |
28649 Name_Dynamic_Predicate |
28654 Name_Type_Invariant |
28655 Name_uType_Invariant |
28659 Name_Assert_And_Cut |
28661 Name_Contract_Cases |
28663 Name_Default_Initial_Condition |
28665 Name_Initial_Condition |
28668 Name_Loop_Invariant |
28669 Name_Loop_Variant |
28670 Name_Postcondition |
28671 Name_Precondition |
28673 Name_Refined_Post |
28674 Name_Statement_Assertions => return True;
28676 when others => return False;
28678 end Is_Valid_Assertion_Kind;
28680 --------------------------------------
28681 -- Process_Compilation_Unit_Pragmas --
28682 --------------------------------------
28684 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28686 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28687 -- strange because it comes at the end of the unit. Rational has the
28688 -- same name for a pragma, but treats it as a program unit pragma, In
28689 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28690 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28691 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28692 -- the context clause to ensure the correct processing.
28694 if Has_Pragma_Suppress_All (N) then
28695 Prepend_To (Context_Items (N),
28696 Make_Pragma (Sloc (N),
28697 Chars => Name_Suppress,
28698 Pragma_Argument_Associations => New_List (
28699 Make_Pragma_Argument_Association (Sloc (N),
28700 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28703 -- Nothing else to do at the current time
28705 end Process_Compilation_Unit_Pragmas;
28707 ------------------------------------
28708 -- Record_Possible_Body_Reference --
28709 ------------------------------------
28711 procedure Record_Possible_Body_Reference
28712 (State_Id : Entity_Id;
28716 Spec_Id : Entity_Id;
28719 -- Ensure that we are dealing with a reference to a state
28721 pragma Assert (Ekind (State_Id) = E_Abstract_State);
28723 -- Climb the tree starting from the reference looking for a package body
28724 -- whose spec declares the referenced state. This criteria automatically
28725 -- excludes references in package specs which are legal. Note that it is
28726 -- not wise to emit an error now as the package body may lack pragma
28727 -- Refined_State or the referenced state may not be mentioned in the
28728 -- refinement. This approach avoids the generation of misleading errors.
28731 while Present (Context) loop
28732 if Nkind (Context) = N_Package_Body then
28733 Spec_Id := Corresponding_Spec (Context);
28735 if Present (Abstract_States (Spec_Id))
28736 and then Contains (Abstract_States (Spec_Id), State_Id)
28738 if No (Body_References (State_Id)) then
28739 Set_Body_References (State_Id, New_Elmt_List);
28742 Append_Elmt (Ref, To => Body_References (State_Id));
28747 Context := Parent (Context);
28749 end Record_Possible_Body_Reference;
28751 ------------------------------------------
28752 -- Relocate_Pragmas_To_Anonymous_Object --
28753 ------------------------------------------
28755 procedure Relocate_Pragmas_To_Anonymous_Object
28756 (Typ_Decl : Node_Id;
28757 Obj_Decl : Node_Id)
28761 Next_Decl : Node_Id;
28764 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28765 Def := Protected_Definition (Typ_Decl);
28767 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28768 Def := Task_Definition (Typ_Decl);
28771 -- The concurrent definition has a visible declaration list. Inspect it
28772 -- and relocate all canidate pragmas.
28774 if Present (Def) and then Present (Visible_Declarations (Def)) then
28775 Decl := First (Visible_Declarations (Def));
28776 while Present (Decl) loop
28778 -- Preserve the following declaration for iteration purposes due
28779 -- to possible relocation of a pragma.
28781 Next_Decl := Next (Decl);
28783 if Nkind (Decl) = N_Pragma
28784 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28787 Insert_After (Obj_Decl, Decl);
28789 -- Skip internally generated code
28791 elsif not Comes_From_Source (Decl) then
28794 -- No candidate pragmas are available for relocation
28803 end Relocate_Pragmas_To_Anonymous_Object;
28805 ------------------------------
28806 -- Relocate_Pragmas_To_Body --
28807 ------------------------------
28809 procedure Relocate_Pragmas_To_Body
28810 (Subp_Body : Node_Id;
28811 Target_Body : Node_Id := Empty)
28813 procedure Relocate_Pragma (Prag : Node_Id);
28814 -- Remove a single pragma from its current list and add it to the
28815 -- declarations of the proper body (either Subp_Body or Target_Body).
28817 ---------------------
28818 -- Relocate_Pragma --
28819 ---------------------
28821 procedure Relocate_Pragma (Prag : Node_Id) is
28826 -- When subprogram stubs or expression functions are involves, the
28827 -- destination declaration list belongs to the proper body.
28829 if Present (Target_Body) then
28830 Target := Target_Body;
28832 Target := Subp_Body;
28835 Decls := Declarations (Target);
28839 Set_Declarations (Target, Decls);
28842 -- Unhook the pragma from its current list
28845 Prepend (Prag, Decls);
28846 end Relocate_Pragma;
28850 Body_Id : constant Entity_Id :=
28851 Defining_Unit_Name (Specification (Subp_Body));
28852 Next_Stmt : Node_Id;
28855 -- Start of processing for Relocate_Pragmas_To_Body
28858 -- Do not process a body that comes from a separate unit as no construct
28859 -- can possibly follow it.
28861 if not Is_List_Member (Subp_Body) then
28864 -- Do not relocate pragmas that follow a stub if the stub does not have
28867 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28868 and then No (Target_Body)
28872 -- Do not process internally generated routine _Postconditions
28874 elsif Ekind (Body_Id) = E_Procedure
28875 and then Chars (Body_Id) = Name_uPostconditions
28880 -- Look at what is following the body. We are interested in certain kind
28881 -- of pragmas (either from source or byproducts of expansion) that can
28882 -- apply to a body [stub].
28884 Stmt := Next (Subp_Body);
28885 while Present (Stmt) loop
28887 -- Preserve the following statement for iteration purposes due to a
28888 -- possible relocation of a pragma.
28890 Next_Stmt := Next (Stmt);
28892 -- Move a candidate pragma following the body to the declarations of
28895 if Nkind (Stmt) = N_Pragma
28896 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28898 Relocate_Pragma (Stmt);
28900 -- Skip internally generated code
28902 elsif not Comes_From_Source (Stmt) then
28905 -- No candidate pragmas are available for relocation
28913 end Relocate_Pragmas_To_Body;
28915 -------------------
28916 -- Resolve_State --
28917 -------------------
28919 procedure Resolve_State (N : Node_Id) is
28924 if Is_Entity_Name (N) and then Present (Entity (N)) then
28925 Func := Entity (N);
28927 -- Handle overloading of state names by functions. Traverse the
28928 -- homonym chain looking for an abstract state.
28930 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
28931 State := Homonym (Func);
28932 while Present (State) loop
28934 -- Resolve the overloading by setting the proper entity of the
28935 -- reference to that of the state.
28937 if Ekind (State) = E_Abstract_State then
28938 Set_Etype (N, Standard_Void_Type);
28939 Set_Entity (N, State);
28940 Set_Associated_Node (N, State);
28944 State := Homonym (State);
28947 -- A function can never act as a state. If the homonym chain does
28948 -- not contain a corresponding state, then something went wrong in
28949 -- the overloading mechanism.
28951 raise Program_Error;
28956 ----------------------------
28957 -- Rewrite_Assertion_Kind --
28958 ----------------------------
28960 procedure Rewrite_Assertion_Kind (N : Node_Id) is
28964 if Nkind (N) = N_Attribute_Reference
28965 and then Attribute_Name (N) = Name_Class
28966 and then Nkind (Prefix (N)) = N_Identifier
28968 case Chars (Prefix (N)) is
28973 when Name_Type_Invariant =>
28974 Nam := Name_uType_Invariant;
28975 when Name_Invariant =>
28976 Nam := Name_uInvariant;
28981 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
28983 end Rewrite_Assertion_Kind;
28991 Dummy := Dummy + 1;
28994 --------------------------------
28995 -- Set_Encoded_Interface_Name --
28996 --------------------------------
28998 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
28999 Str : constant String_Id := Strval (S);
29000 Len : constant Nat := String_Length (Str);
29005 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29008 -- Stores encoded value of character code CC. The encoding we use an
29009 -- underscore followed by four lower case hex digits.
29015 procedure Encode is
29017 Store_String_Char (Get_Char_Code ('_'));
29019 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29021 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29023 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29025 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29028 -- Start of processing for Set_Encoded_Interface_Name
29031 -- If first character is asterisk, this is a link name, and we leave it
29032 -- completely unmodified. We also ignore null strings (the latter case
29033 -- happens only in error cases).
29036 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29038 Set_Interface_Name (E, S);
29043 CC := Get_String_Char (Str, J);
29045 exit when not In_Character_Range (CC);
29047 C := Get_Character (CC);
29049 exit when C /= '_' and then C /= '$'
29050 and then C not in '0' .. '9'
29051 and then C not in 'a' .. 'z'
29052 and then C not in 'A' .. 'Z';
29055 Set_Interface_Name (E, S);
29063 -- Here we need to encode. The encoding we use as follows:
29064 -- three underscores + four hex digits (lower case)
29068 for J in 1 .. String_Length (Str) loop
29069 CC := Get_String_Char (Str, J);
29071 if not In_Character_Range (CC) then
29074 C := Get_Character (CC);
29076 if C = '_' or else C = '$'
29077 or else C in '0' .. '9'
29078 or else C in 'a' .. 'z'
29079 or else C in 'A' .. 'Z'
29081 Store_String_Char (CC);
29088 Set_Interface_Name (E,
29089 Make_String_Literal (Sloc (S),
29090 Strval => End_String));
29092 end Set_Encoded_Interface_Name;
29094 ------------------------
29095 -- Set_Elab_Unit_Name --
29096 ------------------------
29098 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29103 if Nkind (N) = N_Identifier
29104 and then Nkind (With_Item) = N_Identifier
29106 Set_Entity (N, Entity (With_Item));
29108 elsif Nkind (N) = N_Selected_Component then
29109 Change_Selected_Component_To_Expanded_Name (N);
29110 Set_Entity (N, Entity (With_Item));
29111 Set_Entity (Selector_Name (N), Entity (N));
29113 Pref := Prefix (N);
29114 Scop := Scope (Entity (N));
29115 while Nkind (Pref) = N_Selected_Component loop
29116 Change_Selected_Component_To_Expanded_Name (Pref);
29117 Set_Entity (Selector_Name (Pref), Scop);
29118 Set_Entity (Pref, Scop);
29119 Pref := Prefix (Pref);
29120 Scop := Scope (Scop);
29123 Set_Entity (Pref, Scop);
29126 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29127 end Set_Elab_Unit_Name;
29129 -------------------
29130 -- Test_Case_Arg --
29131 -------------------
29133 function Test_Case_Arg
29136 From_Aspect : Boolean := False) return Node_Id
29138 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29143 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29148 -- The caller requests the aspect argument
29150 if From_Aspect then
29151 if Present (Aspect)
29152 and then Nkind (Expression (Aspect)) = N_Aggregate
29154 Args := Expression (Aspect);
29156 -- "Name" and "Mode" may appear without an identifier as a
29157 -- positional association.
29159 if Present (Expressions (Args)) then
29160 Arg := First (Expressions (Args));
29162 if Present (Arg) and then Arg_Nam = Name_Name then
29170 if Present (Arg) and then Arg_Nam = Name_Mode then
29175 -- Some or all arguments may appear as component associatons
29177 if Present (Component_Associations (Args)) then
29178 Arg := First (Component_Associations (Args));
29179 while Present (Arg) loop
29180 if Chars (First (Choices (Arg))) = Arg_Nam then
29189 -- Otherwise retrieve the argument directly from the pragma
29192 Arg := First (Pragma_Argument_Associations (Prag));
29194 if Present (Arg) and then Arg_Nam = Name_Name then
29198 -- Skip argument "Name"
29202 if Present (Arg) and then Arg_Nam = Name_Mode then
29206 -- Skip argument "Mode"
29210 -- Arguments "Requires" and "Ensures" are optional and may not be
29213 while Present (Arg) loop
29214 if Chars (Arg) = Arg_Nam then