1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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;
46 with Gnatvsn; use Gnatvsn;
48 with Lib.Writ; use Lib.Writ;
49 with Lib.Xref; use Lib.Xref;
50 with Namet.Sp; use Namet.Sp;
51 with Nlists; use Nlists;
52 with Nmake; use Nmake;
53 with Output; use Output;
54 with Par_SCO; use Par_SCO;
55 with Restrict; use Restrict;
56 with Rident; use Rident;
57 with Rtsfind; use Rtsfind;
59 with Sem_Aux; use Sem_Aux;
60 with Sem_Ch3; use Sem_Ch3;
61 with Sem_Ch6; use Sem_Ch6;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Ch12; use Sem_Ch12;
64 with Sem_Ch13; use Sem_Ch13;
65 with Sem_Disp; use Sem_Disp;
66 with Sem_Dist; use Sem_Dist;
67 with Sem_Elim; use Sem_Elim;
68 with Sem_Eval; use Sem_Eval;
69 with Sem_Intr; use Sem_Intr;
70 with Sem_Mech; use Sem_Mech;
71 with Sem_Res; use Sem_Res;
72 with Sem_Type; use Sem_Type;
73 with Sem_Util; use Sem_Util;
74 with Sem_Warn; use Sem_Warn;
75 with Stand; use Stand;
76 with Sinfo; use Sinfo;
77 with Sinfo.CN; use Sinfo.CN;
78 with Sinput; use Sinput;
79 with Stringt; use Stringt;
80 with Stylesw; use Stylesw;
82 with Targparm; use Targparm;
83 with Tbuild; use Tbuild;
85 with Uintp; use Uintp;
86 with Uname; use Uname;
87 with Urealp; use Urealp;
88 with Validsw; use Validsw;
89 with Warnsw; use Warnsw;
91 package body Sem_Prag is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all lower case letters.
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
171 -- This routine is used for possible casing adjustment of an explicit
172 -- external name supplied as a string literal (the node N), according to
173 -- the casing requirement of Opt.External_Name_Casing. If this is set to
174 -- As_Is, then the string literal is returned unchanged, but if it is set
175 -- to Uppercase or Lowercase, then a new string literal with appropriate
176 -- casing is constructed.
178 procedure Analyze_Part_Of
182 Encap_Id : out Entity_Id;
183 Legal : out Boolean);
184 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
185 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
186 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
187 -- package instantiation. Encap denotes the encapsulating state or single
188 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
189 -- the indicator is legal.
191 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
192 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
193 -- Query whether a particular item appears in a mixed list of nodes and
194 -- entities. It is assumed that all nodes in the list have entities.
196 procedure Check_Postcondition_Use_In_Inlined_Subprogram
198 Spec_Id : Entity_Id);
199 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
200 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
201 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
203 procedure Check_State_And_Constituent_Use
207 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
208 -- Global and Initializes. Determine whether a state from list States and a
209 -- corresponding constituent from list Constits (if any) appear in the same
210 -- context denoted by Context. If this is the case, emit an error.
212 procedure Contract_Freeze_Error
213 (Contract_Id : Entity_Id;
214 Freeze_Id : Entity_Id);
215 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
216 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
217 -- of a body which caused contract "freezing" and Contract_Id denotes the
218 -- entity of the affected contstruct.
220 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
221 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
222 -- Prag that duplicates previous pragma Prev.
224 function Find_Encapsulating_State
226 Constit_Id : Entity_Id) return Entity_Id;
227 -- Given the entity of a constituent Constit_Id, find the corresponding
228 -- encapsulating state which appears in States. The routine returns Empty
229 -- if no such state is found.
231 function Find_Related_Context
233 Do_Checks : Boolean := False) return Node_Id;
234 -- Subsidiary to the analysis of pragmas
237 -- Constant_After_Elaboration
241 -- Find the first source declaration or statement found while traversing
242 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
243 -- set, the routine reports duplicate pragmas. The routine returns Empty
244 -- when reaching the start of the node chain.
246 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
247 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
248 -- original one, following the renaming chain) is returned. Otherwise the
249 -- entity is returned unchanged. Should be in Einfo???
251 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
252 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
253 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
254 -- value of type SPARK_Mode_Type.
256 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
257 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
258 -- Determine whether dependency clause Clause is surrounded by extra
259 -- parentheses. If this is the case, issue an error message.
261 function Is_CCT_Instance
263 Context_Id : Entity_Id) return Boolean;
264 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
265 -- Global. Determine whether entity Ref_Id denotes the current instance of
266 -- a concurrent type. Context_Id denotes the associated context where the
269 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Record_Possible_Body_Reference
276 (State_Id : Entity_Id;
278 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
279 -- Global. Given an abstract state denoted by State_Id and a reference Ref
280 -- to it, determine whether the reference appears in a package body that
281 -- will eventually refine the state. If this is the case, record the
282 -- reference for future checks (see Analyze_Refined_State_In_Decls).
284 procedure Resolve_State (N : Node_Id);
285 -- Handle the overloading of state names by functions. When N denotes a
286 -- function, this routine finds the corresponding state and sets the entity
287 -- of N to that of the state.
289 procedure Rewrite_Assertion_Kind
291 From_Policy : Boolean := False);
292 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
293 -- then it is rewritten as an identifier with the corresponding special
294 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
295 -- and Check_Policy. If the names are Precondition or Postcondition, this
296 -- combination is deprecated in favor of Assertion_Policy and Ada2012
297 -- Aspect names. The parameter From_Policy indicates that the pragma
298 -- is the old non-standard Check_Policy and not a rewritten pragma.
300 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
301 -- Place semantic information on the argument of an Elaborate/Elaborate_All
302 -- pragma. Entity name for unit and its parents is taken from item in
303 -- previous with_clause that mentions the unit.
305 Dummy : Integer := 0;
306 pragma Volatile (Dummy);
307 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
310 pragma No_Inline (ip);
311 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
312 -- is just to help debugging the front end. If a pragma Inspection_Point
313 -- is added to a source program, then breaking on ip will get you to that
314 -- point in the program.
317 pragma No_Inline (rv);
318 -- This is a dummy function called by the processing for pragma Reviewable.
319 -- It is there for assisting front end debugging. By placing a Reviewable
320 -- pragma in the source program, a breakpoint on rv catches this place in
321 -- the source, allowing convenient stepping to the point of interest.
323 -------------------------------
324 -- Adjust_External_Name_Case --
325 -------------------------------
327 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
331 -- Adjust case of literal if required
333 if Opt.External_Name_Exp_Casing = As_Is then
337 -- Copy existing string
343 for J in 1 .. String_Length (Strval (N)) loop
344 CC := Get_String_Char (Strval (N), J);
346 if Opt.External_Name_Exp_Casing = Uppercase
347 and then CC >= Get_Char_Code ('a')
348 and then CC <= Get_Char_Code ('z')
350 Store_String_Char (CC - 32);
352 elsif Opt.External_Name_Exp_Casing = Lowercase
353 and then CC >= Get_Char_Code ('A')
354 and then CC <= Get_Char_Code ('Z')
356 Store_String_Char (CC + 32);
359 Store_String_Char (CC);
364 Make_String_Literal (Sloc (N),
365 Strval => End_String);
367 end Adjust_External_Name_Case;
369 -----------------------------------------
370 -- Analyze_Contract_Cases_In_Decl_Part --
371 -----------------------------------------
373 -- WARNING: This routine manages Ghost regions. Return statements must be
374 -- replaced by gotos which jump to the end of the routine and restore the
377 procedure Analyze_Contract_Cases_In_Decl_Part
379 Freeze_Id : Entity_Id := Empty)
381 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
382 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
384 Others_Seen : Boolean := False;
385 -- This flag is set when an "others" choice is encountered. It is used
386 -- to detect multiple illegal occurrences of "others".
388 procedure Analyze_Contract_Case (CCase : Node_Id);
389 -- Verify the legality of a single contract case
391 ---------------------------
392 -- Analyze_Contract_Case --
393 ---------------------------
395 procedure Analyze_Contract_Case (CCase : Node_Id) is
396 Case_Guard : Node_Id;
399 Extra_Guard : Node_Id;
402 if Nkind (CCase) = N_Component_Association then
403 Case_Guard := First (Choices (CCase));
404 Conseq := Expression (CCase);
406 -- Each contract case must have exactly one case guard
408 Extra_Guard := Next (Case_Guard);
410 if Present (Extra_Guard) then
412 ("contract case must have exactly one case guard",
416 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
418 if Nkind (Case_Guard) = N_Others_Choice then
421 ("only one others choice allowed in contract cases",
427 elsif Others_Seen then
429 ("others must be the last choice in contract cases", N);
432 -- Preanalyze the case guard and consequence
434 if Nkind (Case_Guard) /= N_Others_Choice then
435 Errors := Serious_Errors_Detected;
436 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
438 -- Emit a clarification message when the case guard contains
439 -- at least one undefined reference, possibly due to contract
442 if Errors /= Serious_Errors_Detected
443 and then Present (Freeze_Id)
444 and then Has_Undefined_Reference (Case_Guard)
446 Contract_Freeze_Error (Spec_Id, Freeze_Id);
450 Errors := Serious_Errors_Detected;
451 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
453 -- Emit a clarification message when the consequence contains
454 -- at least one undefined reference, possibly due to contract
457 if Errors /= Serious_Errors_Detected
458 and then Present (Freeze_Id)
459 and then Has_Undefined_Reference (Conseq)
461 Contract_Freeze_Error (Spec_Id, Freeze_Id);
464 -- The contract case is malformed
467 Error_Msg_N ("wrong syntax in contract case", CCase);
469 end Analyze_Contract_Case;
473 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
475 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
476 -- Save the Ghost mode to restore on exit
479 Restore_Scope : Boolean := False;
481 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
484 -- Do not analyze the pragma multiple times
486 if Is_Analyzed_Pragma (N) then
490 -- Set the Ghost mode in effect from the pragma. Due to the delayed
491 -- analysis of the pragma, the Ghost mode at point of declaration and
492 -- point of analysis may not necessarily be the same. Use the mode in
493 -- effect at the point of declaration.
497 -- Single and multiple contract cases must appear in aggregate form. If
498 -- this is not the case, then either the parser of the analysis of the
499 -- pragma failed to produce an aggregate.
501 pragma Assert (Nkind (CCases) = N_Aggregate);
503 if Present (Component_Associations (CCases)) then
505 -- Ensure that the formal parameters are visible when analyzing all
506 -- clauses. This falls out of the general rule of aspects pertaining
507 -- to subprogram declarations.
509 if not In_Open_Scopes (Spec_Id) then
510 Restore_Scope := True;
511 Push_Scope (Spec_Id);
513 if Is_Generic_Subprogram (Spec_Id) then
514 Install_Generic_Formals (Spec_Id);
516 Install_Formals (Spec_Id);
520 CCase := First (Component_Associations (CCases));
521 while Present (CCase) loop
522 Analyze_Contract_Case (CCase);
526 if Restore_Scope then
530 -- Currently it is not possible to inline pre/postconditions on a
531 -- subprogram subject to pragma Inline_Always.
533 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
535 -- Otherwise the pragma is illegal
538 Error_Msg_N ("wrong syntax for constract cases", N);
541 Set_Is_Analyzed_Pragma (N);
543 Restore_Ghost_Mode (Saved_GM);
544 end Analyze_Contract_Cases_In_Decl_Part;
546 ----------------------------------
547 -- Analyze_Depends_In_Decl_Part --
548 ----------------------------------
550 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
551 Loc : constant Source_Ptr := Sloc (N);
552 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
553 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
555 All_Inputs_Seen : Elist_Id := No_Elist;
556 -- A list containing the entities of all the inputs processed so far.
557 -- The list is populated with unique entities because the same input
558 -- may appear in multiple input lists.
560 All_Outputs_Seen : Elist_Id := No_Elist;
561 -- A list containing the entities of all the outputs processed so far.
562 -- The list is populated with unique entities because output items are
563 -- unique in a dependence relation.
565 Constits_Seen : Elist_Id := No_Elist;
566 -- A list containing the entities of all constituents processed so far.
567 -- It aids in detecting illegal usage of a state and a corresponding
568 -- constituent in pragma [Refinde_]Depends.
570 Global_Seen : Boolean := False;
571 -- A flag set when pragma Global has been processed
573 Null_Output_Seen : Boolean := False;
574 -- A flag used to track the legality of a null output
576 Result_Seen : Boolean := False;
577 -- A flag set when Spec_Id'Result is processed
579 States_Seen : Elist_Id := No_Elist;
580 -- A list containing the entities of all states processed so far. It
581 -- helps in detecting illegal usage of a state and a corresponding
582 -- constituent in pragma [Refined_]Depends.
584 Subp_Inputs : Elist_Id := No_Elist;
585 Subp_Outputs : Elist_Id := No_Elist;
586 -- Two lists containing the full set of inputs and output of the related
587 -- subprograms. Note that these lists contain both nodes and entities.
589 Task_Input_Seen : Boolean := False;
590 Task_Output_Seen : Boolean := False;
591 -- Flags used to track the implicit dependence of a task unit on itself
593 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
594 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
595 -- to the name buffer. The individual kinds are as follows:
596 -- E_Abstract_State - "state"
597 -- E_Constant - "constant"
598 -- E_Discriminant - "discriminant"
599 -- E_Generic_In_Out_Parameter - "generic parameter"
600 -- E_Generic_In_Parameter - "generic parameter"
601 -- E_In_Parameter - "parameter"
602 -- E_In_Out_Parameter - "parameter"
603 -- E_Loop_Parameter - "loop parameter"
604 -- E_Out_Parameter - "parameter"
605 -- E_Protected_Type - "current instance of protected type"
606 -- E_Task_Type - "current instance of task type"
607 -- E_Variable - "global"
609 procedure Analyze_Dependency_Clause
612 -- Verify the legality of a single dependency clause. Flag Is_Last
613 -- denotes whether Clause is the last clause in the relation.
615 procedure Check_Function_Return;
616 -- Verify that Funtion'Result appears as one of the outputs
617 -- (SPARK RM 6.1.5(10)).
624 -- Ensure that an item fulfills its designated input and/or output role
625 -- as specified by pragma Global (if any) or the enclosing context. If
626 -- this is not the case, emit an error. Item and Item_Id denote the
627 -- attributes of an item. Flag Is_Input should be set when item comes
628 -- from an input list. Flag Self_Ref should be set when the item is an
629 -- output and the dependency clause has operator "+".
631 procedure Check_Usage
632 (Subp_Items : Elist_Id;
633 Used_Items : Elist_Id;
635 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
636 -- error if this is not the case.
638 procedure Normalize_Clause (Clause : Node_Id);
639 -- Remove a self-dependency "+" from the input list of a clause
641 -----------------------------
642 -- Add_Item_To_Name_Buffer --
643 -----------------------------
645 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
647 if Ekind (Item_Id) = E_Abstract_State then
648 Add_Str_To_Name_Buffer ("state");
650 elsif Ekind (Item_Id) = E_Constant then
651 Add_Str_To_Name_Buffer ("constant");
653 elsif Ekind (Item_Id) = E_Discriminant then
654 Add_Str_To_Name_Buffer ("discriminant");
656 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
657 E_Generic_In_Parameter)
659 Add_Str_To_Name_Buffer ("generic parameter");
661 elsif Is_Formal (Item_Id) then
662 Add_Str_To_Name_Buffer ("parameter");
664 elsif Ekind (Item_Id) = E_Loop_Parameter then
665 Add_Str_To_Name_Buffer ("loop parameter");
667 elsif Ekind (Item_Id) = E_Protected_Type
668 or else Is_Single_Protected_Object (Item_Id)
670 Add_Str_To_Name_Buffer ("current instance of protected type");
672 elsif Ekind (Item_Id) = E_Task_Type
673 or else Is_Single_Task_Object (Item_Id)
675 Add_Str_To_Name_Buffer ("current instance of task type");
677 elsif Ekind (Item_Id) = E_Variable then
678 Add_Str_To_Name_Buffer ("global");
680 -- The routine should not be called with non-SPARK items
685 end Add_Item_To_Name_Buffer;
687 -------------------------------
688 -- Analyze_Dependency_Clause --
689 -------------------------------
691 procedure Analyze_Dependency_Clause
695 procedure Analyze_Input_List (Inputs : Node_Id);
696 -- Verify the legality of a single input list
698 procedure Analyze_Input_Output
703 Seen : in out Elist_Id;
704 Null_Seen : in out Boolean;
705 Non_Null_Seen : in out Boolean);
706 -- Verify the legality of a single input or output item. Flag
707 -- Is_Input should be set whenever Item is an input, False when it
708 -- denotes an output. Flag Self_Ref should be set when the item is an
709 -- output and the dependency clause has a "+". Flag Top_Level should
710 -- be set whenever Item appears immediately within an input or output
711 -- list. Seen is a collection of all abstract states, objects and
712 -- formals processed so far. Flag Null_Seen denotes whether a null
713 -- input or output has been encountered. Flag Non_Null_Seen denotes
714 -- whether a non-null input or output has been encountered.
716 ------------------------
717 -- Analyze_Input_List --
718 ------------------------
720 procedure Analyze_Input_List (Inputs : Node_Id) is
721 Inputs_Seen : Elist_Id := No_Elist;
722 -- A list containing the entities of all inputs that appear in the
723 -- current input list.
725 Non_Null_Input_Seen : Boolean := False;
726 Null_Input_Seen : Boolean := False;
727 -- Flags used to check the legality of an input list
732 -- Multiple inputs appear as an aggregate
734 if Nkind (Inputs) = N_Aggregate then
735 if Present (Component_Associations (Inputs)) then
737 ("nested dependency relations not allowed", Inputs);
739 elsif Present (Expressions (Inputs)) then
740 Input := First (Expressions (Inputs));
741 while Present (Input) loop
748 Null_Seen => Null_Input_Seen,
749 Non_Null_Seen => Non_Null_Input_Seen);
754 -- Syntax error, always report
757 Error_Msg_N ("malformed input dependency list", Inputs);
760 -- Process a solitary input
769 Null_Seen => Null_Input_Seen,
770 Non_Null_Seen => Non_Null_Input_Seen);
773 -- Detect an illegal dependency clause of the form
777 if Null_Output_Seen and then Null_Input_Seen then
779 ("null dependency clause cannot have a null input list",
782 end Analyze_Input_List;
784 --------------------------
785 -- Analyze_Input_Output --
786 --------------------------
788 procedure Analyze_Input_Output
793 Seen : in out Elist_Id;
794 Null_Seen : in out Boolean;
795 Non_Null_Seen : in out Boolean)
797 procedure Current_Task_Instance_Seen;
798 -- Set the appropriate global flag when the current instance of a
799 -- task unit is encountered.
801 --------------------------------
802 -- Current_Task_Instance_Seen --
803 --------------------------------
805 procedure Current_Task_Instance_Seen is
808 Task_Input_Seen := True;
810 Task_Output_Seen := True;
812 end Current_Task_Instance_Seen;
816 Is_Output : constant Boolean := not Is_Input;
820 -- Start of processing for Analyze_Input_Output
823 -- Multiple input or output items appear as an aggregate
825 if Nkind (Item) = N_Aggregate then
826 if not Top_Level then
827 SPARK_Msg_N ("nested grouping of items not allowed", Item);
829 elsif Present (Component_Associations (Item)) then
831 ("nested dependency relations not allowed", Item);
833 -- Recursively analyze the grouped items
835 elsif Present (Expressions (Item)) then
836 Grouped := First (Expressions (Item));
837 while Present (Grouped) loop
840 Is_Input => Is_Input,
841 Self_Ref => Self_Ref,
844 Null_Seen => Null_Seen,
845 Non_Null_Seen => Non_Null_Seen);
850 -- Syntax error, always report
853 Error_Msg_N ("malformed dependency list", Item);
856 -- Process attribute 'Result in the context of a dependency clause
858 elsif Is_Attribute_Result (Item) then
859 Non_Null_Seen := True;
863 -- Attribute 'Result is allowed to appear on the output side of
864 -- a dependency clause (SPARK RM 6.1.5(6)).
867 SPARK_Msg_N ("function result cannot act as input", Item);
871 ("cannot mix null and non-null dependency items", Item);
877 -- Detect multiple uses of null in a single dependency list or
878 -- throughout the whole relation. Verify the placement of a null
879 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
881 elsif Nkind (Item) = N_Null then
884 ("multiple null dependency relations not allowed", Item);
886 elsif Non_Null_Seen then
888 ("cannot mix null and non-null dependency items", Item);
896 ("null output list must be the last clause in a "
897 & "dependency relation", Item);
899 -- Catch a useless dependence of the form:
904 ("useless dependence, null depends on itself", Item);
912 Non_Null_Seen := True;
915 SPARK_Msg_N ("cannot mix null and non-null items", Item);
919 Resolve_State (Item);
921 -- Find the entity of the item. If this is a renaming, climb
922 -- the renaming chain to reach the root object. Renamings of
923 -- non-entire objects do not yield an entity (Empty).
925 Item_Id := Entity_Of (Item);
927 if Present (Item_Id) then
931 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
934 -- Current instances of concurrent types
936 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
941 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
942 E_Generic_In_Parameter,
950 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
952 -- The item denotes a concurrent type. Note that single
953 -- protected/task types are not considered here because
954 -- they behave as objects in the context of pragma
955 -- [Refined_]Depends.
957 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
959 -- This use is legal as long as the concurrent type is
960 -- the current instance of an enclosing type.
962 if Is_CCT_Instance (Item_Id, Spec_Id) then
964 -- The dependence of a task unit on itself is
965 -- implicit and may or may not be explicitly
966 -- specified (SPARK RM 6.1.4).
968 if Ekind (Item_Id) = E_Task_Type then
969 Current_Task_Instance_Seen;
972 -- Otherwise this is not the current instance
976 ("invalid use of subtype mark in dependency "
980 -- The dependency of a task unit on itself is implicit
981 -- and may or may not be explicitly specified
984 elsif Is_Single_Task_Object (Item_Id)
985 and then Is_CCT_Instance (Item_Id, Spec_Id)
987 Current_Task_Instance_Seen;
990 -- Ensure that the item fulfills its role as input and/or
991 -- output as specified by pragma Global or the enclosing
994 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
996 -- Detect multiple uses of the same state, variable or
997 -- formal parameter. If this is not the case, add the
998 -- item to the list of processed relations.
1000 if Contains (Seen, Item_Id) then
1002 ("duplicate use of item &", Item, Item_Id);
1004 Append_New_Elmt (Item_Id, Seen);
1007 -- Detect illegal use of an input related to a null
1008 -- output. Such input items cannot appear in other
1009 -- input lists (SPARK RM 6.1.5(13)).
1012 and then Null_Output_Seen
1013 and then Contains (All_Inputs_Seen, Item_Id)
1016 ("input of a null output list cannot appear in "
1017 & "multiple input lists", Item);
1020 -- Add an input or a self-referential output to the list
1021 -- of all processed inputs.
1023 if Is_Input or else Self_Ref then
1024 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1027 -- State related checks (SPARK RM 6.1.5(3))
1029 if Ekind (Item_Id) = E_Abstract_State then
1031 -- Package and subprogram bodies are instantiated
1032 -- individually in a separate compiler pass. Due to
1033 -- this mode of instantiation, the refinement of a
1034 -- state may no longer be visible when a subprogram
1035 -- body contract is instantiated. Since the generic
1036 -- template is legal, do not perform this check in
1037 -- the instance to circumvent this oddity.
1039 if Is_Generic_Instance (Spec_Id) then
1042 -- An abstract state with visible refinement cannot
1043 -- appear in pragma [Refined_]Depends as its place
1044 -- must be taken by some of its constituents
1045 -- (SPARK RM 6.1.4(7)).
1047 elsif Has_Visible_Refinement (Item_Id) then
1049 ("cannot mention state & in dependence relation",
1051 SPARK_Msg_N ("\use its constituents instead", Item);
1054 -- If the reference to the abstract state appears in
1055 -- an enclosing package body that will eventually
1056 -- refine the state, record the reference for future
1060 Record_Possible_Body_Reference
1061 (State_Id => Item_Id,
1066 -- When the item renames an entire object, replace the
1067 -- item with a reference to the object.
1069 if Entity (Item) /= Item_Id then
1071 New_Occurrence_Of (Item_Id, Sloc (Item)));
1075 -- Add the entity of the current item to the list of
1078 if Ekind (Item_Id) = E_Abstract_State then
1079 Append_New_Elmt (Item_Id, States_Seen);
1081 -- The variable may eventually become a constituent of a
1082 -- single protected/task type. Record the reference now
1083 -- and verify its legality when analyzing the contract of
1084 -- the variable (SPARK RM 9.3).
1086 elsif Ekind (Item_Id) = E_Variable then
1087 Record_Possible_Part_Of_Reference
1092 if Ekind_In (Item_Id, E_Abstract_State,
1095 and then Present (Encapsulating_State (Item_Id))
1097 Append_New_Elmt (Item_Id, Constits_Seen);
1100 -- All other input/output items are illegal
1101 -- (SPARK RM 6.1.5(1)).
1105 ("item must denote parameter, variable, state or "
1106 & "current instance of concurren type", Item);
1109 -- All other input/output items are illegal
1110 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1114 ("item must denote parameter, variable, state or current "
1115 & "instance of concurrent type", Item);
1118 end Analyze_Input_Output;
1126 Non_Null_Output_Seen : Boolean := False;
1127 -- Flag used to check the legality of an output list
1129 -- Start of processing for Analyze_Dependency_Clause
1132 Inputs := Expression (Clause);
1135 -- An input list with a self-dependency appears as operator "+" where
1136 -- the actuals inputs are the right operand.
1138 if Nkind (Inputs) = N_Op_Plus then
1139 Inputs := Right_Opnd (Inputs);
1143 -- Process the output_list of a dependency_clause
1145 Output := First (Choices (Clause));
1146 while Present (Output) loop
1147 Analyze_Input_Output
1150 Self_Ref => Self_Ref,
1152 Seen => All_Outputs_Seen,
1153 Null_Seen => Null_Output_Seen,
1154 Non_Null_Seen => Non_Null_Output_Seen);
1159 -- Process the input_list of a dependency_clause
1161 Analyze_Input_List (Inputs);
1162 end Analyze_Dependency_Clause;
1164 ---------------------------
1165 -- Check_Function_Return --
1166 ---------------------------
1168 procedure Check_Function_Return is
1170 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1171 and then not Result_Seen
1174 ("result of & must appear in exactly one output list",
1177 end Check_Function_Return;
1183 procedure Check_Role
1185 Item_Id : Entity_Id;
1190 (Item_Is_Input : out Boolean;
1191 Item_Is_Output : out Boolean);
1192 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1193 -- Item_Is_Output are set depending on the role.
1195 procedure Role_Error
1196 (Item_Is_Input : Boolean;
1197 Item_Is_Output : Boolean);
1198 -- Emit an error message concerning the incorrect use of Item in
1199 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1200 -- denote whether the item is an input and/or an output.
1207 (Item_Is_Input : out Boolean;
1208 Item_Is_Output : out Boolean)
1211 Item_Is_Input := False;
1212 Item_Is_Output := False;
1216 if Ekind (Item_Id) = E_Abstract_State then
1218 -- When pragma Global is present, the mode of the state may be
1219 -- further constrained by setting a more restrictive mode.
1222 if Appears_In (Subp_Inputs, Item_Id) then
1223 Item_Is_Input := True;
1226 if Appears_In (Subp_Outputs, Item_Id) then
1227 Item_Is_Output := True;
1230 -- Otherwise the state has a default IN OUT mode
1233 Item_Is_Input := True;
1234 Item_Is_Output := True;
1239 elsif Ekind_In (Item_Id, E_Constant,
1243 Item_Is_Input := True;
1247 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1250 Item_Is_Input := True;
1252 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1255 Item_Is_Input := True;
1256 Item_Is_Output := True;
1258 elsif Ekind (Item_Id) = E_Out_Parameter then
1259 if Scope (Item_Id) = Spec_Id then
1261 -- An OUT parameter of the related subprogram has mode IN
1262 -- if its type is unconstrained or tagged because array
1263 -- bounds, discriminants or tags can be read.
1265 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1266 Item_Is_Input := True;
1269 Item_Is_Output := True;
1271 -- An OUT parameter of an enclosing subprogram behaves as a
1272 -- read-write variable in which case the mode is IN OUT.
1275 Item_Is_Input := True;
1276 Item_Is_Output := True;
1281 elsif Ekind (Item_Id) = E_Protected_Type then
1283 -- A protected type acts as a formal parameter of mode IN when
1284 -- it applies to a protected function.
1286 if Ekind (Spec_Id) = E_Function then
1287 Item_Is_Input := True;
1289 -- Otherwise the protected type acts as a formal of mode IN OUT
1292 Item_Is_Input := True;
1293 Item_Is_Output := True;
1298 elsif Ekind (Item_Id) = E_Task_Type then
1299 Item_Is_Input := True;
1300 Item_Is_Output := True;
1304 else pragma Assert (Ekind (Item_Id) = E_Variable);
1306 -- When pragma Global is present, the mode of the variable may
1307 -- be further constrained by setting a more restrictive mode.
1311 -- A variable has mode IN when its type is unconstrained or
1312 -- tagged because array bounds, discriminants or tags can be
1315 if Appears_In (Subp_Inputs, Item_Id)
1316 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1318 Item_Is_Input := True;
1321 if Appears_In (Subp_Outputs, Item_Id) then
1322 Item_Is_Output := True;
1325 -- Otherwise the variable has a default IN OUT mode
1328 Item_Is_Input := True;
1329 Item_Is_Output := True;
1338 procedure Role_Error
1339 (Item_Is_Input : Boolean;
1340 Item_Is_Output : Boolean)
1342 Error_Msg : Name_Id;
1347 -- When the item is not part of the input and the output set of
1348 -- the related subprogram, then it appears as extra in pragma
1349 -- [Refined_]Depends.
1351 if not Item_Is_Input and then not Item_Is_Output then
1352 Add_Item_To_Name_Buffer (Item_Id);
1353 Add_Str_To_Name_Buffer
1354 (" & cannot appear in dependence relation");
1356 Error_Msg := Name_Find;
1357 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1359 Error_Msg_Name_1 := Chars (Spec_Id);
1361 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1362 & "set of subprogram %"), Item, Item_Id);
1364 -- The mode of the item and its role in pragma [Refined_]Depends
1365 -- are in conflict. Construct a detailed message explaining the
1366 -- illegality (SPARK RM 6.1.5(5-6)).
1369 if Item_Is_Input then
1370 Add_Str_To_Name_Buffer ("read-only");
1372 Add_Str_To_Name_Buffer ("write-only");
1375 Add_Char_To_Name_Buffer (' ');
1376 Add_Item_To_Name_Buffer (Item_Id);
1377 Add_Str_To_Name_Buffer (" & cannot appear as ");
1379 if Item_Is_Input then
1380 Add_Str_To_Name_Buffer ("output");
1382 Add_Str_To_Name_Buffer ("input");
1385 Add_Str_To_Name_Buffer (" in dependence relation");
1386 Error_Msg := Name_Find;
1387 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1393 Item_Is_Input : Boolean;
1394 Item_Is_Output : Boolean;
1396 -- Start of processing for Check_Role
1399 Find_Role (Item_Is_Input, Item_Is_Output);
1404 if not Item_Is_Input then
1405 Role_Error (Item_Is_Input, Item_Is_Output);
1408 -- Self-referential item
1411 if not Item_Is_Input or else not Item_Is_Output then
1412 Role_Error (Item_Is_Input, Item_Is_Output);
1417 elsif not Item_Is_Output then
1418 Role_Error (Item_Is_Input, Item_Is_Output);
1426 procedure Check_Usage
1427 (Subp_Items : Elist_Id;
1428 Used_Items : Elist_Id;
1431 procedure Usage_Error (Item_Id : Entity_Id);
1432 -- Emit an error concerning the illegal usage of an item
1438 procedure Usage_Error (Item_Id : Entity_Id) is
1439 Error_Msg : Name_Id;
1446 -- Unconstrained and tagged items are not part of the explicit
1447 -- input set of the related subprogram, they do not have to be
1448 -- present in a dependence relation and should not be flagged
1449 -- (SPARK RM 6.1.5(8)).
1451 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1454 Add_Item_To_Name_Buffer (Item_Id);
1455 Add_Str_To_Name_Buffer
1456 (" & is missing from input dependence list");
1458 Error_Msg := Name_Find;
1459 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1461 ("\add `null ='> &` dependency to ignore this input",
1465 -- Output case (SPARK RM 6.1.5(10))
1470 Add_Item_To_Name_Buffer (Item_Id);
1471 Add_Str_To_Name_Buffer
1472 (" & is missing from output dependence list");
1474 Error_Msg := Name_Find;
1475 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1483 Item_Id : Entity_Id;
1485 -- Start of processing for Check_Usage
1488 if No (Subp_Items) then
1492 -- Each input or output of the subprogram must appear in a dependency
1495 Elmt := First_Elmt (Subp_Items);
1496 while Present (Elmt) loop
1497 Item := Node (Elmt);
1499 if Nkind (Item) = N_Defining_Identifier then
1502 Item_Id := Entity_Of (Item);
1505 -- The item does not appear in a dependency
1507 if Present (Item_Id)
1508 and then not Contains (Used_Items, Item_Id)
1510 if Is_Formal (Item_Id) then
1511 Usage_Error (Item_Id);
1513 -- The current instance of a protected type behaves as a formal
1514 -- parameter (SPARK RM 6.1.4).
1516 elsif Ekind (Item_Id) = E_Protected_Type
1517 or else Is_Single_Protected_Object (Item_Id)
1519 Usage_Error (Item_Id);
1521 -- The current instance of a task type behaves as a formal
1522 -- parameter (SPARK RM 6.1.4).
1524 elsif Ekind (Item_Id) = E_Task_Type
1525 or else Is_Single_Task_Object (Item_Id)
1527 -- The dependence of a task unit on itself is implicit and
1528 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1529 -- Emit an error if only one input/output is present.
1531 if Task_Input_Seen /= Task_Output_Seen then
1532 Usage_Error (Item_Id);
1535 -- States and global objects are not used properly only when
1536 -- the subprogram is subject to pragma Global.
1538 elsif Global_Seen then
1539 Usage_Error (Item_Id);
1547 ----------------------
1548 -- Normalize_Clause --
1549 ----------------------
1551 procedure Normalize_Clause (Clause : Node_Id) is
1552 procedure Create_Or_Modify_Clause
1558 Multiple : Boolean);
1559 -- Create a brand new clause to represent the self-reference or
1560 -- modify the input and/or output lists of an existing clause. Output
1561 -- denotes a self-referencial output. Outputs is the output list of a
1562 -- clause. Inputs is the input list of a clause. After denotes the
1563 -- clause after which the new clause is to be inserted. Flag In_Place
1564 -- should be set when normalizing the last output of an output list.
1565 -- Flag Multiple should be set when Output comes from a list with
1568 -----------------------------
1569 -- Create_Or_Modify_Clause --
1570 -----------------------------
1572 procedure Create_Or_Modify_Clause
1580 procedure Propagate_Output
1583 -- Handle the various cases of output propagation to the input
1584 -- list. Output denotes a self-referencial output item. Inputs
1585 -- is the input list of a clause.
1587 ----------------------
1588 -- Propagate_Output --
1589 ----------------------
1591 procedure Propagate_Output
1595 function In_Input_List
1597 Inputs : List_Id) return Boolean;
1598 -- Determine whether a particulat item appears in the input
1599 -- list of a clause.
1605 function In_Input_List
1607 Inputs : List_Id) return Boolean
1612 Elmt := First (Inputs);
1613 while Present (Elmt) loop
1614 if Entity_Of (Elmt) = Item then
1626 Output_Id : constant Entity_Id := Entity_Of (Output);
1629 -- Start of processing for Propagate_Output
1632 -- The clause is of the form:
1634 -- (Output =>+ null)
1636 -- Remove null input and replace it with a copy of the output:
1638 -- (Output => Output)
1640 if Nkind (Inputs) = N_Null then
1641 Rewrite (Inputs, New_Copy_Tree (Output));
1643 -- The clause is of the form:
1645 -- (Output =>+ (Input1, ..., InputN))
1647 -- Determine whether the output is not already mentioned in the
1648 -- input list and if not, add it to the list of inputs:
1650 -- (Output => (Output, Input1, ..., InputN))
1652 elsif Nkind (Inputs) = N_Aggregate then
1653 Grouped := Expressions (Inputs);
1655 if not In_Input_List
1659 Prepend_To (Grouped, New_Copy_Tree (Output));
1662 -- The clause is of the form:
1664 -- (Output =>+ Input)
1666 -- If the input does not mention the output, group the two
1669 -- (Output => (Output, Input))
1671 elsif Entity_Of (Inputs) /= Output_Id then
1673 Make_Aggregate (Loc,
1674 Expressions => New_List (
1675 New_Copy_Tree (Output),
1676 New_Copy_Tree (Inputs))));
1678 end Propagate_Output;
1682 Loc : constant Source_Ptr := Sloc (Clause);
1683 New_Clause : Node_Id;
1685 -- Start of processing for Create_Or_Modify_Clause
1688 -- A null output depending on itself does not require any
1691 if Nkind (Output) = N_Null then
1694 -- A function result cannot depend on itself because it cannot
1695 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1697 elsif Is_Attribute_Result (Output) then
1698 SPARK_Msg_N ("function result cannot depend on itself", Output);
1702 -- When performing the transformation in place, simply add the
1703 -- output to the list of inputs (if not already there). This
1704 -- case arises when dealing with the last output of an output
1705 -- list. Perform the normalization in place to avoid generating
1706 -- a malformed tree.
1709 Propagate_Output (Output, Inputs);
1711 -- A list with multiple outputs is slowly trimmed until only
1712 -- one element remains. When this happens, replace aggregate
1713 -- with the element itself.
1717 Rewrite (Outputs, Output);
1723 -- Unchain the output from its output list as it will appear in
1724 -- a new clause. Note that we cannot simply rewrite the output
1725 -- as null because this will violate the semantics of pragma
1730 -- Generate a new clause of the form:
1731 -- (Output => Inputs)
1734 Make_Component_Association (Loc,
1735 Choices => New_List (Output),
1736 Expression => New_Copy_Tree (Inputs));
1738 -- The new clause contains replicated content that has already
1739 -- been analyzed. There is not need to reanalyze or renormalize
1742 Set_Analyzed (New_Clause);
1745 (Output => First (Choices (New_Clause)),
1746 Inputs => Expression (New_Clause));
1748 Insert_After (After, New_Clause);
1750 end Create_Or_Modify_Clause;
1754 Outputs : constant Node_Id := First (Choices (Clause));
1756 Last_Output : Node_Id;
1757 Next_Output : Node_Id;
1760 -- Start of processing for Normalize_Clause
1763 -- A self-dependency appears as operator "+". Remove the "+" from the
1764 -- tree by moving the real inputs to their proper place.
1766 if Nkind (Expression (Clause)) = N_Op_Plus then
1767 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1768 Inputs := Expression (Clause);
1770 -- Multiple outputs appear as an aggregate
1772 if Nkind (Outputs) = N_Aggregate then
1773 Last_Output := Last (Expressions (Outputs));
1775 Output := First (Expressions (Outputs));
1776 while Present (Output) loop
1778 -- Normalization may remove an output from its list,
1779 -- preserve the subsequent output now.
1781 Next_Output := Next (Output);
1783 Create_Or_Modify_Clause
1788 In_Place => Output = Last_Output,
1791 Output := Next_Output;
1797 Create_Or_Modify_Clause
1806 end Normalize_Clause;
1810 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1811 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1815 Last_Clause : Node_Id;
1816 Restore_Scope : Boolean := False;
1818 -- Start of processing for Analyze_Depends_In_Decl_Part
1821 -- Do not analyze the pragma multiple times
1823 if Is_Analyzed_Pragma (N) then
1827 -- Empty dependency list
1829 if Nkind (Deps) = N_Null then
1831 -- Gather all states, objects and formal parameters that the
1832 -- subprogram may depend on. These items are obtained from the
1833 -- parameter profile or pragma [Refined_]Global (if available).
1835 Collect_Subprogram_Inputs_Outputs
1836 (Subp_Id => Subp_Id,
1837 Subp_Inputs => Subp_Inputs,
1838 Subp_Outputs => Subp_Outputs,
1839 Global_Seen => Global_Seen);
1841 -- Verify that every input or output of the subprogram appear in a
1844 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1845 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1846 Check_Function_Return;
1848 -- Dependency clauses appear as component associations of an aggregate
1850 elsif Nkind (Deps) = N_Aggregate then
1852 -- Do not attempt to perform analysis of a syntactically illegal
1853 -- clause as this will lead to misleading errors.
1855 if Has_Extra_Parentheses (Deps) then
1859 if Present (Component_Associations (Deps)) then
1860 Last_Clause := Last (Component_Associations (Deps));
1862 -- Gather all states, objects and formal parameters that the
1863 -- subprogram may depend on. These items are obtained from the
1864 -- parameter profile or pragma [Refined_]Global (if available).
1866 Collect_Subprogram_Inputs_Outputs
1867 (Subp_Id => Subp_Id,
1868 Subp_Inputs => Subp_Inputs,
1869 Subp_Outputs => Subp_Outputs,
1870 Global_Seen => Global_Seen);
1872 -- When pragma [Refined_]Depends appears on a single concurrent
1873 -- type, it is relocated to the anonymous object.
1875 if Is_Single_Concurrent_Object (Spec_Id) then
1878 -- Ensure that the formal parameters are visible when analyzing
1879 -- all clauses. This falls out of the general rule of aspects
1880 -- pertaining to subprogram declarations.
1882 elsif not In_Open_Scopes (Spec_Id) then
1883 Restore_Scope := True;
1884 Push_Scope (Spec_Id);
1886 if Ekind (Spec_Id) = E_Task_Type then
1887 if Has_Discriminants (Spec_Id) then
1888 Install_Discriminants (Spec_Id);
1891 elsif Is_Generic_Subprogram (Spec_Id) then
1892 Install_Generic_Formals (Spec_Id);
1895 Install_Formals (Spec_Id);
1899 Clause := First (Component_Associations (Deps));
1900 while Present (Clause) loop
1901 Errors := Serious_Errors_Detected;
1903 -- The normalization mechanism may create extra clauses that
1904 -- contain replicated input and output names. There is no need
1905 -- to reanalyze them.
1907 if not Analyzed (Clause) then
1908 Set_Analyzed (Clause);
1910 Analyze_Dependency_Clause
1912 Is_Last => Clause = Last_Clause);
1915 -- Do not normalize a clause if errors were detected (count
1916 -- of Serious_Errors has increased) because the inputs and/or
1917 -- outputs may denote illegal items. Normalization is disabled
1918 -- in ASIS mode as it alters the tree by introducing new nodes
1919 -- similar to expansion.
1921 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1922 Normalize_Clause (Clause);
1928 if Restore_Scope then
1932 -- Verify that every input or output of the subprogram appear in a
1935 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1936 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1937 Check_Function_Return;
1939 -- The dependency list is malformed. This is a syntax error, always
1943 Error_Msg_N ("malformed dependency relation", Deps);
1947 -- The top level dependency relation is malformed. This is a syntax
1948 -- error, always report.
1951 Error_Msg_N ("malformed dependency relation", Deps);
1955 -- Ensure that a state and a corresponding constituent do not appear
1956 -- together in pragma [Refined_]Depends.
1958 Check_State_And_Constituent_Use
1959 (States => States_Seen,
1960 Constits => Constits_Seen,
1964 Set_Is_Analyzed_Pragma (N);
1965 end Analyze_Depends_In_Decl_Part;
1967 --------------------------------------------
1968 -- Analyze_External_Property_In_Decl_Part --
1969 --------------------------------------------
1971 procedure Analyze_External_Property_In_Decl_Part
1973 Expr_Val : out Boolean)
1975 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1976 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1977 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1983 -- Do not analyze the pragma multiple times
1985 if Is_Analyzed_Pragma (N) then
1989 Error_Msg_Name_1 := Pragma_Name (N);
1991 -- An external property pragma must apply to an effectively volatile
1992 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1993 -- The check is performed at the end of the declarative region due to a
1994 -- possible out-of-order arrangement of pragmas:
1997 -- pragma Async_Readers (Obj);
1998 -- pragma Volatile (Obj);
2000 if not Is_Effectively_Volatile (Obj_Id) then
2002 ("external property % must apply to a volatile object", N);
2005 -- Ensure that the Boolean expression (if present) is static. A missing
2006 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2010 if Present (Arg1) then
2011 Expr := Get_Pragma_Arg (Arg1);
2013 if Is_OK_Static_Expression (Expr) then
2014 Expr_Val := Is_True (Expr_Value (Expr));
2018 Set_Is_Analyzed_Pragma (N);
2019 end Analyze_External_Property_In_Decl_Part;
2021 ---------------------------------
2022 -- Analyze_Global_In_Decl_Part --
2023 ---------------------------------
2025 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2026 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2027 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2028 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2030 Constits_Seen : Elist_Id := No_Elist;
2031 -- A list containing the entities of all constituents processed so far.
2032 -- It aids in detecting illegal usage of a state and a corresponding
2033 -- constituent in pragma [Refinde_]Global.
2035 Seen : Elist_Id := No_Elist;
2036 -- A list containing the entities of all the items processed so far. It
2037 -- plays a role in detecting distinct entities.
2039 States_Seen : Elist_Id := No_Elist;
2040 -- A list containing the entities of all states processed so far. It
2041 -- helps in detecting illegal usage of a state and a corresponding
2042 -- constituent in pragma [Refined_]Global.
2044 In_Out_Seen : Boolean := False;
2045 Input_Seen : Boolean := False;
2046 Output_Seen : Boolean := False;
2047 Proof_Seen : Boolean := False;
2048 -- Flags used to verify the consistency of modes
2050 procedure Analyze_Global_List
2052 Global_Mode : Name_Id := Name_Input);
2053 -- Verify the legality of a single global list declaration. Global_Mode
2054 -- denotes the current mode in effect.
2056 -------------------------
2057 -- Analyze_Global_List --
2058 -------------------------
2060 procedure Analyze_Global_List
2062 Global_Mode : Name_Id := Name_Input)
2064 procedure Analyze_Global_Item
2066 Global_Mode : Name_Id);
2067 -- Verify the legality of a single global item declaration denoted by
2068 -- Item. Global_Mode denotes the current mode in effect.
2070 procedure Check_Duplicate_Mode
2072 Status : in out Boolean);
2073 -- Flag Status denotes whether a particular mode has been seen while
2074 -- processing a global list. This routine verifies that Mode is not a
2075 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2077 procedure Check_Mode_Restriction_In_Enclosing_Context
2079 Item_Id : Entity_Id);
2080 -- Verify that an item of mode In_Out or Output does not appear as an
2081 -- input in the Global aspect of an enclosing subprogram. If this is
2082 -- the case, emit an error. Item and Item_Id are respectively the
2083 -- item and its entity.
2085 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2086 -- Mode denotes either In_Out or Output. Depending on the kind of the
2087 -- related subprogram, emit an error if those two modes apply to a
2088 -- function (SPARK RM 6.1.4(10)).
2090 -------------------------
2091 -- Analyze_Global_Item --
2092 -------------------------
2094 procedure Analyze_Global_Item
2096 Global_Mode : Name_Id)
2098 Item_Id : Entity_Id;
2101 -- Detect one of the following cases
2103 -- with Global => (null, Name)
2104 -- with Global => (Name_1, null, Name_2)
2105 -- with Global => (Name, null)
2107 if Nkind (Item) = N_Null then
2108 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2113 Resolve_State (Item);
2115 -- Find the entity of the item. If this is a renaming, climb the
2116 -- renaming chain to reach the root object. Renamings of non-
2117 -- entire objects do not yield an entity (Empty).
2119 Item_Id := Entity_Of (Item);
2121 if Present (Item_Id) then
2123 -- A global item may denote a formal parameter of an enclosing
2124 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2125 -- provide a better error diagnostic.
2127 if Is_Formal (Item_Id) then
2128 if Scope (Item_Id) = Spec_Id then
2130 (Fix_Msg (Spec_Id, "global item cannot reference "
2131 & "parameter of subprogram &"), Item, Spec_Id);
2135 -- A global item may denote a concurrent type as long as it is
2136 -- the current instance of an enclosing protected or task type
2137 -- (SPARK RM 6.1.4).
2139 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2140 if Is_CCT_Instance (Item_Id, Spec_Id) then
2142 -- Pragma [Refined_]Global associated with a protected
2143 -- subprogram cannot mention the current instance of a
2144 -- protected type because the instance behaves as a
2145 -- formal parameter.
2147 if Ekind (Item_Id) = E_Protected_Type then
2148 Error_Msg_Name_1 := Chars (Item_Id);
2150 (Fix_Msg (Spec_Id, "global item of subprogram & "
2151 & "cannot reference current instance of protected "
2152 & "type %"), Item, Spec_Id);
2155 -- Pragma [Refined_]Global associated with a task type
2156 -- cannot mention the current instance of a task type
2157 -- because the instance behaves as a formal parameter.
2159 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2160 Error_Msg_Name_1 := Chars (Item_Id);
2162 (Fix_Msg (Spec_Id, "global item of subprogram & "
2163 & "cannot reference current instance of task type "
2164 & "%"), Item, Spec_Id);
2168 -- Otherwise the global item denotes a subtype mark that is
2169 -- not a current instance.
2173 ("invalid use of subtype mark in global list", Item);
2177 -- A global item may denote the anonymous object created for a
2178 -- single protected/task type as long as the current instance
2179 -- is the same single type (SPARK RM 6.1.4).
2181 elsif Is_Single_Concurrent_Object (Item_Id)
2182 and then Is_CCT_Instance (Item_Id, Spec_Id)
2184 -- Pragma [Refined_]Global associated with a protected
2185 -- subprogram cannot mention the current instance of a
2186 -- protected type because the instance behaves as a formal
2189 if Is_Single_Protected_Object (Item_Id) then
2190 Error_Msg_Name_1 := Chars (Item_Id);
2192 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2193 & "reference current instance of protected type %"),
2197 -- Pragma [Refined_]Global associated with a task type
2198 -- cannot mention the current instance of a task type
2199 -- because the instance behaves as a formal parameter.
2201 else pragma Assert (Is_Single_Task_Object (Item_Id));
2202 Error_Msg_Name_1 := Chars (Item_Id);
2204 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2205 & "reference current instance of task type %"),
2210 -- A formal object may act as a global item inside a generic
2212 elsif Is_Formal_Object (Item_Id) then
2215 -- The only legal references are those to abstract states,
2216 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2218 elsif not Ekind_In (Item_Id, E_Abstract_State,
2224 ("global item must denote object, state or current "
2225 & "instance of concurrent type", Item);
2229 -- State related checks
2231 if Ekind (Item_Id) = E_Abstract_State then
2233 -- Package and subprogram bodies are instantiated
2234 -- individually in a separate compiler pass. Due to this
2235 -- mode of instantiation, the refinement of a state may
2236 -- no longer be visible when a subprogram body contract
2237 -- is instantiated. Since the generic template is legal,
2238 -- do not perform this check in the instance to circumvent
2241 if Is_Generic_Instance (Spec_Id) then
2244 -- An abstract state with visible refinement cannot appear
2245 -- in pragma [Refined_]Global as its place must be taken by
2246 -- some of its constituents (SPARK RM 6.1.4(7)).
2248 elsif Has_Visible_Refinement (Item_Id) then
2250 ("cannot mention state & in global refinement",
2252 SPARK_Msg_N ("\use its constituents instead", Item);
2255 -- An external state cannot appear as a global item of a
2256 -- nonvolatile function (SPARK RM 7.1.3(8)).
2258 elsif Is_External_State (Item_Id)
2259 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2260 and then not Is_Volatile_Function (Spec_Id)
2263 ("external state & cannot act as global item of "
2264 & "nonvolatile function", Item, Item_Id);
2267 -- If the reference to the abstract state appears in an
2268 -- enclosing package body that will eventually refine the
2269 -- state, record the reference for future checks.
2272 Record_Possible_Body_Reference
2273 (State_Id => Item_Id,
2277 -- Constant related checks
2279 elsif Ekind (Item_Id) = E_Constant then
2281 -- A constant is a read-only item, therefore it cannot act
2284 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2286 ("constant & cannot act as output", Item, Item_Id);
2290 -- Loop parameter related checks
2292 elsif Ekind (Item_Id) = E_Loop_Parameter then
2294 -- A loop parameter is a read-only item, therefore it cannot
2295 -- act as an output.
2297 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2299 ("loop parameter & cannot act as output",
2304 -- Variable related checks. These are only relevant when
2305 -- SPARK_Mode is on as they are not standard Ada legality
2308 elsif SPARK_Mode = On
2309 and then Ekind (Item_Id) = E_Variable
2310 and then Is_Effectively_Volatile (Item_Id)
2312 -- An effectively volatile object cannot appear as a global
2313 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2315 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2316 and then not Is_Volatile_Function (Spec_Id)
2319 ("volatile object & cannot act as global item of a "
2320 & "function", Item, Item_Id);
2323 -- An effectively volatile object with external property
2324 -- Effective_Reads set to True must have mode Output or
2325 -- In_Out (SPARK RM 7.1.3(10)).
2327 elsif Effective_Reads_Enabled (Item_Id)
2328 and then Global_Mode = Name_Input
2331 ("volatile object & with property Effective_Reads must "
2332 & "have mode In_Out or Output", Item, Item_Id);
2337 -- When the item renames an entire object, replace the item
2338 -- with a reference to the object.
2340 if Entity (Item) /= Item_Id then
2341 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2345 -- Some form of illegal construct masquerading as a name
2346 -- (SPARK RM 6.1.4(4)).
2350 ("global item must denote object, state or current instance "
2351 & "of concurrent type", Item);
2355 -- Verify that an output does not appear as an input in an
2356 -- enclosing subprogram.
2358 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2359 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2362 -- The same entity might be referenced through various way.
2363 -- Check the entity of the item rather than the item itself
2364 -- (SPARK RM 6.1.4(10)).
2366 if Contains (Seen, Item_Id) then
2367 SPARK_Msg_N ("duplicate global item", Item);
2369 -- Add the entity of the current item to the list of processed
2373 Append_New_Elmt (Item_Id, Seen);
2375 if Ekind (Item_Id) = E_Abstract_State then
2376 Append_New_Elmt (Item_Id, States_Seen);
2378 -- The variable may eventually become a constituent of a single
2379 -- protected/task type. Record the reference now and verify its
2380 -- legality when analyzing the contract of the variable
2383 elsif Ekind (Item_Id) = E_Variable then
2384 Record_Possible_Part_Of_Reference
2389 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2390 and then Present (Encapsulating_State (Item_Id))
2392 Append_New_Elmt (Item_Id, Constits_Seen);
2395 end Analyze_Global_Item;
2397 --------------------------
2398 -- Check_Duplicate_Mode --
2399 --------------------------
2401 procedure Check_Duplicate_Mode
2403 Status : in out Boolean)
2407 SPARK_Msg_N ("duplicate global mode", Mode);
2411 end Check_Duplicate_Mode;
2413 -------------------------------------------------
2414 -- Check_Mode_Restriction_In_Enclosing_Context --
2415 -------------------------------------------------
2417 procedure Check_Mode_Restriction_In_Enclosing_Context
2419 Item_Id : Entity_Id)
2421 Context : Entity_Id;
2423 Inputs : Elist_Id := No_Elist;
2424 Outputs : Elist_Id := No_Elist;
2427 -- Traverse the scope stack looking for enclosing subprograms
2428 -- subject to pragma [Refined_]Global.
2430 Context := Scope (Subp_Id);
2431 while Present (Context) and then Context /= Standard_Standard loop
2432 if Is_Subprogram (Context)
2434 (Present (Get_Pragma (Context, Pragma_Global))
2436 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2438 Collect_Subprogram_Inputs_Outputs
2439 (Subp_Id => Context,
2440 Subp_Inputs => Inputs,
2441 Subp_Outputs => Outputs,
2442 Global_Seen => Dummy);
2444 -- The item is classified as In_Out or Output but appears as
2445 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2447 if Appears_In (Inputs, Item_Id)
2448 and then not Appears_In (Outputs, Item_Id)
2451 ("global item & cannot have mode In_Out or Output",
2455 (Fix_Msg (Subp_Id, "\item already appears as input of "
2456 & "subprogram &"), Item, Context);
2458 -- Stop the traversal once an error has been detected
2464 Context := Scope (Context);
2466 end Check_Mode_Restriction_In_Enclosing_Context;
2468 ----------------------------------------
2469 -- Check_Mode_Restriction_In_Function --
2470 ----------------------------------------
2472 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2474 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2476 ("global mode & is not applicable to functions", Mode);
2478 end Check_Mode_Restriction_In_Function;
2486 -- Start of processing for Analyze_Global_List
2489 if Nkind (List) = N_Null then
2490 Set_Analyzed (List);
2492 -- Single global item declaration
2494 elsif Nkind_In (List, N_Expanded_Name,
2496 N_Selected_Component)
2498 Analyze_Global_Item (List, Global_Mode);
2500 -- Simple global list or moded global list declaration
2502 elsif Nkind (List) = N_Aggregate then
2503 Set_Analyzed (List);
2505 -- The declaration of a simple global list appear as a collection
2508 if Present (Expressions (List)) then
2509 if Present (Component_Associations (List)) then
2511 ("cannot mix moded and non-moded global lists", List);
2514 Item := First (Expressions (List));
2515 while Present (Item) loop
2516 Analyze_Global_Item (Item, Global_Mode);
2520 -- The declaration of a moded global list appears as a collection
2521 -- of component associations where individual choices denote
2524 elsif Present (Component_Associations (List)) then
2525 if Present (Expressions (List)) then
2527 ("cannot mix moded and non-moded global lists", List);
2530 Assoc := First (Component_Associations (List));
2531 while Present (Assoc) loop
2532 Mode := First (Choices (Assoc));
2534 if Nkind (Mode) = N_Identifier then
2535 if Chars (Mode) = Name_In_Out then
2536 Check_Duplicate_Mode (Mode, In_Out_Seen);
2537 Check_Mode_Restriction_In_Function (Mode);
2539 elsif Chars (Mode) = Name_Input then
2540 Check_Duplicate_Mode (Mode, Input_Seen);
2542 elsif Chars (Mode) = Name_Output then
2543 Check_Duplicate_Mode (Mode, Output_Seen);
2544 Check_Mode_Restriction_In_Function (Mode);
2546 elsif Chars (Mode) = Name_Proof_In then
2547 Check_Duplicate_Mode (Mode, Proof_Seen);
2550 SPARK_Msg_N ("invalid mode selector", Mode);
2554 SPARK_Msg_N ("invalid mode selector", Mode);
2557 -- Items in a moded list appear as a collection of
2558 -- expressions. Reuse the existing machinery to analyze
2562 (List => Expression (Assoc),
2563 Global_Mode => Chars (Mode));
2571 raise Program_Error;
2574 -- Any other attempt to declare a global item is illegal. This is a
2575 -- syntax error, always report.
2578 Error_Msg_N ("malformed global list", List);
2580 end Analyze_Global_List;
2584 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2586 Restore_Scope : Boolean := False;
2588 -- Start of processing for Analyze_Global_In_Decl_Part
2591 -- Do not analyze the pragma multiple times
2593 if Is_Analyzed_Pragma (N) then
2597 -- There is nothing to be done for a null global list
2599 if Nkind (Items) = N_Null then
2600 Set_Analyzed (Items);
2602 -- Analyze the various forms of global lists and items. Note that some
2603 -- of these may be malformed in which case the analysis emits error
2607 -- When pragma [Refined_]Global appears on a single concurrent type,
2608 -- it is relocated to the anonymous object.
2610 if Is_Single_Concurrent_Object (Spec_Id) then
2613 -- Ensure that the formal parameters are visible when processing an
2614 -- item. This falls out of the general rule of aspects pertaining to
2615 -- subprogram declarations.
2617 elsif not In_Open_Scopes (Spec_Id) then
2618 Restore_Scope := True;
2619 Push_Scope (Spec_Id);
2621 if Ekind (Spec_Id) = E_Task_Type then
2622 if Has_Discriminants (Spec_Id) then
2623 Install_Discriminants (Spec_Id);
2626 elsif Is_Generic_Subprogram (Spec_Id) then
2627 Install_Generic_Formals (Spec_Id);
2630 Install_Formals (Spec_Id);
2634 Analyze_Global_List (Items);
2636 if Restore_Scope then
2641 -- Ensure that a state and a corresponding constituent do not appear
2642 -- together in pragma [Refined_]Global.
2644 Check_State_And_Constituent_Use
2645 (States => States_Seen,
2646 Constits => Constits_Seen,
2649 Set_Is_Analyzed_Pragma (N);
2650 end Analyze_Global_In_Decl_Part;
2652 --------------------------------------------
2653 -- Analyze_Initial_Condition_In_Decl_Part --
2654 --------------------------------------------
2656 -- WARNING: This routine manages Ghost regions. Return statements must be
2657 -- replaced by gotos which jump to the end of the routine and restore the
2660 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2661 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2662 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2663 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2665 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2666 -- Save the Ghost mode to restore on exit
2669 -- Do not analyze the pragma multiple times
2671 if Is_Analyzed_Pragma (N) then
2675 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2676 -- analysis of the pragma, the Ghost mode at point of declaration and
2677 -- point of analysis may not necessarily be the same. Use the mode in
2678 -- effect at the point of declaration.
2682 -- The expression is preanalyzed because it has not been moved to its
2683 -- final place yet. A direct analysis may generate side effects and this
2684 -- is not desired at this point.
2686 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2687 Set_Is_Analyzed_Pragma (N);
2689 Restore_Ghost_Mode (Saved_GM);
2690 end Analyze_Initial_Condition_In_Decl_Part;
2692 --------------------------------------
2693 -- Analyze_Initializes_In_Decl_Part --
2694 --------------------------------------
2696 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2697 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2698 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2700 Constits_Seen : Elist_Id := No_Elist;
2701 -- A list containing the entities of all constituents processed so far.
2702 -- It aids in detecting illegal usage of a state and a corresponding
2703 -- constituent in pragma Initializes.
2705 Items_Seen : Elist_Id := No_Elist;
2706 -- A list of all initialization items processed so far. This list is
2707 -- used to detect duplicate items.
2709 Non_Null_Seen : Boolean := False;
2710 Null_Seen : Boolean := False;
2711 -- Flags used to check the legality of a null initialization list
2713 States_And_Objs : Elist_Id := No_Elist;
2714 -- A list of all abstract states and objects declared in the visible
2715 -- declarations of the related package. This list is used to detect the
2716 -- legality of initialization items.
2718 States_Seen : Elist_Id := No_Elist;
2719 -- A list containing the entities of all states processed so far. It
2720 -- helps in detecting illegal usage of a state and a corresponding
2721 -- constituent in pragma Initializes.
2723 procedure Analyze_Initialization_Item (Item : Node_Id);
2724 -- Verify the legality of a single initialization item
2726 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2727 -- Verify the legality of a single initialization item followed by a
2728 -- list of input items.
2730 procedure Collect_States_And_Objects;
2731 -- Inspect the visible declarations of the related package and gather
2732 -- the entities of all abstract states and objects in States_And_Objs.
2734 ---------------------------------
2735 -- Analyze_Initialization_Item --
2736 ---------------------------------
2738 procedure Analyze_Initialization_Item (Item : Node_Id) is
2739 Item_Id : Entity_Id;
2742 -- Null initialization list
2744 if Nkind (Item) = N_Null then
2746 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2748 elsif Non_Null_Seen then
2750 ("cannot mix null and non-null initialization items", Item);
2755 -- Initialization item
2758 Non_Null_Seen := True;
2762 ("cannot mix null and non-null initialization items", Item);
2766 Resolve_State (Item);
2768 if Is_Entity_Name (Item) then
2769 Item_Id := Entity_Of (Item);
2771 if Ekind_In (Item_Id, E_Abstract_State,
2775 -- The state or variable must be declared in the visible
2776 -- declarations of the package (SPARK RM 7.1.5(7)).
2778 if not Contains (States_And_Objs, Item_Id) then
2779 Error_Msg_Name_1 := Chars (Pack_Id);
2781 ("initialization item & must appear in the visible "
2782 & "declarations of package %", Item, Item_Id);
2784 -- Detect a duplicate use of the same initialization item
2785 -- (SPARK RM 7.1.5(5)).
2787 elsif Contains (Items_Seen, Item_Id) then
2788 SPARK_Msg_N ("duplicate initialization item", Item);
2790 -- The item is legal, add it to the list of processed states
2794 Append_New_Elmt (Item_Id, Items_Seen);
2796 if Ekind (Item_Id) = E_Abstract_State then
2797 Append_New_Elmt (Item_Id, States_Seen);
2800 if Present (Encapsulating_State (Item_Id)) then
2801 Append_New_Elmt (Item_Id, Constits_Seen);
2805 -- The item references something that is not a state or object
2806 -- (SPARK RM 7.1.5(3)).
2810 ("initialization item must denote object or state", Item);
2813 -- Some form of illegal construct masquerading as a name
2814 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2818 ("initialization item must denote object or state", Item);
2821 end Analyze_Initialization_Item;
2823 ---------------------------------------------
2824 -- Analyze_Initialization_Item_With_Inputs --
2825 ---------------------------------------------
2827 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2828 Inputs_Seen : Elist_Id := No_Elist;
2829 -- A list of all inputs processed so far. This list is used to detect
2830 -- duplicate uses of an input.
2832 Non_Null_Seen : Boolean := False;
2833 Null_Seen : Boolean := False;
2834 -- Flags used to check the legality of an input list
2836 procedure Analyze_Input_Item (Input : Node_Id);
2837 -- Verify the legality of a single input item
2839 ------------------------
2840 -- Analyze_Input_Item --
2841 ------------------------
2843 procedure Analyze_Input_Item (Input : Node_Id) is
2844 Input_Id : Entity_Id;
2845 Input_OK : Boolean := True;
2850 if Nkind (Input) = N_Null then
2853 ("multiple null initializations not allowed", Item);
2855 elsif Non_Null_Seen then
2857 ("cannot mix null and non-null initialization item", Item);
2865 Non_Null_Seen := True;
2869 ("cannot mix null and non-null initialization item", Item);
2873 Resolve_State (Input);
2875 if Is_Entity_Name (Input) then
2876 Input_Id := Entity_Of (Input);
2878 if Ekind_In (Input_Id, E_Abstract_State,
2880 E_Generic_In_Out_Parameter,
2881 E_Generic_In_Parameter,
2887 -- The input cannot denote states or objects declared
2888 -- within the related package (SPARK RM 7.1.5(4)).
2890 if Within_Scope (Input_Id, Current_Scope) then
2892 -- Do not consider generic formal parameters or their
2893 -- respective mappings to generic formals. Even though
2894 -- the formals appear within the scope of the package,
2895 -- it is allowed for an initialization item to depend
2896 -- on an input item.
2898 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2899 E_Generic_In_Parameter)
2903 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2904 and then Present (Corresponding_Generic_Association
2905 (Declaration_Node (Input_Id)))
2911 Error_Msg_Name_1 := Chars (Pack_Id);
2913 ("input item & cannot denote a visible object or "
2914 & "state of package %", Input, Input_Id);
2918 -- Detect a duplicate use of the same input item
2919 -- (SPARK RM 7.1.5(5)).
2921 if Contains (Inputs_Seen, Input_Id) then
2923 SPARK_Msg_N ("duplicate input item", Input);
2926 -- Input is legal, add it to the list of processed inputs
2929 Append_New_Elmt (Input_Id, Inputs_Seen);
2931 if Ekind (Input_Id) = E_Abstract_State then
2932 Append_New_Elmt (Input_Id, States_Seen);
2935 if Ekind_In (Input_Id, E_Abstract_State,
2938 and then Present (Encapsulating_State (Input_Id))
2940 Append_New_Elmt (Input_Id, Constits_Seen);
2944 -- The input references something that is not a state or an
2945 -- object (SPARK RM 7.1.5(3)).
2949 ("input item must denote object or state", Input);
2952 -- Some form of illegal construct masquerading as a name
2953 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2957 ("input item must denote object or state", Input);
2960 end Analyze_Input_Item;
2964 Inputs : constant Node_Id := Expression (Item);
2968 Name_Seen : Boolean := False;
2969 -- A flag used to detect multiple item names
2971 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2974 -- Inspect the name of an item with inputs
2976 Elmt := First (Choices (Item));
2977 while Present (Elmt) loop
2979 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2982 Analyze_Initialization_Item (Elmt);
2988 -- Multiple input items appear as an aggregate
2990 if Nkind (Inputs) = N_Aggregate then
2991 if Present (Expressions (Inputs)) then
2992 Input := First (Expressions (Inputs));
2993 while Present (Input) loop
2994 Analyze_Input_Item (Input);
2999 if Present (Component_Associations (Inputs)) then
3001 ("inputs must appear in named association form", Inputs);
3004 -- Single input item
3007 Analyze_Input_Item (Inputs);
3009 end Analyze_Initialization_Item_With_Inputs;
3011 --------------------------------
3012 -- Collect_States_And_Objects --
3013 --------------------------------
3015 procedure Collect_States_And_Objects is
3016 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3020 -- Collect the abstract states defined in the package (if any)
3022 if Present (Abstract_States (Pack_Id)) then
3023 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3026 -- Collect all objects the appear in the visible declarations of the
3029 if Present (Visible_Declarations (Pack_Spec)) then
3030 Decl := First (Visible_Declarations (Pack_Spec));
3031 while Present (Decl) loop
3032 if Comes_From_Source (Decl)
3033 and then Nkind (Decl) = N_Object_Declaration
3035 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3041 end Collect_States_And_Objects;
3045 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3048 -- Start of processing for Analyze_Initializes_In_Decl_Part
3051 -- Do not analyze the pragma multiple times
3053 if Is_Analyzed_Pragma (N) then
3057 -- Nothing to do when the initialization list is empty
3059 if Nkind (Inits) = N_Null then
3063 -- Single and multiple initialization clauses appear as an aggregate. If
3064 -- this is not the case, then either the parser or the analysis of the
3065 -- pragma failed to produce an aggregate.
3067 pragma Assert (Nkind (Inits) = N_Aggregate);
3069 -- Initialize the various lists used during analysis
3071 Collect_States_And_Objects;
3073 if Present (Expressions (Inits)) then
3074 Init := First (Expressions (Inits));
3075 while Present (Init) loop
3076 Analyze_Initialization_Item (Init);
3081 if Present (Component_Associations (Inits)) then
3082 Init := First (Component_Associations (Inits));
3083 while Present (Init) loop
3084 Analyze_Initialization_Item_With_Inputs (Init);
3089 -- Ensure that a state and a corresponding constituent do not appear
3090 -- together in pragma Initializes.
3092 Check_State_And_Constituent_Use
3093 (States => States_Seen,
3094 Constits => Constits_Seen,
3097 Set_Is_Analyzed_Pragma (N);
3098 end Analyze_Initializes_In_Decl_Part;
3100 ---------------------
3101 -- Analyze_Part_Of --
3102 ---------------------
3104 procedure Analyze_Part_Of
3106 Item_Id : Entity_Id;
3108 Encap_Id : out Entity_Id;
3109 Legal : out Boolean)
3111 Encap_Typ : Entity_Id;
3112 Item_Decl : Node_Id;
3113 Pack_Id : Entity_Id;
3114 Placement : State_Space_Kind;
3115 Parent_Unit : Entity_Id;
3118 -- Assume that the indicator is illegal
3123 if Nkind_In (Encap, N_Expanded_Name,
3125 N_Selected_Component)
3128 Resolve_State (Encap);
3130 Encap_Id := Entity (Encap);
3132 -- The encapsulator is an abstract state
3134 if Ekind (Encap_Id) = E_Abstract_State then
3137 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3139 elsif Is_Single_Concurrent_Object (Encap_Id) then
3142 -- Otherwise the encapsulator is not a legal choice
3146 ("indicator Part_Of must denote abstract state, single "
3147 & "protected type or single task type", Encap);
3151 -- This is a syntax error, always report
3155 ("indicator Part_Of must denote abstract state, single protected "
3156 & "type or single task type", Encap);
3160 -- Catch a case where indicator Part_Of denotes the abstract view of a
3161 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3163 if From_Limited_With (Encap_Id)
3164 and then Present (Non_Limited_View (Encap_Id))
3165 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3167 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3168 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3172 -- The encapsulator is an abstract state
3174 if Ekind (Encap_Id) = E_Abstract_State then
3176 -- Determine where the object, package instantiation or state lives
3177 -- with respect to the enclosing packages or package bodies.
3179 Find_Placement_In_State_Space
3180 (Item_Id => Item_Id,
3181 Placement => Placement,
3182 Pack_Id => Pack_Id);
3184 -- The item appears in a non-package construct with a declarative
3185 -- part (subprogram, block, etc). As such, the item is not allowed
3186 -- to be a part of an encapsulating state because the item is not
3189 if Placement = Not_In_Package then
3191 ("indicator Part_Of cannot appear in this context "
3192 & "(SPARK RM 7.2.6(5))", Indic);
3193 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3195 ("\& is not part of the hidden state of package %",
3198 -- The item appears in the visible state space of some package. In
3199 -- general this scenario does not warrant Part_Of except when the
3200 -- package is a private child unit and the encapsulating state is
3201 -- declared in a parent unit or a public descendant of that parent
3204 elsif Placement = Visible_State_Space then
3205 if Is_Child_Unit (Pack_Id)
3206 and then Is_Private_Descendant (Pack_Id)
3208 -- A variable or state abstraction which is part of the visible
3209 -- state of a private child unit (or one of its public
3210 -- descendants) must have its Part_Of indicator specified. The
3211 -- Part_Of indicator must denote a state abstraction declared
3212 -- by either the parent unit of the private unit or by a public
3213 -- descendant of that parent unit.
3215 -- Find nearest private ancestor (which can be the current unit
3218 Parent_Unit := Pack_Id;
3219 while Present (Parent_Unit) loop
3222 (Parent (Unit_Declaration_Node (Parent_Unit)));
3223 Parent_Unit := Scope (Parent_Unit);
3226 Parent_Unit := Scope (Parent_Unit);
3228 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3230 ("indicator Part_Of must denote abstract state or public "
3231 & "descendant of & (SPARK RM 7.2.6(3))",
3232 Indic, Parent_Unit);
3234 elsif Scope (Encap_Id) = Parent_Unit
3236 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3237 and then not Is_Private_Descendant (Scope (Encap_Id)))
3243 ("indicator Part_Of must denote abstract state or public "
3244 & "descendant of & (SPARK RM 7.2.6(3))",
3245 Indic, Parent_Unit);
3248 -- Indicator Part_Of is not needed when the related package is not
3249 -- a private child unit or a public descendant thereof.
3253 ("indicator Part_Of cannot appear in this context "
3254 & "(SPARK RM 7.2.6(5))", Indic);
3255 Error_Msg_Name_1 := Chars (Pack_Id);
3257 ("\& is declared in the visible part of package %",
3261 -- When the item appears in the private state space of a package, the
3262 -- encapsulating state must be declared in the same package.
3264 elsif Placement = Private_State_Space then
3265 if Scope (Encap_Id) /= Pack_Id then
3267 ("indicator Part_Of must designate an abstract state of "
3268 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3269 Error_Msg_Name_1 := Chars (Pack_Id);
3271 ("\& is declared in the private part of package %",
3275 -- Items declared in the body state space of a package do not need
3276 -- Part_Of indicators as the refinement has already been seen.
3280 ("indicator Part_Of cannot appear in this context "
3281 & "(SPARK RM 7.2.6(5))", Indic);
3283 if Scope (Encap_Id) = Pack_Id then
3284 Error_Msg_Name_1 := Chars (Pack_Id);
3286 ("\& is declared in the body of package %", Indic, Item_Id);
3290 -- The encapsulator is a single concurrent type
3293 Encap_Typ := Etype (Encap_Id);
3295 -- Only abstract states and variables can act as constituents of an
3296 -- encapsulating single concurrent type.
3298 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3301 -- The constituent is a constant
3303 elsif Ekind (Item_Id) = E_Constant then
3304 Error_Msg_Name_1 := Chars (Encap_Id);
3306 (Fix_Msg (Encap_Typ, "constant & cannot act as constituent of "
3307 & "single protected type %"), Indic, Item_Id);
3309 -- The constituent is a package instantiation
3312 Error_Msg_Name_1 := Chars (Encap_Id);
3314 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3315 & "constituent of single protected type %"), Indic, Item_Id);
3318 -- When the item denotes an abstract state of a nested package, use
3319 -- the declaration of the package to detect proper placement.
3324 -- with Abstract_State => (State with Part_Of => T)
3326 if Ekind (Item_Id) = E_Abstract_State then
3327 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3329 Item_Decl := Declaration_Node (Item_Id);
3332 -- Both the item and its encapsulating single concurrent type must
3333 -- appear in the same declarative region (SPARK RM 9.3). Note that
3334 -- privacy is ignored.
3336 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3337 Error_Msg_Name_1 := Chars (Encap_Id);
3339 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3340 & "immediately within the same region as single protected "
3341 & "type %"), Indic, Item_Id);
3346 end Analyze_Part_Of;
3348 ----------------------------------
3349 -- Analyze_Part_Of_In_Decl_Part --
3350 ----------------------------------
3352 procedure Analyze_Part_Of_In_Decl_Part
3354 Freeze_Id : Entity_Id := Empty)
3356 Encap : constant Node_Id :=
3357 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3358 Errors : constant Nat := Serious_Errors_Detected;
3359 Var_Decl : constant Node_Id := Find_Related_Context (N);
3360 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3361 Constits : Elist_Id;
3362 Encap_Id : Entity_Id;
3366 -- Detect any discrepancies between the placement of the variable with
3367 -- respect to general state space and the encapsulating state or single
3374 Encap_Id => Encap_Id,
3377 -- The Part_Of indicator turns the variable into a constituent of the
3378 -- encapsulating state or single concurrent type.
3381 pragma Assert (Present (Encap_Id));
3382 Constits := Part_Of_Constituents (Encap_Id);
3384 if No (Constits) then
3385 Constits := New_Elmt_List;
3386 Set_Part_Of_Constituents (Encap_Id, Constits);
3389 Append_Elmt (Var_Id, Constits);
3390 Set_Encapsulating_State (Var_Id, Encap_Id);
3392 -- A Part_Of constituent partially refines an abstract state. This
3393 -- property does not apply to protected or task units.
3395 if Ekind (Encap_Id) = E_Abstract_State then
3396 Set_Has_Partial_Visible_Refinement (Encap_Id);
3400 -- Emit a clarification message when the encapsulator is undefined,
3401 -- possibly due to contract "freezing".
3403 if Errors /= Serious_Errors_Detected
3404 and then Present (Freeze_Id)
3405 and then Has_Undefined_Reference (Encap)
3407 Contract_Freeze_Error (Var_Id, Freeze_Id);
3409 end Analyze_Part_Of_In_Decl_Part;
3411 --------------------
3412 -- Analyze_Pragma --
3413 --------------------
3415 procedure Analyze_Pragma (N : Node_Id) is
3416 Loc : constant Source_Ptr := Sloc (N);
3418 Pname : Name_Id := Pragma_Name (N);
3419 -- Name of the source pragma, or name of the corresponding aspect for
3420 -- pragmas which originate in a source aspect. In the latter case, the
3421 -- name may be different from the pragma name.
3423 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3425 Pragma_Exit : exception;
3426 -- This exception is used to exit pragma processing completely. It
3427 -- is used when an error is detected, and no further processing is
3428 -- required. It is also used if an earlier error has left the tree in
3429 -- a state where the pragma should not be processed.
3432 -- Number of pragma argument associations
3438 -- First four pragma arguments (pragma argument association nodes, or
3439 -- Empty if the corresponding argument does not exist).
3441 type Name_List is array (Natural range <>) of Name_Id;
3442 type Args_List is array (Natural range <>) of Node_Id;
3443 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3445 -----------------------
3446 -- Local Subprograms --
3447 -----------------------
3449 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3450 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3451 -- get the given string argument, and place it in Name_Buffer, adding
3452 -- leading and trailing asterisks if they are not already present. The
3453 -- caller has already checked that Arg is a static string expression.
3455 procedure Ada_2005_Pragma;
3456 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3457 -- Ada 95 mode, these are implementation defined pragmas, so should be
3458 -- caught by the No_Implementation_Pragmas restriction.
3460 procedure Ada_2012_Pragma;
3461 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3462 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3463 -- should be caught by the No_Implementation_Pragmas restriction.
3465 procedure Analyze_Depends_Global
3466 (Spec_Id : out Entity_Id;
3467 Subp_Decl : out Node_Id;
3468 Legal : out Boolean);
3469 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3470 -- legality of the placement and related context of the pragma. Spec_Id
3471 -- is the entity of the related subprogram. Subp_Decl is the declaration
3472 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3474 procedure Analyze_If_Present (Id : Pragma_Id);
3475 -- Inspect the remainder of the list containing pragma N and look for
3476 -- a pragma that matches Id. If found, analyze the pragma.
3478 procedure Analyze_Pre_Post_Condition;
3479 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3481 procedure Analyze_Refined_Depends_Global_Post
3482 (Spec_Id : out Entity_Id;
3483 Body_Id : out Entity_Id;
3484 Legal : out Boolean);
3485 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3486 -- Refined_Global and Refined_Post. Verify the legality of the placement
3487 -- and related context of the pragma. Spec_Id is the entity of the
3488 -- related subprogram. Body_Id is the entity of the subprogram body.
3489 -- Flag Legal is set when the pragma is legal.
3491 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3492 -- Perform full analysis of pragma Unmodified and the write aspect of
3493 -- pragma Unused. Flag Is_Unused should be set when verifying the
3494 -- semantics of pragma Unused.
3496 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3497 -- Perform full analysis of pragma Unreferenced and the read aspect of
3498 -- pragma Unused. Flag Is_Unused should be set when verifying the
3499 -- semantics of pragma Unused.
3501 procedure Check_Ada_83_Warning;
3502 -- Issues a warning message for the current pragma if operating in Ada
3503 -- 83 mode (used for language pragmas that are not a standard part of
3504 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3507 procedure Check_Arg_Count (Required : Nat);
3508 -- Check argument count for pragma is equal to given parameter. If not,
3509 -- then issue an error message and raise Pragma_Exit.
3511 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3512 -- Arg which can either be a pragma argument association, in which case
3513 -- the check is applied to the expression of the association or an
3514 -- expression directly.
3516 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3517 -- Check that an argument has the right form for an EXTERNAL_NAME
3518 -- parameter of an extended import/export pragma. The rule is that the
3519 -- name must be an identifier or string literal (in Ada 83 mode) or a
3520 -- static string expression (in Ada 95 mode).
3522 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3523 -- Check the specified argument Arg to make sure that it is an
3524 -- identifier. If not give error and raise Pragma_Exit.
3526 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3527 -- Check the specified argument Arg to make sure that it is an integer
3528 -- literal. If not give error and raise Pragma_Exit.
3530 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3531 -- Check the specified argument Arg to make sure that it has the proper
3532 -- syntactic form for a local name and meets the semantic requirements
3533 -- for a local name. The local name is analyzed as part of the
3534 -- processing for this call. In addition, the local name is required
3535 -- to represent an entity at the library level.
3537 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3538 -- Check the specified argument Arg to make sure that it has the proper
3539 -- syntactic form for a local name and meets the semantic requirements
3540 -- for a local name. The local name is analyzed as part of the
3541 -- processing for this call.
3543 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3544 -- Check the specified argument Arg to make sure that it is a valid
3545 -- locking policy name. If not give error and raise Pragma_Exit.
3547 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3548 -- Check the specified argument Arg to make sure that it is a valid
3549 -- elaboration policy name. If not give error and raise Pragma_Exit.
3551 procedure Check_Arg_Is_One_Of
3554 procedure Check_Arg_Is_One_Of
3556 N1, N2, N3 : Name_Id);
3557 procedure Check_Arg_Is_One_Of
3559 N1, N2, N3, N4 : Name_Id);
3560 procedure Check_Arg_Is_One_Of
3562 N1, N2, N3, N4, N5 : Name_Id);
3563 -- Check the specified argument Arg to make sure that it is an
3564 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3565 -- present). If not then give error and raise Pragma_Exit.
3567 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3568 -- Check the specified argument Arg to make sure that it is a valid
3569 -- queuing policy name. If not give error and raise Pragma_Exit.
3571 procedure Check_Arg_Is_OK_Static_Expression
3573 Typ : Entity_Id := Empty);
3574 -- Check the specified argument Arg to make sure that it is a static
3575 -- expression of the given type (i.e. it will be analyzed and resolved
3576 -- using this type, which can be any valid argument to Resolve, e.g.
3577 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3578 -- Typ is left Empty, then any static expression is allowed. Includes
3579 -- checking that the argument does not raise Constraint_Error.
3581 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3582 -- Check the specified argument Arg to make sure that it is a valid task
3583 -- dispatching policy name. If not give error and raise Pragma_Exit.
3585 procedure Check_Arg_Order (Names : Name_List);
3586 -- Checks for an instance of two arguments with identifiers for the
3587 -- current pragma which are not in the sequence indicated by Names,
3588 -- and if so, generates a fatal message about bad order of arguments.
3590 procedure Check_At_Least_N_Arguments (N : Nat);
3591 -- Check there are at least N arguments present
3593 procedure Check_At_Most_N_Arguments (N : Nat);
3594 -- Check there are no more than N arguments present
3596 procedure Check_Component
3599 In_Variant_Part : Boolean := False);
3600 -- Examine an Unchecked_Union component for correct use of per-object
3601 -- constrained subtypes, and for restrictions on finalizable components.
3602 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3603 -- should be set when Comp comes from a record variant.
3605 procedure Check_Duplicate_Pragma (E : Entity_Id);
3606 -- Check if a rep item of the same name as the current pragma is already
3607 -- chained as a rep pragma to the given entity. If so give a message
3608 -- about the duplicate, and then raise Pragma_Exit so does not return.
3609 -- Note that if E is a type, then this routine avoids flagging a pragma
3610 -- which applies to a parent type from which E is derived.
3612 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3613 -- Nam is an N_String_Literal node containing the external name set by
3614 -- an Import or Export pragma (or extended Import or Export pragma).
3615 -- This procedure checks for possible duplications if this is the export
3616 -- case, and if found, issues an appropriate error message.
3618 procedure Check_Expr_Is_OK_Static_Expression
3620 Typ : Entity_Id := Empty);
3621 -- Check the specified expression Expr to make sure that it is a static
3622 -- expression of the given type (i.e. it will be analyzed and resolved
3623 -- using this type, which can be any valid argument to Resolve, e.g.
3624 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3625 -- Typ is left Empty, then any static expression is allowed. Includes
3626 -- checking that the expression does not raise Constraint_Error.
3628 procedure Check_First_Subtype (Arg : Node_Id);
3629 -- Checks that Arg, whose expression is an entity name, references a
3632 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3633 -- Checks that the given argument has an identifier, and if so, requires
3634 -- it to match the given identifier name. If there is no identifier, or
3635 -- a non-matching identifier, then an error message is given and
3636 -- Pragma_Exit is raised.
3638 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3639 -- Checks that the given argument has an identifier, and if so, requires
3640 -- it to match one of the given identifier names. If there is no
3641 -- identifier, or a non-matching identifier, then an error message is
3642 -- given and Pragma_Exit is raised.
3644 procedure Check_In_Main_Program;
3645 -- Common checks for pragmas that appear within a main program
3646 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3648 procedure Check_Interrupt_Or_Attach_Handler;
3649 -- Common processing for first argument of pragma Interrupt_Handler or
3650 -- pragma Attach_Handler.
3652 procedure Check_Loop_Pragma_Placement;
3653 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3654 -- appear immediately within a construct restricted to loops, and that
3655 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3657 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3658 -- Check that pragma appears in a declarative part, or in a package
3659 -- specification, i.e. that it does not occur in a statement sequence
3662 procedure Check_No_Identifier (Arg : Node_Id);
3663 -- Checks that the given argument does not have an identifier. If
3664 -- an identifier is present, then an error message is issued, and
3665 -- Pragma_Exit is raised.
3667 procedure Check_No_Identifiers;
3668 -- Checks that none of the arguments to the pragma has an identifier.
3669 -- If any argument has an identifier, then an error message is issued,
3670 -- and Pragma_Exit is raised.
3672 procedure Check_No_Link_Name;
3673 -- Checks that no link name is specified
3675 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3676 -- Checks if the given argument has an identifier, and if so, requires
3677 -- it to match the given identifier name. If there is a non-matching
3678 -- identifier, then an error message is given and Pragma_Exit is raised.
3680 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3681 -- Checks if the given argument has an identifier, and if so, requires
3682 -- it to match the given identifier name. If there is a non-matching
3683 -- identifier, then an error message is given and Pragma_Exit is raised.
3684 -- In this version of the procedure, the identifier name is given as
3685 -- a string with lower case letters.
3687 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3688 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3689 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3690 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3691 -- is an OK static boolean expression. Emit an error if this is not the
3694 procedure Check_Static_Constraint (Constr : Node_Id);
3695 -- Constr is a constraint from an N_Subtype_Indication node from a
3696 -- component constraint in an Unchecked_Union type. This routine checks
3697 -- that the constraint is static as required by the restrictions for
3700 procedure Check_Valid_Configuration_Pragma;
3701 -- Legality checks for placement of a configuration pragma
3703 procedure Check_Valid_Library_Unit_Pragma;
3704 -- Legality checks for library unit pragmas. A special case arises for
3705 -- pragmas in generic instances that come from copies of the original
3706 -- library unit pragmas in the generic templates. In the case of other
3707 -- than library level instantiations these can appear in contexts which
3708 -- would normally be invalid (they only apply to the original template
3709 -- and to library level instantiations), and they are simply ignored,
3710 -- which is implemented by rewriting them as null statements.
3712 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3713 -- Check an Unchecked_Union variant for lack of nested variants and
3714 -- presence of at least one component. UU_Typ is the related Unchecked_
3717 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3718 -- Subsidiary routine to the processing of pragmas Abstract_State,
3719 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3720 -- Refined_Global and Refined_State. Transform argument Arg into
3721 -- an aggregate if not one already. N_Null is never transformed.
3722 -- Arg may denote an aspect specification or a pragma argument
3725 procedure Error_Pragma (Msg : String);
3726 pragma No_Return (Error_Pragma);
3727 -- Outputs error message for current pragma. The message contains a %
3728 -- that will be replaced with the pragma name, and the flag is placed
3729 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3730 -- calls Fix_Error (see spec of that procedure for details).
3732 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3733 pragma No_Return (Error_Pragma_Arg);
3734 -- Outputs error message for current pragma. The message may contain
3735 -- a % that will be replaced with the pragma name. The parameter Arg
3736 -- may either be a pragma argument association, in which case the flag
3737 -- is placed on the expression of this association, or an expression,
3738 -- in which case the flag is placed directly on the expression. The
3739 -- message is placed using Error_Msg_N, so the message may also contain
3740 -- an & insertion character which will reference the given Arg value.
3741 -- After placing the message, Pragma_Exit is raised. Note: this routine
3742 -- calls Fix_Error (see spec of that procedure for details).
3744 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3745 pragma No_Return (Error_Pragma_Arg);
3746 -- Similar to above form of Error_Pragma_Arg except that two messages
3747 -- are provided, the second is a continuation comment starting with \.
3749 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3750 pragma No_Return (Error_Pragma_Arg_Ident);
3751 -- Outputs error message for current pragma. The message may contain a %
3752 -- that will be replaced with the pragma name. The parameter Arg must be
3753 -- a pragma argument association with a non-empty identifier (i.e. its
3754 -- Chars field must be set), and the error message is placed on the
3755 -- identifier. The message is placed using Error_Msg_N so the message
3756 -- may also contain an & insertion character which will reference
3757 -- the identifier. After placing the message, Pragma_Exit is raised.
3758 -- Note: this routine calls Fix_Error (see spec of that procedure for
3761 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3762 pragma No_Return (Error_Pragma_Ref);
3763 -- Outputs error message for current pragma. The message may contain
3764 -- a % that will be replaced with the pragma name. The parameter Ref
3765 -- must be an entity whose name can be referenced by & and sloc by #.
3766 -- After placing the message, Pragma_Exit is raised. Note: this routine
3767 -- calls Fix_Error (see spec of that procedure for details).
3769 function Find_Lib_Unit_Name return Entity_Id;
3770 -- Used for a library unit pragma to find the entity to which the
3771 -- library unit pragma applies, returns the entity found.
3773 procedure Find_Program_Unit_Name (Id : Node_Id);
3774 -- If the pragma is a compilation unit pragma, the id must denote the
3775 -- compilation unit in the same compilation, and the pragma must appear
3776 -- in the list of preceding or trailing pragmas. If it is a program
3777 -- unit pragma that is not a compilation unit pragma, then the
3778 -- identifier must be visible.
3780 function Find_Unique_Parameterless_Procedure
3782 Arg : Node_Id) return Entity_Id;
3783 -- Used for a procedure pragma to find the unique parameterless
3784 -- procedure identified by Name, returns it if it exists, otherwise
3785 -- errors out and uses Arg as the pragma argument for the message.
3787 function Fix_Error (Msg : String) return String;
3788 -- This is called prior to issuing an error message. Msg is the normal
3789 -- error message issued in the pragma case. This routine checks for the
3790 -- case of a pragma coming from an aspect in the source, and returns a
3791 -- message suitable for the aspect case as follows:
3793 -- Each substring "pragma" is replaced by "aspect"
3795 -- If "argument of" is at the start of the error message text, it is
3796 -- replaced by "entity for".
3798 -- If "argument" is at the start of the error message text, it is
3799 -- replaced by "entity".
3801 -- So for example, "argument of pragma X must be discrete type"
3802 -- returns "entity for aspect X must be a discrete type".
3804 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3805 -- be different from the pragma name). If the current pragma results
3806 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3807 -- original pragma name.
3809 procedure Gather_Associations
3811 Args : out Args_List);
3812 -- This procedure is used to gather the arguments for a pragma that
3813 -- permits arbitrary ordering of parameters using the normal rules
3814 -- for named and positional parameters. The Names argument is a list
3815 -- of Name_Id values that corresponds to the allowed pragma argument
3816 -- association identifiers in order. The result returned in Args is
3817 -- a list of corresponding expressions that are the pragma arguments.
3818 -- Note that this is a list of expressions, not of pragma argument
3819 -- associations (Gather_Associations has completely checked all the
3820 -- optional identifiers when it returns). An entry in Args is Empty
3821 -- on return if the corresponding argument is not present.
3823 procedure GNAT_Pragma;
3824 -- Called for all GNAT defined pragmas to check the relevant restriction
3825 -- (No_Implementation_Pragmas).
3827 function Is_Before_First_Decl
3828 (Pragma_Node : Node_Id;
3829 Decls : List_Id) return Boolean;
3830 -- Return True if Pragma_Node is before the first declarative item in
3831 -- Decls where Decls is the list of declarative items.
3833 function Is_Configuration_Pragma return Boolean;
3834 -- Determines if the placement of the current pragma is appropriate
3835 -- for a configuration pragma.
3837 function Is_In_Context_Clause return Boolean;
3838 -- Returns True if pragma appears within the context clause of a unit,
3839 -- and False for any other placement (does not generate any messages).
3841 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3842 -- Analyzes the argument, and determines if it is a static string
3843 -- expression, returns True if so, False if non-static or not String.
3844 -- A special case is that a string literal returns True in Ada 83 mode
3845 -- (which has no such thing as static string expressions). Note that
3846 -- the call analyzes its argument, so this cannot be used for the case
3847 -- where an identifier might not be declared.
3849 procedure Pragma_Misplaced;
3850 pragma No_Return (Pragma_Misplaced);
3851 -- Issue fatal error message for misplaced pragma
3853 procedure Process_Atomic_Independent_Shared_Volatile;
3854 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3855 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3856 -- and treated as being identical in effect to pragma Atomic.
3858 procedure Process_Compile_Time_Warning_Or_Error;
3859 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3861 procedure Process_Convention
3862 (C : out Convention_Id;
3863 Ent : out Entity_Id);
3864 -- Common processing for Convention, Interface, Import and Export.
3865 -- Checks first two arguments of pragma, and sets the appropriate
3866 -- convention value in the specified entity or entities. On return
3867 -- C is the convention, Ent is the referenced entity.
3869 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3870 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3871 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3873 procedure Process_Extended_Import_Export_Object_Pragma
3874 (Arg_Internal : Node_Id;
3875 Arg_External : Node_Id;
3876 Arg_Size : Node_Id);
3877 -- Common processing for the pragmas Import/Export_Object. The three
3878 -- arguments correspond to the three named parameters of the pragmas. An
3879 -- argument is empty if the corresponding parameter is not present in
3882 procedure Process_Extended_Import_Export_Internal_Arg
3883 (Arg_Internal : Node_Id := Empty);
3884 -- Common processing for all extended Import and Export pragmas. The
3885 -- argument is the pragma parameter for the Internal argument. If
3886 -- Arg_Internal is empty or inappropriate, an error message is posted.
3887 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3888 -- set to identify the referenced entity.
3890 procedure Process_Extended_Import_Export_Subprogram_Pragma
3891 (Arg_Internal : Node_Id;
3892 Arg_External : Node_Id;
3893 Arg_Parameter_Types : Node_Id;
3894 Arg_Result_Type : Node_Id := Empty;
3895 Arg_Mechanism : Node_Id;
3896 Arg_Result_Mechanism : Node_Id := Empty);
3897 -- Common processing for all extended Import and Export pragmas applying
3898 -- to subprograms. The caller omits any arguments that do not apply to
3899 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3900 -- only in the Import_Function and Export_Function cases). The argument
3901 -- names correspond to the allowed pragma association identifiers.
3903 procedure Process_Generic_List;
3904 -- Common processing for Share_Generic and Inline_Generic
3906 procedure Process_Import_Or_Interface;
3907 -- Common processing for Import or Interface
3909 procedure Process_Import_Predefined_Type;
3910 -- Processing for completing a type with pragma Import. This is used
3911 -- to declare types that match predefined C types, especially for cases
3912 -- without corresponding Ada predefined type.
3914 type Inline_Status is (Suppressed, Disabled, Enabled);
3915 -- Inline status of a subprogram, indicated as follows:
3916 -- Suppressed: inlining is suppressed for the subprogram
3917 -- Disabled: no inlining is requested for the subprogram
3918 -- Enabled: inlining is requested/required for the subprogram
3920 procedure Process_Inline (Status : Inline_Status);
3921 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3922 -- indicates the inline status specified by the pragma.
3924 procedure Process_Interface_Name
3925 (Subprogram_Def : Entity_Id;
3929 -- Given the last two arguments of pragma Import, pragma Export, or
3930 -- pragma Interface_Name, performs validity checks and sets the
3931 -- Interface_Name field of the given subprogram entity to the
3932 -- appropriate external or link name, depending on the arguments given.
3933 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3934 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3935 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3936 -- nor Link_Arg is present, the interface name is set to the default
3937 -- from the subprogram name. In addition, the pragma itself is passed
3938 -- to analyze any expressions in the case the pragma came from an aspect
3941 procedure Process_Interrupt_Or_Attach_Handler;
3942 -- Common processing for Interrupt and Attach_Handler pragmas
3944 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3945 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3946 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3947 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3948 -- is not set in the Restrictions case.
3950 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3951 -- Common processing for Suppress and Unsuppress. The boolean parameter
3952 -- Suppress_Case is True for the Suppress case, and False for the
3955 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3956 -- Subsidiary to the analysis of pragmas Independent[_Components].
3957 -- Record such a pragma N applied to entity E for future checks.
3959 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3960 -- This procedure sets the Is_Exported flag for the given entity,
3961 -- checking that the entity was not previously imported. Arg is
3962 -- the argument that specified the entity. A check is also made
3963 -- for exporting inappropriate entities.
3965 procedure Set_Extended_Import_Export_External_Name
3966 (Internal_Ent : Entity_Id;
3967 Arg_External : Node_Id);
3968 -- Common processing for all extended import export pragmas. The first
3969 -- argument, Internal_Ent, is the internal entity, which has already
3970 -- been checked for validity by the caller. Arg_External is from the
3971 -- Import or Export pragma, and may be null if no External parameter
3972 -- was present. If Arg_External is present and is a non-null string
3973 -- (a null string is treated as the default), then the Interface_Name
3974 -- field of Internal_Ent is set appropriately.
3976 procedure Set_Imported (E : Entity_Id);
3977 -- This procedure sets the Is_Imported flag for the given entity,
3978 -- checking that it is not previously exported or imported.
3980 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3981 -- Mech is a parameter passing mechanism (see Import_Function syntax
3982 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3983 -- has the right form, and if not issues an error message. If the
3984 -- argument has the right form then the Mechanism field of Ent is
3985 -- set appropriately.
3987 procedure Set_Rational_Profile;
3988 -- Activate the set of configuration pragmas and permissions that make
3989 -- up the Rational profile.
3991 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
3992 -- Activate the set of configuration pragmas and restrictions that make
3993 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
3994 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
3995 -- which is used for error messages on any constructs violating the
3998 ----------------------------------
3999 -- Acquire_Warning_Match_String --
4000 ----------------------------------
4002 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4004 String_To_Name_Buffer
4005 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4007 -- Add asterisk at start if not already there
4009 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4010 Name_Buffer (2 .. Name_Len + 1) :=
4011 Name_Buffer (1 .. Name_Len);
4012 Name_Buffer (1) := '*';
4013 Name_Len := Name_Len + 1;
4016 -- Add asterisk at end if not already there
4018 if Name_Buffer (Name_Len) /= '*' then
4019 Name_Len := Name_Len + 1;
4020 Name_Buffer (Name_Len) := '*';
4022 end Acquire_Warning_Match_String;
4024 ---------------------
4025 -- Ada_2005_Pragma --
4026 ---------------------
4028 procedure Ada_2005_Pragma is
4030 if Ada_Version <= Ada_95 then
4031 Check_Restriction (No_Implementation_Pragmas, N);
4033 end Ada_2005_Pragma;
4035 ---------------------
4036 -- Ada_2012_Pragma --
4037 ---------------------
4039 procedure Ada_2012_Pragma is
4041 if Ada_Version <= Ada_2005 then
4042 Check_Restriction (No_Implementation_Pragmas, N);
4044 end Ada_2012_Pragma;
4046 ----------------------------
4047 -- Analyze_Depends_Global --
4048 ----------------------------
4050 procedure Analyze_Depends_Global
4051 (Spec_Id : out Entity_Id;
4052 Subp_Decl : out Node_Id;
4053 Legal : out Boolean)
4056 -- Assume that the pragma is illegal
4063 Check_Arg_Count (1);
4065 -- Ensure the proper placement of the pragma. Depends/Global must be
4066 -- associated with a subprogram declaration or a body that acts as a
4069 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4073 if Nkind (Subp_Decl) = N_Entry_Declaration then
4076 -- Generic subprogram
4078 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4081 -- Object declaration of a single concurrent type
4083 elsif Nkind (Subp_Decl) = N_Object_Declaration
4084 and then Is_Single_Concurrent_Object
4085 (Unique_Defining_Entity (Subp_Decl))
4091 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4094 -- Subprogram body acts as spec
4096 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4097 and then No (Corresponding_Spec (Subp_Decl))
4101 -- Subprogram body stub acts as spec
4103 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4104 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4108 -- Subprogram declaration
4110 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4115 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4123 -- If we get here, then the pragma is legal
4126 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4128 -- When the related context is an entry, the entry must belong to a
4129 -- protected unit (SPARK RM 6.1.4(6)).
4131 if Is_Entry_Declaration (Spec_Id)
4132 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4137 -- When the related context is an anonymous object created for a
4138 -- simple concurrent type, the type must be a task
4139 -- (SPARK RM 6.1.4(6)).
4141 elsif Is_Single_Concurrent_Object (Spec_Id)
4142 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4148 -- A pragma that applies to a Ghost entity becomes Ghost for the
4149 -- purposes of legality checks and removal of ignored Ghost code.
4151 Mark_Ghost_Pragma (N, Spec_Id);
4152 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4153 end Analyze_Depends_Global;
4155 ------------------------
4156 -- Analyze_If_Present --
4157 ------------------------
4159 procedure Analyze_If_Present (Id : Pragma_Id) is
4163 pragma Assert (Is_List_Member (N));
4165 -- Inspect the declarations or statements following pragma N looking
4166 -- for another pragma whose Id matches the caller's request. If it is
4167 -- available, analyze it.
4170 while Present (Stmt) loop
4171 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4172 Analyze_Pragma (Stmt);
4175 -- The first source declaration or statement immediately following
4176 -- N ends the region where a pragma may appear.
4178 elsif Comes_From_Source (Stmt) then
4184 end Analyze_If_Present;
4186 --------------------------------
4187 -- Analyze_Pre_Post_Condition --
4188 --------------------------------
4190 procedure Analyze_Pre_Post_Condition is
4191 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4192 Subp_Decl : Node_Id;
4193 Subp_Id : Entity_Id;
4195 Duplicates_OK : Boolean := False;
4196 -- Flag set when a pre/postcondition allows multiple pragmas of the
4199 In_Body_OK : Boolean := False;
4200 -- Flag set when a pre/postcondition is allowed to appear on a body
4201 -- even though the subprogram may have a spec.
4203 Is_Pre_Post : Boolean := False;
4204 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4207 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4208 -- Implement rules in AI12-0131: an overriding operation can have
4209 -- a class-wide precondition only if one of its ancestors has an
4210 -- explicit class-wide precondition.
4212 -----------------------------
4213 -- Inherits_Class_Wide_Pre --
4214 -----------------------------
4216 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4217 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4220 Prev : Entity_Id := Overridden_Operation (E);
4223 -- Check ancestors on the overriding operation to examine the
4224 -- preconditions that may apply to them.
4226 while Present (Prev) loop
4227 Cont := Contract (Prev);
4228 if Present (Cont) then
4229 Prag := Pre_Post_Conditions (Cont);
4230 while Present (Prag) loop
4231 if Class_Present (Prag) then
4235 Prag := Next_Pragma (Prag);
4239 -- For a type derived from a generic formal type, the operation
4240 -- inheriting the condition is a renaming, not an overriding of
4241 -- the operation of the formal. Ditto for an inherited
4242 -- operation which has no explicit contracts.
4244 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4245 or else not Comes_From_Source (Prev)
4247 Prev := Alias (Prev);
4249 Prev := Overridden_Operation (Prev);
4253 -- If the controlling type of the subprogram has progenitors, an
4254 -- interface operation implemented by the current operation may
4255 -- have a class-wide precondition.
4257 if Has_Interfaces (Typ) then
4262 Prim_Elmt : Elmt_Id;
4263 Prim_List : Elist_Id;
4266 Collect_Interfaces (Typ, Ints);
4267 Elmt := First_Elmt (Ints);
4269 -- Iterate over the primitive operations of each interface
4271 while Present (Elmt) loop
4272 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4273 Prim_Elmt := First_Elmt (Prim_List);
4274 while Present (Prim_Elmt) loop
4275 Prim := Node (Prim_Elmt);
4276 if Chars (Prim) = Chars (E)
4277 and then Present (Contract (Prim))
4278 and then Class_Present
4279 (Pre_Post_Conditions (Contract (Prim)))
4284 Next_Elmt (Prim_Elmt);
4293 end Inherits_Class_Wide_Pre;
4295 -- Start of processing for Analyze_Pre_Post_Condition
4298 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4299 -- offer uniformity among the various kinds of pre/postconditions by
4300 -- rewriting the pragma identifier. This allows the retrieval of the
4301 -- original pragma name by routine Original_Aspect_Pragma_Name.
4303 if Comes_From_Source (N) then
4304 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4305 Is_Pre_Post := True;
4306 Set_Class_Present (N, Pname = Name_Pre_Class);
4307 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4309 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4310 Is_Pre_Post := True;
4311 Set_Class_Present (N, Pname = Name_Post_Class);
4312 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4316 -- Determine the semantics with respect to duplicates and placement
4317 -- in a body. Pragmas Precondition and Postcondition were introduced
4318 -- before aspects and are not subject to the same aspect-like rules.
4320 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4321 Duplicates_OK := True;
4327 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4328 -- argument without an identifier.
4331 Check_Arg_Count (1);
4332 Check_No_Identifiers;
4334 -- Pragmas Precondition and Postcondition have complex argument
4338 Check_At_Least_N_Arguments (1);
4339 Check_At_Most_N_Arguments (2);
4340 Check_Optional_Identifier (Arg1, Name_Check);
4342 if Present (Arg2) then
4343 Check_Optional_Identifier (Arg2, Name_Message);
4344 Preanalyze_Spec_Expression
4345 (Get_Pragma_Arg (Arg2), Standard_String);
4349 -- For a pragma PPC in the extended main source unit, record enabled
4351 -- ??? nothing checks that the pragma is in the main source unit
4353 if Is_Checked (N) and then not Split_PPC (N) then
4354 Set_SCO_Pragma_Enabled (Loc);
4357 -- Ensure the proper placement of the pragma
4360 Find_Related_Declaration_Or_Body
4361 (N, Do_Checks => not Duplicates_OK);
4363 -- When a pre/postcondition pragma applies to an abstract subprogram,
4364 -- its original form must be an aspect with 'Class.
4366 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4367 if not From_Aspect_Specification (N) then
4369 ("pragma % cannot be applied to abstract subprogram");
4371 elsif not Class_Present (N) then
4373 ("aspect % requires ''Class for abstract subprogram");
4376 -- Entry declaration
4378 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4381 -- Generic subprogram declaration
4383 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4388 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4389 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4393 -- Subprogram body stub
4395 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4396 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4400 -- Subprogram declaration
4402 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4404 -- AI05-0230: When a pre/postcondition pragma applies to a null
4405 -- procedure, its original form must be an aspect with 'Class.
4407 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4408 and then Null_Present (Specification (Subp_Decl))
4409 and then From_Aspect_Specification (N)
4410 and then not Class_Present (N)
4412 Error_Pragma ("aspect % requires ''Class for null procedure");
4415 -- Implement the legality checks mandated by AI12-0131:
4416 -- Pre'Class shall not be specified for an overriding primitive
4417 -- subprogram of a tagged type T unless the Pre'Class aspect is
4418 -- specified for the corresponding primitive subprogram of some
4422 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4425 if Class_Present (N)
4426 and then Pragma_Name (N) = Name_Precondition
4427 and then Present (Overridden_Operation (E))
4428 and then not Inherits_Class_Wide_Pre (E)
4431 ("illegal class-wide precondition on overriding operation",
4432 Corresponding_Aspect (N));
4436 -- A renaming declaration may inherit a generated pragma, its
4437 -- placement comes from expansion, not from source.
4439 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4440 and then not Comes_From_Source (N)
4444 -- Otherwise the placement is illegal
4451 Subp_Id := Defining_Entity (Subp_Decl);
4453 -- A pragma that applies to a Ghost entity becomes Ghost for the
4454 -- purposes of legality checks and removal of ignored Ghost code.
4456 Mark_Ghost_Pragma (N, Subp_Id);
4458 -- Chain the pragma on the contract for further processing by
4459 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4461 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4463 -- Fully analyze the pragma when it appears inside an entry or
4464 -- subprogram body because it cannot benefit from forward references.
4466 if Nkind_In (Subp_Decl, N_Entry_Body,
4468 N_Subprogram_Body_Stub)
4470 -- The legality checks of pragmas Precondition and Postcondition
4471 -- are affected by the SPARK mode in effect and the volatility of
4472 -- the context. Analyze all pragmas in a specific order.
4474 Analyze_If_Present (Pragma_SPARK_Mode);
4475 Analyze_If_Present (Pragma_Volatile_Function);
4476 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4478 end Analyze_Pre_Post_Condition;
4480 -----------------------------------------
4481 -- Analyze_Refined_Depends_Global_Post --
4482 -----------------------------------------
4484 procedure Analyze_Refined_Depends_Global_Post
4485 (Spec_Id : out Entity_Id;
4486 Body_Id : out Entity_Id;
4487 Legal : out Boolean)
4489 Body_Decl : Node_Id;
4490 Spec_Decl : Node_Id;
4493 -- Assume that the pragma is illegal
4500 Check_Arg_Count (1);
4501 Check_No_Identifiers;
4503 -- Verify the placement of the pragma and check for duplicates. The
4504 -- pragma must apply to a subprogram body [stub].
4506 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4510 if Nkind (Body_Decl) = N_Entry_Body then
4515 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4518 -- Subprogram body stub
4520 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4525 elsif Nkind (Body_Decl) = N_Task_Body then
4533 Body_Id := Defining_Entity (Body_Decl);
4534 Spec_Id := Unique_Defining_Entity (Body_Decl);
4536 -- The pragma must apply to the second declaration of a subprogram.
4537 -- In other words, the body [stub] cannot acts as a spec.
4539 if No (Spec_Id) then
4540 Error_Pragma ("pragma % cannot apply to a stand alone body");
4543 -- Catch the case where the subprogram body is a subunit and acts as
4544 -- the third declaration of the subprogram.
4546 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4547 Error_Pragma ("pragma % cannot apply to a subunit");
4551 -- A refined pragma can only apply to the body [stub] of a subprogram
4552 -- declared in the visible part of a package. Retrieve the context of
4553 -- the subprogram declaration.
4555 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4557 -- When dealing with protected entries or protected subprograms, use
4558 -- the enclosing protected type as the proper context.
4560 if Ekind_In (Spec_Id, E_Entry,
4564 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4566 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4569 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4571 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4572 & "subprogram declared in a package specification"));
4576 -- If we get here, then the pragma is legal
4580 -- A pragma that applies to a Ghost entity becomes Ghost for the
4581 -- purposes of legality checks and removal of ignored Ghost code.
4583 Mark_Ghost_Pragma (N, Spec_Id);
4585 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4586 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4588 end Analyze_Refined_Depends_Global_Post;
4590 ----------------------------------
4591 -- Analyze_Unmodified_Or_Unused --
4592 ----------------------------------
4594 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4599 Ghost_Error_Posted : Boolean := False;
4600 -- Flag set when an error concerning the illegal mix of Ghost and
4601 -- non-Ghost variables is emitted.
4603 Ghost_Id : Entity_Id := Empty;
4604 -- The entity of the first Ghost variable encountered while
4605 -- processing the arguments of the pragma.
4609 Check_At_Least_N_Arguments (1);
4611 -- Loop through arguments
4614 while Present (Arg) loop
4615 Check_No_Identifier (Arg);
4617 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4618 -- in fact generate reference, so that the entity will have a
4619 -- reference, which will inhibit any warnings about it not
4620 -- being referenced, and also properly show up in the ali file
4621 -- as a reference. But this reference is recorded before the
4622 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4623 -- generated for this reference.
4625 Check_Arg_Is_Local_Name (Arg);
4626 Arg_Expr := Get_Pragma_Arg (Arg);
4628 if Is_Entity_Name (Arg_Expr) then
4629 Arg_Id := Entity (Arg_Expr);
4631 -- Skip processing the argument if already flagged
4633 if Is_Assignable (Arg_Id)
4634 and then not Has_Pragma_Unmodified (Arg_Id)
4635 and then not Has_Pragma_Unused (Arg_Id)
4637 Set_Has_Pragma_Unmodified (Arg_Id);
4640 Set_Has_Pragma_Unused (Arg_Id);
4643 -- A pragma that applies to a Ghost entity becomes Ghost for
4644 -- the purposes of legality checks and removal of ignored
4647 Mark_Ghost_Pragma (N, Arg_Id);
4649 -- Capture the entity of the first Ghost variable being
4650 -- processed for error detection purposes.
4652 if Is_Ghost_Entity (Arg_Id) then
4653 if No (Ghost_Id) then
4657 -- Otherwise the variable is non-Ghost. It is illegal to mix
4658 -- references to Ghost and non-Ghost entities
4661 elsif Present (Ghost_Id)
4662 and then not Ghost_Error_Posted
4664 Ghost_Error_Posted := True;
4666 Error_Msg_Name_1 := Pname;
4668 ("pragma % cannot mention ghost and non-ghost "
4671 Error_Msg_Sloc := Sloc (Ghost_Id);
4672 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4674 Error_Msg_Sloc := Sloc (Arg_Id);
4675 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4678 -- Warn if already flagged as Unused or Unmodified
4680 elsif Has_Pragma_Unmodified (Arg_Id) then
4681 if Has_Pragma_Unused (Arg_Id) then
4683 ("??pragma Unused already given for &!", Arg_Expr,
4687 ("??pragma Unmodified already given for &!", Arg_Expr,
4691 -- Otherwise the pragma referenced an illegal entity
4695 ("pragma% can only be applied to a variable", Arg_Expr);
4701 end Analyze_Unmodified_Or_Unused;
4703 -----------------------------------
4704 -- Analyze_Unreference_Or_Unused --
4705 -----------------------------------
4707 procedure Analyze_Unreferenced_Or_Unused
4708 (Is_Unused : Boolean := False)
4715 Ghost_Error_Posted : Boolean := False;
4716 -- Flag set when an error concerning the illegal mix of Ghost and
4717 -- non-Ghost names is emitted.
4719 Ghost_Id : Entity_Id := Empty;
4720 -- The entity of the first Ghost name encountered while processing
4721 -- the arguments of the pragma.
4725 Check_At_Least_N_Arguments (1);
4727 -- Check case of appearing within context clause
4729 if not Is_Unused and then Is_In_Context_Clause then
4731 -- The arguments must all be units mentioned in a with clause in
4732 -- the same context clause. Note that Par.Prag already checked
4733 -- that the arguments are either identifiers or selected
4737 while Present (Arg) loop
4738 Citem := First (List_Containing (N));
4739 while Citem /= N loop
4740 Arg_Expr := Get_Pragma_Arg (Arg);
4742 if Nkind (Citem) = N_With_Clause
4743 and then Same_Name (Name (Citem), Arg_Expr)
4745 Set_Has_Pragma_Unreferenced
4748 (Library_Unit (Citem))));
4749 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4758 ("argument of pragma% is not withed unit", Arg);
4764 -- Case of not in list of context items
4768 while Present (Arg) loop
4769 Check_No_Identifier (Arg);
4771 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4772 -- in fact generate reference, so that the entity will have a
4773 -- reference, which will inhibit any warnings about it not
4774 -- being referenced, and also properly show up in the ali file
4775 -- as a reference. But this reference is recorded before the
4776 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4777 -- generated for this reference.
4779 Check_Arg_Is_Local_Name (Arg);
4780 Arg_Expr := Get_Pragma_Arg (Arg);
4782 if Is_Entity_Name (Arg_Expr) then
4783 Arg_Id := Entity (Arg_Expr);
4785 -- Warn if already flagged as Unused or Unreferenced and
4786 -- skip processing the argument.
4788 if Has_Pragma_Unreferenced (Arg_Id) then
4789 if Has_Pragma_Unused (Arg_Id) then
4791 ("??pragma Unused already given for &!", Arg_Expr,
4795 ("??pragma Unreferenced already given for &!",
4799 -- Apply Unreferenced to the entity
4802 -- If the entity is overloaded, the pragma applies to the
4803 -- most recent overloading, as documented. In this case,
4804 -- name resolution does not generate a reference, so it
4805 -- must be done here explicitly.
4807 if Is_Overloaded (Arg_Expr) then
4808 Generate_Reference (Arg_Id, N);
4811 Set_Has_Pragma_Unreferenced (Arg_Id);
4814 Set_Has_Pragma_Unused (Arg_Id);
4817 -- A pragma that applies to a Ghost entity becomes Ghost
4818 -- for the purposes of legality checks and removal of
4819 -- ignored Ghost code.
4821 Mark_Ghost_Pragma (N, Arg_Id);
4823 -- Capture the entity of the first Ghost name being
4824 -- processed for error detection purposes.
4826 if Is_Ghost_Entity (Arg_Id) then
4827 if No (Ghost_Id) then
4831 -- Otherwise the name is non-Ghost. It is illegal to mix
4832 -- references to Ghost and non-Ghost entities
4835 elsif Present (Ghost_Id)
4836 and then not Ghost_Error_Posted
4838 Ghost_Error_Posted := True;
4840 Error_Msg_Name_1 := Pname;
4842 ("pragma % cannot mention ghost and non-ghost "
4845 Error_Msg_Sloc := Sloc (Ghost_Id);
4847 ("\& # declared as ghost", N, Ghost_Id);
4849 Error_Msg_Sloc := Sloc (Arg_Id);
4851 ("\& # declared as non-ghost", N, Arg_Id);
4859 end Analyze_Unreferenced_Or_Unused;
4861 --------------------------
4862 -- Check_Ada_83_Warning --
4863 --------------------------
4865 procedure Check_Ada_83_Warning is
4867 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4868 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4870 end Check_Ada_83_Warning;
4872 ---------------------
4873 -- Check_Arg_Count --
4874 ---------------------
4876 procedure Check_Arg_Count (Required : Nat) is
4878 if Arg_Count /= Required then
4879 Error_Pragma ("wrong number of arguments for pragma%");
4881 end Check_Arg_Count;
4883 --------------------------------
4884 -- Check_Arg_Is_External_Name --
4885 --------------------------------
4887 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4888 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4891 if Nkind (Argx) = N_Identifier then
4895 Analyze_And_Resolve (Argx, Standard_String);
4897 if Is_OK_Static_Expression (Argx) then
4900 elsif Etype (Argx) = Any_Type then
4903 -- An interesting special case, if we have a string literal and
4904 -- we are in Ada 83 mode, then we allow it even though it will
4905 -- not be flagged as static. This allows expected Ada 83 mode
4906 -- use of external names which are string literals, even though
4907 -- technically these are not static in Ada 83.
4909 elsif Ada_Version = Ada_83
4910 and then Nkind (Argx) = N_String_Literal
4914 -- Here we have a real error (non-static expression)
4917 Error_Msg_Name_1 := Pname;
4918 Flag_Non_Static_Expr
4919 (Fix_Error ("argument for pragma% must be a identifier or "
4920 & "static string expression!"), Argx);
4925 end Check_Arg_Is_External_Name;
4927 -----------------------------
4928 -- Check_Arg_Is_Identifier --
4929 -----------------------------
4931 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4932 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4934 if Nkind (Argx) /= N_Identifier then
4935 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
4937 end Check_Arg_Is_Identifier;
4939 ----------------------------------
4940 -- Check_Arg_Is_Integer_Literal --
4941 ----------------------------------
4943 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4944 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4946 if Nkind (Argx) /= N_Integer_Literal then
4948 ("argument for pragma% must be integer literal", Argx);
4950 end Check_Arg_Is_Integer_Literal;
4952 -------------------------------------------
4953 -- Check_Arg_Is_Library_Level_Local_Name --
4954 -------------------------------------------
4958 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4959 -- | library_unit_NAME
4961 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4963 Check_Arg_Is_Local_Name (Arg);
4965 -- If it came from an aspect, we want to give the error just as if it
4966 -- came from source.
4968 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4969 and then (Comes_From_Source (N)
4970 or else Present (Corresponding_Aspect (Parent (Arg))))
4973 ("argument for pragma% must be library level entity", Arg);
4975 end Check_Arg_Is_Library_Level_Local_Name;
4977 -----------------------------
4978 -- Check_Arg_Is_Local_Name --
4979 -----------------------------
4983 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4984 -- | library_unit_NAME
4986 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4987 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4990 -- If this pragma came from an aspect specification, we don't want to
4991 -- check for this error, because that would cause spurious errors, in
4992 -- case a type is frozen in a scope more nested than the type. The
4993 -- aspect itself of course can't be anywhere but on the declaration
4996 if Nkind (Arg) = N_Pragma_Argument_Association then
4997 if From_Aspect_Specification (Parent (Arg)) then
5001 -- Arg is the Expression of an N_Pragma_Argument_Association
5004 if From_Aspect_Specification (Parent (Parent (Arg))) then
5011 if Nkind (Argx) not in N_Direct_Name
5012 and then (Nkind (Argx) /= N_Attribute_Reference
5013 or else Present (Expressions (Argx))
5014 or else Nkind (Prefix (Argx)) /= N_Identifier)
5015 and then (not Is_Entity_Name (Argx)
5016 or else not Is_Compilation_Unit (Entity (Argx)))
5018 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5021 -- No further check required if not an entity name
5023 if not Is_Entity_Name (Argx) then
5029 Ent : constant Entity_Id := Entity (Argx);
5030 Scop : constant Entity_Id := Scope (Ent);
5033 -- Case of a pragma applied to a compilation unit: pragma must
5034 -- occur immediately after the program unit in the compilation.
5036 if Is_Compilation_Unit (Ent) then
5038 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5041 -- Case of pragma placed immediately after spec
5043 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5046 -- Case of pragma placed immediately after body
5048 elsif Nkind (Decl) = N_Subprogram_Declaration
5049 and then Present (Corresponding_Body (Decl))
5053 (Parent (Unit_Declaration_Node
5054 (Corresponding_Body (Decl))));
5056 -- All other cases are illegal
5063 -- Special restricted placement rule from 10.2.1(11.8/2)
5065 elsif Is_Generic_Formal (Ent)
5066 and then Prag_Id = Pragma_Preelaborable_Initialization
5068 OK := List_Containing (N) =
5069 Generic_Formal_Declarations
5070 (Unit_Declaration_Node (Scop));
5072 -- If this is an aspect applied to a subprogram body, the
5073 -- pragma is inserted in its declarative part.
5075 elsif From_Aspect_Specification (N)
5076 and then Ent = Current_Scope
5078 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5082 -- If the aspect is a predicate (possibly others ???) and the
5083 -- context is a record type, this is a discriminant expression
5084 -- within a type declaration, that freezes the predicated
5087 elsif From_Aspect_Specification (N)
5088 and then Prag_Id = Pragma_Predicate
5089 and then Ekind (Current_Scope) = E_Record_Type
5090 and then Scop = Scope (Current_Scope)
5094 -- Default case, just check that the pragma occurs in the scope
5095 -- of the entity denoted by the name.
5098 OK := Current_Scope = Scop;
5103 ("pragma% argument must be in same declarative part", Arg);
5107 end Check_Arg_Is_Local_Name;
5109 ---------------------------------
5110 -- Check_Arg_Is_Locking_Policy --
5111 ---------------------------------
5113 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5114 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5117 Check_Arg_Is_Identifier (Argx);
5119 if not Is_Locking_Policy_Name (Chars (Argx)) then
5120 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5122 end Check_Arg_Is_Locking_Policy;
5124 -----------------------------------------------
5125 -- Check_Arg_Is_Partition_Elaboration_Policy --
5126 -----------------------------------------------
5128 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5129 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5132 Check_Arg_Is_Identifier (Argx);
5134 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5136 ("& is not a valid partition elaboration policy name", Argx);
5138 end Check_Arg_Is_Partition_Elaboration_Policy;
5140 -------------------------
5141 -- Check_Arg_Is_One_Of --
5142 -------------------------
5144 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5145 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5148 Check_Arg_Is_Identifier (Argx);
5150 if not Nam_In (Chars (Argx), N1, N2) then
5151 Error_Msg_Name_2 := N1;
5152 Error_Msg_Name_3 := N2;
5153 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5155 end Check_Arg_Is_One_Of;
5157 procedure Check_Arg_Is_One_Of
5159 N1, N2, N3 : Name_Id)
5161 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5164 Check_Arg_Is_Identifier (Argx);
5166 if not Nam_In (Chars (Argx), N1, N2, N3) then
5167 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5169 end Check_Arg_Is_One_Of;
5171 procedure Check_Arg_Is_One_Of
5173 N1, N2, N3, N4 : Name_Id)
5175 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5178 Check_Arg_Is_Identifier (Argx);
5180 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5181 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5183 end Check_Arg_Is_One_Of;
5185 procedure Check_Arg_Is_One_Of
5187 N1, N2, N3, N4, N5 : Name_Id)
5189 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5192 Check_Arg_Is_Identifier (Argx);
5194 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5195 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5197 end Check_Arg_Is_One_Of;
5199 ---------------------------------
5200 -- Check_Arg_Is_Queuing_Policy --
5201 ---------------------------------
5203 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5204 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5207 Check_Arg_Is_Identifier (Argx);
5209 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5210 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5212 end Check_Arg_Is_Queuing_Policy;
5214 ---------------------------------------
5215 -- Check_Arg_Is_OK_Static_Expression --
5216 ---------------------------------------
5218 procedure Check_Arg_Is_OK_Static_Expression
5220 Typ : Entity_Id := Empty)
5223 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5224 end Check_Arg_Is_OK_Static_Expression;
5226 ------------------------------------------
5227 -- Check_Arg_Is_Task_Dispatching_Policy --
5228 ------------------------------------------
5230 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5231 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5234 Check_Arg_Is_Identifier (Argx);
5236 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5238 ("& is not an allowed task dispatching policy name", Argx);
5240 end Check_Arg_Is_Task_Dispatching_Policy;
5242 ---------------------
5243 -- Check_Arg_Order --
5244 ---------------------
5246 procedure Check_Arg_Order (Names : Name_List) is
5249 Highest_So_Far : Natural := 0;
5250 -- Highest index in Names seen do far
5254 for J in 1 .. Arg_Count loop
5255 if Chars (Arg) /= No_Name then
5256 for K in Names'Range loop
5257 if Chars (Arg) = Names (K) then
5258 if K < Highest_So_Far then
5259 Error_Msg_Name_1 := Pname;
5261 ("parameters out of order for pragma%", Arg);
5262 Error_Msg_Name_1 := Names (K);
5263 Error_Msg_Name_2 := Names (Highest_So_Far);
5264 Error_Msg_N ("\% must appear before %", Arg);
5268 Highest_So_Far := K;
5276 end Check_Arg_Order;
5278 --------------------------------
5279 -- Check_At_Least_N_Arguments --
5280 --------------------------------
5282 procedure Check_At_Least_N_Arguments (N : Nat) is
5284 if Arg_Count < N then
5285 Error_Pragma ("too few arguments for pragma%");
5287 end Check_At_Least_N_Arguments;
5289 -------------------------------
5290 -- Check_At_Most_N_Arguments --
5291 -------------------------------
5293 procedure Check_At_Most_N_Arguments (N : Nat) is
5296 if Arg_Count > N then
5298 for J in 1 .. N loop
5300 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5303 end Check_At_Most_N_Arguments;
5305 ---------------------
5306 -- Check_Component --
5307 ---------------------
5309 procedure Check_Component
5312 In_Variant_Part : Boolean := False)
5314 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5315 Sindic : constant Node_Id :=
5316 Subtype_Indication (Component_Definition (Comp));
5317 Typ : constant Entity_Id := Etype (Comp_Id);
5320 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5321 -- object constraint, then the component type shall be an Unchecked_
5324 if Nkind (Sindic) = N_Subtype_Indication
5325 and then Has_Per_Object_Constraint (Comp_Id)
5326 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5329 ("component subtype subject to per-object constraint "
5330 & "must be an Unchecked_Union", Comp);
5332 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5333 -- the body of a generic unit, or within the body of any of its
5334 -- descendant library units, no part of the type of a component
5335 -- declared in a variant_part of the unchecked union type shall be of
5336 -- a formal private type or formal private extension declared within
5337 -- the formal part of the generic unit.
5339 elsif Ada_Version >= Ada_2012
5340 and then In_Generic_Body (UU_Typ)
5341 and then In_Variant_Part
5342 and then Is_Private_Type (Typ)
5343 and then Is_Generic_Type (Typ)
5346 ("component of unchecked union cannot be of generic type", Comp);
5348 elsif Needs_Finalization (Typ) then
5350 ("component of unchecked union cannot be controlled", Comp);
5352 elsif Has_Task (Typ) then
5354 ("component of unchecked union cannot have tasks", Comp);
5356 end Check_Component;
5358 ----------------------------
5359 -- Check_Duplicate_Pragma --
5360 ----------------------------
5362 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5363 Id : Entity_Id := E;
5367 -- Nothing to do if this pragma comes from an aspect specification,
5368 -- since we could not be duplicating a pragma, and we dealt with the
5369 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5371 if From_Aspect_Specification (N) then
5375 -- Otherwise current pragma may duplicate previous pragma or a
5376 -- previously given aspect specification or attribute definition
5377 -- clause for the same pragma.
5379 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5383 -- If the entity is a type, then we have to make sure that the
5384 -- ostensible duplicate is not for a parent type from which this
5388 if Nkind (P) = N_Pragma then
5390 Args : constant List_Id :=
5391 Pragma_Argument_Associations (P);
5394 and then Is_Entity_Name (Expression (First (Args)))
5395 and then Is_Type (Entity (Expression (First (Args))))
5396 and then Entity (Expression (First (Args))) /= E
5402 elsif Nkind (P) = N_Aspect_Specification
5403 and then Is_Type (Entity (P))
5404 and then Entity (P) /= E
5410 -- Here we have a definite duplicate
5412 Error_Msg_Name_1 := Pragma_Name (N);
5413 Error_Msg_Sloc := Sloc (P);
5415 -- For a single protected or a single task object, the error is
5416 -- issued on the original entity.
5418 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5419 Id := Defining_Identifier (Original_Node (Parent (Id)));
5422 if Nkind (P) = N_Aspect_Specification
5423 or else From_Aspect_Specification (P)
5425 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5427 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5432 end Check_Duplicate_Pragma;
5434 ----------------------------------
5435 -- Check_Duplicated_Export_Name --
5436 ----------------------------------
5438 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5439 String_Val : constant String_Id := Strval (Nam);
5442 -- We are only interested in the export case, and in the case of
5443 -- generics, it is the instance, not the template, that is the
5444 -- problem (the template will generate a warning in any case).
5446 if not Inside_A_Generic
5447 and then (Prag_Id = Pragma_Export
5449 Prag_Id = Pragma_Export_Procedure
5451 Prag_Id = Pragma_Export_Valued_Procedure
5453 Prag_Id = Pragma_Export_Function)
5455 for J in Externals.First .. Externals.Last loop
5456 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5457 Error_Msg_Sloc := Sloc (Externals.Table (J));
5458 Error_Msg_N ("external name duplicates name given#", Nam);
5463 Externals.Append (Nam);
5465 end Check_Duplicated_Export_Name;
5467 ----------------------------------------
5468 -- Check_Expr_Is_OK_Static_Expression --
5469 ----------------------------------------
5471 procedure Check_Expr_Is_OK_Static_Expression
5473 Typ : Entity_Id := Empty)
5476 if Present (Typ) then
5477 Analyze_And_Resolve (Expr, Typ);
5479 Analyze_And_Resolve (Expr);
5482 -- An expression cannot be considered static if its resolution failed
5483 -- or if it's erroneous. Stop the analysis of the related pragma.
5485 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5488 elsif Is_OK_Static_Expression (Expr) then
5491 -- An interesting special case, if we have a string literal and we
5492 -- are in Ada 83 mode, then we allow it even though it will not be
5493 -- flagged as static. This allows the use of Ada 95 pragmas like
5494 -- Import in Ada 83 mode. They will of course be flagged with
5495 -- warnings as usual, but will not cause errors.
5497 elsif Ada_Version = Ada_83
5498 and then Nkind (Expr) = N_String_Literal
5502 -- Finally, we have a real error
5505 Error_Msg_Name_1 := Pname;
5506 Flag_Non_Static_Expr
5507 (Fix_Error ("argument for pragma% must be a static expression!"),
5511 end Check_Expr_Is_OK_Static_Expression;
5513 -------------------------
5514 -- Check_First_Subtype --
5515 -------------------------
5517 procedure Check_First_Subtype (Arg : Node_Id) is
5518 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5519 Ent : constant Entity_Id := Entity (Argx);
5522 if Is_First_Subtype (Ent) then
5525 elsif Is_Type (Ent) then
5527 ("pragma% cannot apply to subtype", Argx);
5529 elsif Is_Object (Ent) then
5531 ("pragma% cannot apply to object, requires a type", Argx);
5535 ("pragma% cannot apply to&, requires a type", Argx);
5537 end Check_First_Subtype;
5539 ----------------------
5540 -- Check_Identifier --
5541 ----------------------
5543 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5546 and then Nkind (Arg) = N_Pragma_Argument_Association
5548 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5549 Error_Msg_Name_1 := Pname;
5550 Error_Msg_Name_2 := Id;
5551 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5555 end Check_Identifier;
5557 --------------------------------
5558 -- Check_Identifier_Is_One_Of --
5559 --------------------------------
5561 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5564 and then Nkind (Arg) = N_Pragma_Argument_Association
5566 if Chars (Arg) = No_Name then
5567 Error_Msg_Name_1 := Pname;
5568 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5571 elsif Chars (Arg) /= N1
5572 and then Chars (Arg) /= N2
5574 Error_Msg_Name_1 := Pname;
5575 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5579 end Check_Identifier_Is_One_Of;
5581 ---------------------------
5582 -- Check_In_Main_Program --
5583 ---------------------------
5585 procedure Check_In_Main_Program is
5586 P : constant Node_Id := Parent (N);
5589 -- Must be in subprogram body
5591 if Nkind (P) /= N_Subprogram_Body then
5592 Error_Pragma ("% pragma allowed only in subprogram");
5594 -- Otherwise warn if obviously not main program
5596 elsif Present (Parameter_Specifications (Specification (P)))
5597 or else not Is_Compilation_Unit (Defining_Entity (P))
5599 Error_Msg_Name_1 := Pname;
5601 ("??pragma% is only effective in main program", N);
5603 end Check_In_Main_Program;
5605 ---------------------------------------
5606 -- Check_Interrupt_Or_Attach_Handler --
5607 ---------------------------------------
5609 procedure Check_Interrupt_Or_Attach_Handler is
5610 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5611 Handler_Proc, Proc_Scope : Entity_Id;
5616 if Prag_Id = Pragma_Interrupt_Handler then
5617 Check_Restriction (No_Dynamic_Attachment, N);
5620 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5621 Proc_Scope := Scope (Handler_Proc);
5623 if Ekind (Proc_Scope) /= E_Protected_Type then
5625 ("argument of pragma% must be protected procedure", Arg1);
5628 -- For pragma case (as opposed to access case), check placement.
5629 -- We don't need to do that for aspects, because we have the
5630 -- check that they aspect applies an appropriate procedure.
5632 if not From_Aspect_Specification (N)
5633 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5635 Error_Pragma ("pragma% must be in protected definition");
5638 if not Is_Library_Level_Entity (Proc_Scope) then
5640 ("argument for pragma% must be library level entity", Arg1);
5643 -- AI05-0033: A pragma cannot appear within a generic body, because
5644 -- instance can be in a nested scope. The check that protected type
5645 -- is itself a library-level declaration is done elsewhere.
5647 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5648 -- handle code prior to AI-0033. Analysis tools typically are not
5649 -- interested in this pragma in any case, so no need to worry too
5650 -- much about its placement.
5652 if Inside_A_Generic then
5653 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5654 and then In_Package_Body (Scope (Current_Scope))
5655 and then not Relaxed_RM_Semantics
5657 Error_Pragma ("pragma% cannot be used inside a generic");
5660 end Check_Interrupt_Or_Attach_Handler;
5662 ---------------------------------
5663 -- Check_Loop_Pragma_Placement --
5664 ---------------------------------
5666 procedure Check_Loop_Pragma_Placement is
5667 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5668 -- Verify whether the current pragma is properly grouped with other
5669 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5670 -- related loop where the pragma appears.
5672 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5673 -- Determine whether an arbitrary statement Stmt denotes pragma
5674 -- Loop_Invariant or Loop_Variant.
5676 procedure Placement_Error (Constr : Node_Id);
5677 pragma No_Return (Placement_Error);
5678 -- Node Constr denotes the last loop restricted construct before we
5679 -- encountered an illegal relation between enclosing constructs. Emit
5680 -- an error depending on what Constr was.
5682 --------------------------------
5683 -- Check_Loop_Pragma_Grouping --
5684 --------------------------------
5686 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5687 Stop_Search : exception;
5688 -- This exception is used to terminate the recursive descent of
5689 -- routine Check_Grouping.
5691 procedure Check_Grouping (L : List_Id);
5692 -- Find the first group of pragmas in list L and if successful,
5693 -- ensure that the current pragma is part of that group. The
5694 -- routine raises Stop_Search once such a check is performed to
5695 -- halt the recursive descent.
5697 procedure Grouping_Error (Prag : Node_Id);
5698 pragma No_Return (Grouping_Error);
5699 -- Emit an error concerning the current pragma indicating that it
5700 -- should be placed after pragma Prag.
5702 --------------------
5703 -- Check_Grouping --
5704 --------------------
5706 procedure Check_Grouping (L : List_Id) is
5712 -- Inspect the list of declarations or statements looking for
5713 -- the first grouping of pragmas:
5716 -- pragma Loop_Invariant ...;
5717 -- pragma Loop_Variant ...;
5719 -- pragma Loop_Variant ...; -- current pragma
5721 -- If the current pragma is not in the grouping, then it must
5722 -- either appear in a different declarative or statement list
5723 -- or the construct at (1) is separating the pragma from the
5727 while Present (Stmt) loop
5729 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5730 -- inside a loop or a block housed inside a loop. Inspect
5731 -- the declarations and statements of the block as they may
5732 -- contain the first grouping.
5734 if Nkind (Stmt) = N_Block_Statement then
5735 HSS := Handled_Statement_Sequence (Stmt);
5737 Check_Grouping (Declarations (Stmt));
5739 if Present (HSS) then
5740 Check_Grouping (Statements (HSS));
5743 -- First pragma of the first topmost grouping has been found
5745 elsif Is_Loop_Pragma (Stmt) then
5747 -- The group and the current pragma are not in the same
5748 -- declarative or statement list.
5750 if List_Containing (Stmt) /= List_Containing (N) then
5751 Grouping_Error (Stmt);
5753 -- Try to reach the current pragma from the first pragma
5754 -- of the grouping while skipping other members:
5756 -- pragma Loop_Invariant ...; -- first pragma
5757 -- pragma Loop_Variant ...; -- member
5759 -- pragma Loop_Variant ...; -- current pragma
5762 while Present (Stmt) loop
5764 -- The current pragma is either the first pragma
5765 -- of the group or is a member of the group. Stop
5766 -- the search as the placement is legal.
5771 -- Skip group members, but keep track of the last
5772 -- pragma in the group.
5774 elsif Is_Loop_Pragma (Stmt) then
5777 -- Skip declarations and statements generated by
5778 -- the compiler during expansion.
5780 elsif not Comes_From_Source (Stmt) then
5783 -- A non-pragma is separating the group from the
5784 -- current pragma, the placement is illegal.
5787 Grouping_Error (Prag);
5793 -- If the traversal did not reach the current pragma,
5794 -- then the list must be malformed.
5796 raise Program_Error;
5804 --------------------
5805 -- Grouping_Error --
5806 --------------------
5808 procedure Grouping_Error (Prag : Node_Id) is
5810 Error_Msg_Sloc := Sloc (Prag);
5811 Error_Pragma ("pragma% must appear next to pragma#");
5814 -- Start of processing for Check_Loop_Pragma_Grouping
5817 -- Inspect the statements of the loop or nested blocks housed
5818 -- within to determine whether the current pragma is part of the
5819 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5821 Check_Grouping (Statements (Loop_Stmt));
5824 when Stop_Search => null;
5825 end Check_Loop_Pragma_Grouping;
5827 --------------------
5828 -- Is_Loop_Pragma --
5829 --------------------
5831 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5833 -- Inspect the original node as Loop_Invariant and Loop_Variant
5834 -- pragmas are rewritten to null when assertions are disabled.
5836 if Nkind (Original_Node (Stmt)) = N_Pragma then
5838 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
5839 Name_Loop_Invariant,
5846 ---------------------
5847 -- Placement_Error --
5848 ---------------------
5850 procedure Placement_Error (Constr : Node_Id) is
5851 LA : constant String := " with Loop_Entry";
5854 if Prag_Id = Pragma_Assert then
5855 Error_Msg_String (1 .. LA'Length) := LA;
5856 Error_Msg_Strlen := LA'Length;
5858 Error_Msg_Strlen := 0;
5861 if Nkind (Constr) = N_Pragma then
5863 ("pragma %~ must appear immediately within the statements "
5867 ("block containing pragma %~ must appear immediately within "
5868 & "the statements of a loop", Constr);
5870 end Placement_Error;
5872 -- Local declarations
5877 -- Start of processing for Check_Loop_Pragma_Placement
5880 -- Check that pragma appears immediately within a loop statement,
5881 -- ignoring intervening block statements.
5885 while Present (Stmt) loop
5887 -- The pragma or previous block must appear immediately within the
5888 -- current block's declarative or statement part.
5890 if Nkind (Stmt) = N_Block_Statement then
5891 if (No (Declarations (Stmt))
5892 or else List_Containing (Prev) /= Declarations (Stmt))
5894 List_Containing (Prev) /=
5895 Statements (Handled_Statement_Sequence (Stmt))
5897 Placement_Error (Prev);
5900 -- Keep inspecting the parents because we are now within a
5901 -- chain of nested blocks.
5905 Stmt := Parent (Stmt);
5908 -- The pragma or previous block must appear immediately within the
5909 -- statements of the loop.
5911 elsif Nkind (Stmt) = N_Loop_Statement then
5912 if List_Containing (Prev) /= Statements (Stmt) then
5913 Placement_Error (Prev);
5916 -- Stop the traversal because we reached the innermost loop
5917 -- regardless of whether we encountered an error or not.
5921 -- Ignore a handled statement sequence. Note that this node may
5922 -- be related to a subprogram body in which case we will emit an
5923 -- error on the next iteration of the search.
5925 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5926 Stmt := Parent (Stmt);
5928 -- Any other statement breaks the chain from the pragma to the
5932 Placement_Error (Prev);
5937 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5938 -- grouped together with other such pragmas.
5940 if Is_Loop_Pragma (N) then
5942 -- The previous check should have located the related loop
5944 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5945 Check_Loop_Pragma_Grouping (Stmt);
5947 end Check_Loop_Pragma_Placement;
5949 -------------------------------------------
5950 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5951 -------------------------------------------
5953 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5962 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5965 elsif Nkind_In (P, N_Package_Specification,
5970 -- Note: the following tests seem a little peculiar, because
5971 -- they test for bodies, but if we were in the statement part
5972 -- of the body, we would already have hit the handled statement
5973 -- sequence, so the only way we get here is by being in the
5974 -- declarative part of the body.
5976 elsif Nkind_In (P, N_Subprogram_Body,
5987 Error_Pragma ("pragma% is not in declarative part or package spec");
5988 end Check_Is_In_Decl_Part_Or_Package_Spec;
5990 -------------------------
5991 -- Check_No_Identifier --
5992 -------------------------
5994 procedure Check_No_Identifier (Arg : Node_Id) is
5996 if Nkind (Arg) = N_Pragma_Argument_Association
5997 and then Chars (Arg) /= No_Name
5999 Error_Pragma_Arg_Ident
6000 ("pragma% does not permit identifier& here", Arg);
6002 end Check_No_Identifier;
6004 --------------------------
6005 -- Check_No_Identifiers --
6006 --------------------------
6008 procedure Check_No_Identifiers is
6012 for J in 1 .. Arg_Count loop
6013 Check_No_Identifier (Arg_Node);
6016 end Check_No_Identifiers;
6018 ------------------------
6019 -- Check_No_Link_Name --
6020 ------------------------
6022 procedure Check_No_Link_Name is
6024 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6028 if Present (Arg4) then
6030 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6032 end Check_No_Link_Name;
6034 -------------------------------
6035 -- Check_Optional_Identifier --
6036 -------------------------------
6038 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6041 and then Nkind (Arg) = N_Pragma_Argument_Association
6042 and then Chars (Arg) /= No_Name
6044 if Chars (Arg) /= Id then
6045 Error_Msg_Name_1 := Pname;
6046 Error_Msg_Name_2 := Id;
6047 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6051 end Check_Optional_Identifier;
6053 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6055 Check_Optional_Identifier (Arg, Name_Find (Id));
6056 end Check_Optional_Identifier;
6058 -------------------------------------
6059 -- Check_Static_Boolean_Expression --
6060 -------------------------------------
6062 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6064 if Present (Expr) then
6065 Analyze_And_Resolve (Expr, Standard_Boolean);
6067 if not Is_OK_Static_Expression (Expr) then
6069 ("expression of pragma % must be static", Expr);
6072 end Check_Static_Boolean_Expression;
6074 -----------------------------
6075 -- Check_Static_Constraint --
6076 -----------------------------
6078 -- Note: for convenience in writing this procedure, in addition to
6079 -- the officially (i.e. by spec) allowed argument which is always a
6080 -- constraint, it also allows ranges and discriminant associations.
6081 -- Above is not clear ???
6083 procedure Check_Static_Constraint (Constr : Node_Id) is
6085 procedure Require_Static (E : Node_Id);
6086 -- Require given expression to be static expression
6088 --------------------
6089 -- Require_Static --
6090 --------------------
6092 procedure Require_Static (E : Node_Id) is
6094 if not Is_OK_Static_Expression (E) then
6095 Flag_Non_Static_Expr
6096 ("non-static constraint not allowed in Unchecked_Union!", E);
6101 -- Start of processing for Check_Static_Constraint
6104 case Nkind (Constr) is
6105 when N_Discriminant_Association =>
6106 Require_Static (Expression (Constr));
6109 Require_Static (Low_Bound (Constr));
6110 Require_Static (High_Bound (Constr));
6112 when N_Attribute_Reference =>
6113 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6114 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6116 when N_Range_Constraint =>
6117 Check_Static_Constraint (Range_Expression (Constr));
6119 when N_Index_Or_Discriminant_Constraint =>
6123 IDC := First (Constraints (Constr));
6124 while Present (IDC) loop
6125 Check_Static_Constraint (IDC);
6133 end Check_Static_Constraint;
6135 --------------------------------------
6136 -- Check_Valid_Configuration_Pragma --
6137 --------------------------------------
6139 -- A configuration pragma must appear in the context clause of a
6140 -- compilation unit, and only other pragmas may precede it. Note that
6141 -- the test also allows use in a configuration pragma file.
6143 procedure Check_Valid_Configuration_Pragma is
6145 if not Is_Configuration_Pragma then
6146 Error_Pragma ("incorrect placement for configuration pragma%");
6148 end Check_Valid_Configuration_Pragma;
6150 -------------------------------------
6151 -- Check_Valid_Library_Unit_Pragma --
6152 -------------------------------------
6154 procedure Check_Valid_Library_Unit_Pragma is
6156 Parent_Node : Node_Id;
6157 Unit_Name : Entity_Id;
6158 Unit_Kind : Node_Kind;
6159 Unit_Node : Node_Id;
6160 Sindex : Source_File_Index;
6163 if not Is_List_Member (N) then
6167 Plist := List_Containing (N);
6168 Parent_Node := Parent (Plist);
6170 if Parent_Node = Empty then
6173 -- Case of pragma appearing after a compilation unit. In this case
6174 -- it must have an argument with the corresponding name and must
6175 -- be part of the following pragmas of its parent.
6177 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6178 if Plist /= Pragmas_After (Parent_Node) then
6181 elsif Arg_Count = 0 then
6183 ("argument required if outside compilation unit");
6186 Check_No_Identifiers;
6187 Check_Arg_Count (1);
6188 Unit_Node := Unit (Parent (Parent_Node));
6189 Unit_Kind := Nkind (Unit_Node);
6191 Analyze (Get_Pragma_Arg (Arg1));
6193 if Unit_Kind = N_Generic_Subprogram_Declaration
6194 or else Unit_Kind = N_Subprogram_Declaration
6196 Unit_Name := Defining_Entity (Unit_Node);
6198 elsif Unit_Kind in N_Generic_Instantiation then
6199 Unit_Name := Defining_Entity (Unit_Node);
6202 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6205 if Chars (Unit_Name) /=
6206 Chars (Entity (Get_Pragma_Arg (Arg1)))
6209 ("pragma% argument is not current unit name", Arg1);
6212 if Ekind (Unit_Name) = E_Package
6213 and then Present (Renamed_Entity (Unit_Name))
6215 Error_Pragma ("pragma% not allowed for renamed package");
6219 -- Pragma appears other than after a compilation unit
6222 -- Here we check for the generic instantiation case and also
6223 -- for the case of processing a generic formal package. We
6224 -- detect these cases by noting that the Sloc on the node
6225 -- does not belong to the current compilation unit.
6227 Sindex := Source_Index (Current_Sem_Unit);
6229 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6230 Rewrite (N, Make_Null_Statement (Loc));
6233 -- If before first declaration, the pragma applies to the
6234 -- enclosing unit, and the name if present must be this name.
6236 elsif Is_Before_First_Decl (N, Plist) then
6237 Unit_Node := Unit_Declaration_Node (Current_Scope);
6238 Unit_Kind := Nkind (Unit_Node);
6240 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6243 elsif Unit_Kind = N_Subprogram_Body
6244 and then not Acts_As_Spec (Unit_Node)
6248 elsif Nkind (Parent_Node) = N_Package_Body then
6251 elsif Nkind (Parent_Node) = N_Package_Specification
6252 and then Plist = Private_Declarations (Parent_Node)
6256 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6257 or else Nkind (Parent_Node) =
6258 N_Generic_Subprogram_Declaration)
6259 and then Plist = Generic_Formal_Declarations (Parent_Node)
6263 elsif Arg_Count > 0 then
6264 Analyze (Get_Pragma_Arg (Arg1));
6266 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6268 ("name in pragma% must be enclosing unit", Arg1);
6271 -- It is legal to have no argument in this context
6277 -- Error if not before first declaration. This is because a
6278 -- library unit pragma argument must be the name of a library
6279 -- unit (RM 10.1.5(7)), but the only names permitted in this
6280 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6281 -- generic subprogram declarations or generic instantiations.
6285 ("pragma% misplaced, must be before first declaration");
6289 end Check_Valid_Library_Unit_Pragma;
6295 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6296 Clist : constant Node_Id := Component_List (Variant);
6300 Comp := First (Component_Items (Clist));
6301 while Present (Comp) loop
6302 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6307 ---------------------------
6308 -- Ensure_Aggregate_Form --
6309 ---------------------------
6311 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6312 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6313 Expr : constant Node_Id := Expression (Arg);
6314 Loc : constant Source_Ptr := Sloc (Expr);
6315 Comps : List_Id := No_List;
6316 Exprs : List_Id := No_List;
6317 Nam : Name_Id := No_Name;
6318 Nam_Loc : Source_Ptr;
6321 -- The pragma argument is in positional form:
6323 -- pragma Depends (Nam => ...)
6327 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6328 -- argument association.
6330 if Nkind (Arg) = N_Pragma_Argument_Association then
6332 Nam_Loc := Sloc (Arg);
6334 -- Remove the pragma argument name as this will be captured in the
6337 Set_Chars (Arg, No_Name);
6340 -- The argument is already in aggregate form, but the presence of a
6341 -- name causes this to be interpreted as named association which in
6342 -- turn must be converted into an aggregate.
6344 -- pragma Global (In_Out => (A, B, C))
6348 -- pragma Global ((In_Out => (A, B, C)))
6350 -- aggregate aggregate
6352 if Nkind (Expr) = N_Aggregate then
6353 if Nam = No_Name then
6357 -- Do not transform a null argument into an aggregate as N_Null has
6358 -- special meaning in formal verification pragmas.
6360 elsif Nkind (Expr) = N_Null then
6364 -- Everything comes from source if the original comes from source
6366 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6368 -- Positional argument is transformed into an aggregate with an
6369 -- Expressions list.
6371 if Nam = No_Name then
6372 Exprs := New_List (Relocate_Node (Expr));
6374 -- An associative argument is transformed into an aggregate with
6375 -- Component_Associations.
6379 Make_Component_Association (Loc,
6380 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6381 Expression => Relocate_Node (Expr)));
6384 Set_Expression (Arg,
6385 Make_Aggregate (Loc,
6386 Component_Associations => Comps,
6387 Expressions => Exprs));
6389 -- Restore Comes_From_Source default
6391 Set_Comes_From_Source_Default (CFSD);
6392 end Ensure_Aggregate_Form;
6398 procedure Error_Pragma (Msg : String) is
6400 Error_Msg_Name_1 := Pname;
6401 Error_Msg_N (Fix_Error (Msg), N);
6405 ----------------------
6406 -- Error_Pragma_Arg --
6407 ----------------------
6409 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6411 Error_Msg_Name_1 := Pname;
6412 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6414 end Error_Pragma_Arg;
6416 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6418 Error_Msg_Name_1 := Pname;
6419 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6420 Error_Pragma_Arg (Msg2, Arg);
6421 end Error_Pragma_Arg;
6423 ----------------------------
6424 -- Error_Pragma_Arg_Ident --
6425 ----------------------------
6427 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6429 Error_Msg_Name_1 := Pname;
6430 Error_Msg_N (Fix_Error (Msg), Arg);
6432 end Error_Pragma_Arg_Ident;
6434 ----------------------
6435 -- Error_Pragma_Ref --
6436 ----------------------
6438 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6440 Error_Msg_Name_1 := Pname;
6441 Error_Msg_Sloc := Sloc (Ref);
6442 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6444 end Error_Pragma_Ref;
6446 ------------------------
6447 -- Find_Lib_Unit_Name --
6448 ------------------------
6450 function Find_Lib_Unit_Name return Entity_Id is
6452 -- Return inner compilation unit entity, for case of nested
6453 -- categorization pragmas. This happens in generic unit.
6455 if Nkind (Parent (N)) = N_Package_Specification
6456 and then Defining_Entity (Parent (N)) /= Current_Scope
6458 return Defining_Entity (Parent (N));
6460 return Current_Scope;
6462 end Find_Lib_Unit_Name;
6464 ----------------------------
6465 -- Find_Program_Unit_Name --
6466 ----------------------------
6468 procedure Find_Program_Unit_Name (Id : Node_Id) is
6469 Unit_Name : Entity_Id;
6470 Unit_Kind : Node_Kind;
6471 P : constant Node_Id := Parent (N);
6474 if Nkind (P) = N_Compilation_Unit then
6475 Unit_Kind := Nkind (Unit (P));
6477 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6478 N_Package_Declaration)
6479 or else Unit_Kind in N_Generic_Declaration
6481 Unit_Name := Defining_Entity (Unit (P));
6483 if Chars (Id) = Chars (Unit_Name) then
6484 Set_Entity (Id, Unit_Name);
6485 Set_Etype (Id, Etype (Unit_Name));
6487 Set_Etype (Id, Any_Type);
6489 ("cannot find program unit referenced by pragma%");
6493 Set_Etype (Id, Any_Type);
6494 Error_Pragma ("pragma% inapplicable to this unit");
6500 end Find_Program_Unit_Name;
6502 -----------------------------------------
6503 -- Find_Unique_Parameterless_Procedure --
6504 -----------------------------------------
6506 function Find_Unique_Parameterless_Procedure
6508 Arg : Node_Id) return Entity_Id
6510 Proc : Entity_Id := Empty;
6513 -- The body of this procedure needs some comments ???
6515 if not Is_Entity_Name (Name) then
6517 ("argument of pragma% must be entity name", Arg);
6519 elsif not Is_Overloaded (Name) then
6520 Proc := Entity (Name);
6522 if Ekind (Proc) /= E_Procedure
6523 or else Present (First_Formal (Proc))
6526 ("argument of pragma% must be parameterless procedure", Arg);
6531 Found : Boolean := False;
6533 Index : Interp_Index;
6536 Get_First_Interp (Name, Index, It);
6537 while Present (It.Nam) loop
6540 if Ekind (Proc) = E_Procedure
6541 and then No (First_Formal (Proc))
6545 Set_Entity (Name, Proc);
6546 Set_Is_Overloaded (Name, False);
6549 ("ambiguous handler name for pragma% ", Arg);
6553 Get_Next_Interp (Index, It);
6558 ("argument of pragma% must be parameterless procedure",
6561 Proc := Entity (Name);
6567 end Find_Unique_Parameterless_Procedure;
6573 function Fix_Error (Msg : String) return String is
6574 Res : String (Msg'Range) := Msg;
6575 Res_Last : Natural := Msg'Last;
6579 -- If we have a rewriting of another pragma, go to that pragma
6581 if Is_Rewrite_Substitution (N)
6582 and then Nkind (Original_Node (N)) = N_Pragma
6584 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6587 -- Case where pragma comes from an aspect specification
6589 if From_Aspect_Specification (N) then
6591 -- Change appearence of "pragma" in message to "aspect"
6594 while J <= Res_Last - 5 loop
6595 if Res (J .. J + 5) = "pragma" then
6596 Res (J .. J + 5) := "aspect";
6604 -- Change "argument of" at start of message to "entity for"
6607 and then Res (Res'First .. Res'First + 10) = "argument of"
6609 Res (Res'First .. Res'First + 9) := "entity for";
6610 Res (Res'First + 10 .. Res_Last - 1) :=
6611 Res (Res'First + 11 .. Res_Last);
6612 Res_Last := Res_Last - 1;
6615 -- Change "argument" at start of message to "entity"
6618 and then Res (Res'First .. Res'First + 7) = "argument"
6620 Res (Res'First .. Res'First + 5) := "entity";
6621 Res (Res'First + 6 .. Res_Last - 2) :=
6622 Res (Res'First + 8 .. Res_Last);
6623 Res_Last := Res_Last - 2;
6626 -- Get name from corresponding aspect
6628 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6631 -- Return possibly modified message
6633 return Res (Res'First .. Res_Last);
6636 -------------------------
6637 -- Gather_Associations --
6638 -------------------------
6640 procedure Gather_Associations
6642 Args : out Args_List)
6647 -- Initialize all parameters to Empty
6649 for J in Args'Range loop
6653 -- That's all we have to do if there are no argument associations
6655 if No (Pragma_Argument_Associations (N)) then
6659 -- Otherwise first deal with any positional parameters present
6661 Arg := First (Pragma_Argument_Associations (N));
6662 for Index in Args'Range loop
6663 exit when No (Arg) or else Chars (Arg) /= No_Name;
6664 Args (Index) := Get_Pragma_Arg (Arg);
6668 -- Positional parameters all processed, if any left, then we
6669 -- have too many positional parameters.
6671 if Present (Arg) and then Chars (Arg) = No_Name then
6673 ("too many positional associations for pragma%", Arg);
6676 -- Process named parameters if any are present
6678 while Present (Arg) loop
6679 if Chars (Arg) = No_Name then
6681 ("positional association cannot follow named association",
6685 for Index in Names'Range loop
6686 if Names (Index) = Chars (Arg) then
6687 if Present (Args (Index)) then
6689 ("duplicate argument association for pragma%", Arg);
6691 Args (Index) := Get_Pragma_Arg (Arg);
6696 if Index = Names'Last then
6697 Error_Msg_Name_1 := Pname;
6698 Error_Msg_N ("pragma% does not allow & argument", Arg);
6700 -- Check for possible misspelling
6702 for Index1 in Names'Range loop
6703 if Is_Bad_Spelling_Of
6704 (Chars (Arg), Names (Index1))
6706 Error_Msg_Name_1 := Names (Index1);
6707 Error_Msg_N -- CODEFIX
6708 ("\possible misspelling of%", Arg);
6720 end Gather_Associations;
6726 procedure GNAT_Pragma is
6728 -- We need to check the No_Implementation_Pragmas restriction for
6729 -- the case of a pragma from source. Note that the case of aspects
6730 -- generating corresponding pragmas marks these pragmas as not being
6731 -- from source, so this test also catches that case.
6733 if Comes_From_Source (N) then
6734 Check_Restriction (No_Implementation_Pragmas, N);
6738 --------------------------
6739 -- Is_Before_First_Decl --
6740 --------------------------
6742 function Is_Before_First_Decl
6743 (Pragma_Node : Node_Id;
6744 Decls : List_Id) return Boolean
6746 Item : Node_Id := First (Decls);
6749 -- Only other pragmas can come before this pragma
6752 if No (Item) or else Nkind (Item) /= N_Pragma then
6755 elsif Item = Pragma_Node then
6761 end Is_Before_First_Decl;
6763 -----------------------------
6764 -- Is_Configuration_Pragma --
6765 -----------------------------
6767 -- A configuration pragma must appear in the context clause of a
6768 -- compilation unit, and only other pragmas may precede it. Note that
6769 -- the test below also permits use in a configuration pragma file.
6771 function Is_Configuration_Pragma return Boolean is
6772 Lis : constant List_Id := List_Containing (N);
6773 Par : constant Node_Id := Parent (N);
6777 -- If no parent, then we are in the configuration pragma file,
6778 -- so the placement is definitely appropriate.
6783 -- Otherwise we must be in the context clause of a compilation unit
6784 -- and the only thing allowed before us in the context list is more
6785 -- configuration pragmas.
6787 elsif Nkind (Par) = N_Compilation_Unit
6788 and then Context_Items (Par) = Lis
6795 elsif Nkind (Prg) /= N_Pragma then
6805 end Is_Configuration_Pragma;
6807 --------------------------
6808 -- Is_In_Context_Clause --
6809 --------------------------
6811 function Is_In_Context_Clause return Boolean is
6813 Parent_Node : Node_Id;
6816 if not Is_List_Member (N) then
6820 Plist := List_Containing (N);
6821 Parent_Node := Parent (Plist);
6823 if Parent_Node = Empty
6824 or else Nkind (Parent_Node) /= N_Compilation_Unit
6825 or else Context_Items (Parent_Node) /= Plist
6832 end Is_In_Context_Clause;
6834 ---------------------------------
6835 -- Is_Static_String_Expression --
6836 ---------------------------------
6838 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6839 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6840 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6843 Analyze_And_Resolve (Argx);
6845 -- Special case Ada 83, where the expression will never be static,
6846 -- but we will return true if we had a string literal to start with.
6848 if Ada_Version = Ada_83 then
6851 -- Normal case, true only if we end up with a string literal that
6852 -- is marked as being the result of evaluating a static expression.
6855 return Is_OK_Static_Expression (Argx)
6856 and then Nkind (Argx) = N_String_Literal;
6859 end Is_Static_String_Expression;
6861 ----------------------
6862 -- Pragma_Misplaced --
6863 ----------------------
6865 procedure Pragma_Misplaced is
6867 Error_Pragma ("incorrect placement of pragma%");
6868 end Pragma_Misplaced;
6870 ------------------------------------------------
6871 -- Process_Atomic_Independent_Shared_Volatile --
6872 ------------------------------------------------
6874 procedure Process_Atomic_Independent_Shared_Volatile is
6875 procedure Set_Atomic_VFA (E : Entity_Id);
6876 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6877 -- no explicit alignment was given, set alignment to unknown, since
6878 -- back end knows what the alignment requirements are for atomic and
6879 -- full access arrays. Note: this is necessary for derived types.
6881 --------------------
6882 -- Set_Atomic_VFA --
6883 --------------------
6885 procedure Set_Atomic_VFA (E : Entity_Id) is
6887 if Prag_Id = Pragma_Volatile_Full_Access then
6888 Set_Is_Volatile_Full_Access (E);
6893 if not Has_Alignment_Clause (E) then
6894 Set_Alignment (E, Uint_0);
6904 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6907 Check_Ada_83_Warning;
6908 Check_No_Identifiers;
6909 Check_Arg_Count (1);
6910 Check_Arg_Is_Local_Name (Arg1);
6911 E_Arg := Get_Pragma_Arg (Arg1);
6913 if Etype (E_Arg) = Any_Type then
6917 E := Entity (E_Arg);
6919 -- A pragma that applies to a Ghost entity becomes Ghost for the
6920 -- purposes of legality checks and removal of ignored Ghost code.
6922 Mark_Ghost_Pragma (N, E);
6924 -- Check duplicate before we chain ourselves
6926 Check_Duplicate_Pragma (E);
6928 -- Check Atomic and VFA used together
6930 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6931 or else (Is_Volatile_Full_Access (E)
6932 and then (Prag_Id = Pragma_Atomic
6934 Prag_Id = Pragma_Shared))
6937 ("cannot have Volatile_Full_Access and Atomic for same entity");
6940 -- Check for applying VFA to an entity which has aliased component
6942 if Prag_Id = Pragma_Volatile_Full_Access then
6945 Aliased_Comp : Boolean := False;
6946 -- Set True if aliased component present
6949 if Is_Array_Type (Etype (E)) then
6950 Aliased_Comp := Has_Aliased_Components (Etype (E));
6952 -- Record case, too bad Has_Aliased_Components is not also
6953 -- set for records, should it be ???
6955 elsif Is_Record_Type (Etype (E)) then
6956 Comp := First_Component_Or_Discriminant (Etype (E));
6957 while Present (Comp) loop
6958 if Is_Aliased (Comp)
6959 or else Is_Aliased (Etype (Comp))
6961 Aliased_Comp := True;
6965 Next_Component_Or_Discriminant (Comp);
6969 if Aliased_Comp then
6971 ("cannot apply Volatile_Full_Access (aliased component "
6977 -- Now check appropriateness of the entity
6979 Decl := Declaration_Node (E);
6982 if Rep_Item_Too_Early (E, N)
6984 Rep_Item_Too_Late (E, N)
6988 Check_First_Subtype (Arg1);
6991 -- Attribute belongs on the base type. If the view of the type is
6992 -- currently private, it also belongs on the underlying type.
6994 if Prag_Id = Pragma_Atomic
6996 Prag_Id = Pragma_Shared
6998 Prag_Id = Pragma_Volatile_Full_Access
7001 Set_Atomic_VFA (Base_Type (E));
7002 Set_Atomic_VFA (Underlying_Type (E));
7005 -- Atomic/Shared/Volatile_Full_Access imply Independent
7007 if Prag_Id /= Pragma_Volatile then
7008 Set_Is_Independent (E);
7009 Set_Is_Independent (Base_Type (E));
7010 Set_Is_Independent (Underlying_Type (E));
7012 if Prag_Id = Pragma_Independent then
7013 Record_Independence_Check (N, Base_Type (E));
7017 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7019 if Prag_Id /= Pragma_Independent then
7020 Set_Is_Volatile (E);
7021 Set_Is_Volatile (Base_Type (E));
7022 Set_Is_Volatile (Underlying_Type (E));
7024 Set_Treat_As_Volatile (E);
7025 Set_Treat_As_Volatile (Underlying_Type (E));
7028 elsif Nkind (Decl) = N_Object_Declaration
7029 or else (Nkind (Decl) = N_Component_Declaration
7030 and then Original_Record_Component (E) = E)
7032 if Rep_Item_Too_Late (E, N) then
7036 if Prag_Id = Pragma_Atomic
7038 Prag_Id = Pragma_Shared
7040 Prag_Id = Pragma_Volatile_Full_Access
7042 if Prag_Id = Pragma_Volatile_Full_Access then
7043 Set_Is_Volatile_Full_Access (E);
7048 -- If the object declaration has an explicit initialization, a
7049 -- temporary may have to be created to hold the expression, to
7050 -- ensure that access to the object remain atomic.
7052 if Nkind (Parent (E)) = N_Object_Declaration
7053 and then Present (Expression (Parent (E)))
7055 Set_Has_Delayed_Freeze (E);
7059 -- Atomic/Shared/Volatile_Full_Access imply Independent
7061 if Prag_Id /= Pragma_Volatile then
7062 Set_Is_Independent (E);
7064 if Prag_Id = Pragma_Independent then
7065 Record_Independence_Check (N, E);
7069 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7071 if Prag_Id /= Pragma_Independent then
7072 Set_Is_Volatile (E);
7073 Set_Treat_As_Volatile (E);
7077 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7080 -- The following check is only relevant when SPARK_Mode is on as
7081 -- this is not a standard Ada legality rule. Pragma Volatile can
7082 -- only apply to a full type declaration or an object declaration
7083 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7084 -- untagged derived types that are rewritten as subtypes of their
7085 -- respective root types.
7088 and then Prag_Id = Pragma_Volatile
7090 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
7091 N_Object_Declaration)
7094 ("argument of pragma % must denote a full type or object "
7095 & "declaration", Arg1);
7097 end Process_Atomic_Independent_Shared_Volatile;
7099 -------------------------------------------
7100 -- Process_Compile_Time_Warning_Or_Error --
7101 -------------------------------------------
7103 procedure Process_Compile_Time_Warning_Or_Error is
7104 Validation_Needed : Boolean := False;
7106 function Check_Node (N : Node_Id) return Traverse_Result;
7107 -- Tree visitor that checks if N is an attribute reference that can
7108 -- be statically computed by the back end. Validation_Needed is set
7109 -- to True if found.
7115 function Check_Node (N : Node_Id) return Traverse_Result is
7117 if Nkind (N) = N_Attribute_Reference
7118 and then Is_Entity_Name (Prefix (N))
7121 Attr_Id : constant Attribute_Id :=
7122 Get_Attribute_Id (Attribute_Name (N));
7124 if Attr_Id = Attribute_Alignment
7125 or else Attr_Id = Attribute_Size
7127 Validation_Needed := True;
7135 procedure Check_Expression is new Traverse_Proc (Check_Node);
7139 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7141 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7144 Check_Arg_Count (2);
7145 Check_No_Identifiers;
7146 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7147 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7149 if Compile_Time_Known_Value (Arg1x) then
7150 Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7152 -- Register the expression for its validation after the back end has
7153 -- been called if it has occurrences of attributes Size or Alignment
7154 -- (because they may be statically computed by the back end and hence
7155 -- the whole expression needs to be reevaluated).
7158 Check_Expression (Arg1x);
7160 if Validation_Needed then
7161 Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
7164 end Process_Compile_Time_Warning_Or_Error;
7166 ------------------------
7167 -- Process_Convention --
7168 ------------------------
7170 procedure Process_Convention
7171 (C : out Convention_Id;
7172 Ent : out Entity_Id)
7176 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7177 -- Called if we have more than one Export/Import/Convention pragma.
7178 -- This is generally illegal, but we have a special case of allowing
7179 -- Import and Interface to coexist if they specify the convention in
7180 -- a consistent manner. We are allowed to do this, since Interface is
7181 -- an implementation defined pragma, and we choose to do it since we
7182 -- know Rational allows this combination. S is the entity id of the
7183 -- subprogram in question. This procedure also sets the special flag
7184 -- Import_Interface_Present in both pragmas in the case where we do
7185 -- have matching Import and Interface pragmas.
7187 procedure Set_Convention_From_Pragma (E : Entity_Id);
7188 -- Set convention in entity E, and also flag that the entity has a
7189 -- convention pragma. If entity is for a private or incomplete type,
7190 -- also set convention and flag on underlying type. This procedure
7191 -- also deals with the special case of C_Pass_By_Copy convention,
7192 -- and error checks for inappropriate convention specification.
7194 -------------------------------
7195 -- Diagnose_Multiple_Pragmas --
7196 -------------------------------
7198 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7199 Pdec : constant Node_Id := Declaration_Node (S);
7203 function Same_Convention (Decl : Node_Id) return Boolean;
7204 -- Decl is a pragma node. This function returns True if this
7205 -- pragma has a first argument that is an identifier with a
7206 -- Chars field corresponding to the Convention_Id C.
7208 function Same_Name (Decl : Node_Id) return Boolean;
7209 -- Decl is a pragma node. This function returns True if this
7210 -- pragma has a second argument that is an identifier with a
7211 -- Chars field that matches the Chars of the current subprogram.
7213 ---------------------
7214 -- Same_Convention --
7215 ---------------------
7217 function Same_Convention (Decl : Node_Id) return Boolean is
7218 Arg1 : constant Node_Id :=
7219 First (Pragma_Argument_Associations (Decl));
7222 if Present (Arg1) then
7224 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7226 if Nkind (Arg) = N_Identifier
7227 and then Is_Convention_Name (Chars (Arg))
7228 and then Get_Convention_Id (Chars (Arg)) = C
7236 end Same_Convention;
7242 function Same_Name (Decl : Node_Id) return Boolean is
7243 Arg1 : constant Node_Id :=
7244 First (Pragma_Argument_Associations (Decl));
7252 Arg2 := Next (Arg1);
7259 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7261 if Nkind (Arg) = N_Identifier
7262 and then Chars (Arg) = Chars (S)
7271 -- Start of processing for Diagnose_Multiple_Pragmas
7276 -- Definitely give message if we have Convention/Export here
7278 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7281 -- If we have an Import or Export, scan back from pragma to
7282 -- find any previous pragma applying to the same procedure.
7283 -- The scan will be terminated by the start of the list, or
7284 -- hitting the subprogram declaration. This won't allow one
7285 -- pragma to appear in the public part and one in the private
7286 -- part, but that seems very unlikely in practice.
7290 while Present (Decl) and then Decl /= Pdec loop
7292 -- Look for pragma with same name as us
7294 if Nkind (Decl) = N_Pragma
7295 and then Same_Name (Decl)
7297 -- Give error if same as our pragma or Export/Convention
7299 if Nam_In (Pragma_Name_Unmapped (Decl),
7302 Pragma_Name_Unmapped (N))
7306 -- Case of Import/Interface or the other way round
7308 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7309 Name_Interface, Name_Import)
7311 -- Here we know that we have Import and Interface. It
7312 -- doesn't matter which way round they are. See if
7313 -- they specify the same convention. If so, all OK,
7314 -- and set special flags to stop other messages
7316 if Same_Convention (Decl) then
7317 Set_Import_Interface_Present (N);
7318 Set_Import_Interface_Present (Decl);
7321 -- If different conventions, special message
7324 Error_Msg_Sloc := Sloc (Decl);
7326 ("convention differs from that given#", Arg1);
7336 -- Give message if needed if we fall through those tests
7337 -- except on Relaxed_RM_Semantics where we let go: either this
7338 -- is a case accepted/ignored by other Ada compilers (e.g.
7339 -- a mix of Convention and Import), or another error will be
7340 -- generated later (e.g. using both Import and Export).
7342 if Err and not Relaxed_RM_Semantics then
7344 ("at most one Convention/Export/Import pragma is allowed",
7347 end Diagnose_Multiple_Pragmas;
7349 --------------------------------
7350 -- Set_Convention_From_Pragma --
7351 --------------------------------
7353 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7355 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7356 -- for an overridden dispatching operation. Technically this is
7357 -- an amendment and should only be done in Ada 2005 mode. However,
7358 -- this is clearly a mistake, since the problem that is addressed
7359 -- by this AI is that there is a clear gap in the RM.
7361 if Is_Dispatching_Operation (E)
7362 and then Present (Overridden_Operation (E))
7363 and then C /= Convention (Overridden_Operation (E))
7366 ("cannot change convention for overridden dispatching "
7367 & "operation", Arg1);
7370 -- Special checks for Convention_Stdcall
7372 if C = Convention_Stdcall then
7374 -- A dispatching call is not allowed. A dispatching subprogram
7375 -- cannot be used to interface to the Win32 API, so in fact
7376 -- this check does not impose any effective restriction.
7378 if Is_Dispatching_Operation (E) then
7379 Error_Msg_Sloc := Sloc (E);
7381 -- Note: make this unconditional so that if there is more
7382 -- than one call to which the pragma applies, we get a
7383 -- message for each call. Also don't use Error_Pragma,
7384 -- so that we get multiple messages.
7387 ("dispatching subprogram# cannot use Stdcall convention!",
7390 -- Several allowed cases
7392 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7396 or else Ekind (E) = E_Variable
7398 -- A component as well. The entity does not have its Ekind
7399 -- set until the enclosing record declaration is fully
7402 or else Nkind (Parent (E)) = N_Component_Declaration
7404 -- An access to subprogram is also allowed
7408 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7410 -- Allow internal call to set convention of subprogram type
7412 or else Ekind (E) = E_Subprogram_Type
7418 ("second argument of pragma% must be subprogram (type)",
7423 -- Set the convention
7425 Set_Convention (E, C);
7426 Set_Has_Convention_Pragma (E);
7428 -- For the case of a record base type, also set the convention of
7429 -- any anonymous access types declared in the record which do not
7430 -- currently have a specified convention.
7432 if Is_Record_Type (E) and then Is_Base_Type (E) then
7437 Comp := First_Component (E);
7438 while Present (Comp) loop
7439 if Present (Etype (Comp))
7440 and then Ekind_In (Etype (Comp),
7441 E_Anonymous_Access_Type,
7442 E_Anonymous_Access_Subprogram_Type)
7443 and then not Has_Convention_Pragma (Comp)
7445 Set_Convention (Comp, C);
7448 Next_Component (Comp);
7453 -- Deal with incomplete/private type case, where underlying type
7454 -- is available, so set convention of that underlying type.
7456 if Is_Incomplete_Or_Private_Type (E)
7457 and then Present (Underlying_Type (E))
7459 Set_Convention (Underlying_Type (E), C);
7460 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7463 -- A class-wide type should inherit the convention of the specific
7464 -- root type (although this isn't specified clearly by the RM).
7466 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7467 Set_Convention (Class_Wide_Type (E), C);
7470 -- If the entity is a record type, then check for special case of
7471 -- C_Pass_By_Copy, which is treated the same as C except that the
7472 -- special record flag is set. This convention is only permitted
7473 -- on record types (see AI95-00131).
7475 if Cname = Name_C_Pass_By_Copy then
7476 if Is_Record_Type (E) then
7477 Set_C_Pass_By_Copy (Base_Type (E));
7478 elsif Is_Incomplete_Or_Private_Type (E)
7479 and then Is_Record_Type (Underlying_Type (E))
7481 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7484 ("C_Pass_By_Copy convention allowed only for record type",
7489 -- If the entity is a derived boolean type, check for the special
7490 -- case of convention C, C++, or Fortran, where we consider any
7491 -- nonzero value to represent true.
7493 if Is_Discrete_Type (E)
7494 and then Root_Type (Etype (E)) = Standard_Boolean
7500 C = Convention_Fortran)
7502 Set_Nonzero_Is_True (Base_Type (E));
7504 end Set_Convention_From_Pragma;
7508 Comp_Unit : Unit_Number_Type;
7513 -- Start of processing for Process_Convention
7516 Check_At_Least_N_Arguments (2);
7517 Check_Optional_Identifier (Arg1, Name_Convention);
7518 Check_Arg_Is_Identifier (Arg1);
7519 Cname := Chars (Get_Pragma_Arg (Arg1));
7521 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7522 -- tested again below to set the critical flag).
7524 if Cname = Name_C_Pass_By_Copy then
7527 -- Otherwise we must have something in the standard convention list
7529 elsif Is_Convention_Name (Cname) then
7530 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7532 -- Otherwise warn on unrecognized convention
7535 if Warn_On_Export_Import then
7537 ("??unrecognized convention name, C assumed",
7538 Get_Pragma_Arg (Arg1));
7544 Check_Optional_Identifier (Arg2, Name_Entity);
7545 Check_Arg_Is_Local_Name (Arg2);
7547 Id := Get_Pragma_Arg (Arg2);
7550 if not Is_Entity_Name (Id) then
7551 Error_Pragma_Arg ("entity name required", Arg2);
7556 -- Set entity to return
7560 -- Ada_Pass_By_Copy special checking
7562 if C = Convention_Ada_Pass_By_Copy then
7563 if not Is_First_Subtype (E) then
7565 ("convention `Ada_Pass_By_Copy` only allowed for types",
7569 if Is_By_Reference_Type (E) then
7571 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7575 -- Ada_Pass_By_Reference special checking
7577 elsif C = Convention_Ada_Pass_By_Reference then
7578 if not Is_First_Subtype (E) then
7580 ("convention `Ada_Pass_By_Reference` only allowed for types",
7584 if Is_By_Copy_Type (E) then
7586 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7591 -- Go to renamed subprogram if present, since convention applies to
7592 -- the actual renamed entity, not to the renaming entity. If the
7593 -- subprogram is inherited, go to parent subprogram.
7595 if Is_Subprogram (E)
7596 and then Present (Alias (E))
7598 if Nkind (Parent (Declaration_Node (E))) =
7599 N_Subprogram_Renaming_Declaration
7601 if Scope (E) /= Scope (Alias (E)) then
7603 ("cannot apply pragma% to non-local entity&#", E);
7608 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7609 N_Private_Extension_Declaration)
7610 and then Scope (E) = Scope (Alias (E))
7614 -- Return the parent subprogram the entity was inherited from
7620 -- Check that we are not applying this to a specless body. Relax this
7621 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7623 if Is_Subprogram (E)
7624 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7625 and then not Relaxed_RM_Semantics
7628 ("pragma% requires separate spec and must come before body");
7631 -- Check that we are not applying this to a named constant
7633 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7634 Error_Msg_Name_1 := Pname;
7636 ("cannot apply pragma% to named constant!",
7637 Get_Pragma_Arg (Arg2));
7639 ("\supply appropriate type for&!", Arg2);
7642 if Ekind (E) = E_Enumeration_Literal then
7643 Error_Pragma ("enumeration literal not allowed for pragma%");
7646 -- Check for rep item appearing too early or too late
7648 if Etype (E) = Any_Type
7649 or else Rep_Item_Too_Early (E, N)
7653 elsif Present (Underlying_Type (E)) then
7654 E := Underlying_Type (E);
7657 if Rep_Item_Too_Late (E, N) then
7661 if Has_Convention_Pragma (E) then
7662 Diagnose_Multiple_Pragmas (E);
7664 elsif Convention (E) = Convention_Protected
7665 or else Ekind (Scope (E)) = E_Protected_Type
7668 ("a protected operation cannot be given a different convention",
7672 -- For Intrinsic, a subprogram is required
7674 if C = Convention_Intrinsic
7675 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7677 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7679 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7681 ("second argument of pragma% must be a subprogram", Arg2);
7685 -- Deal with non-subprogram cases
7687 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7688 Set_Convention_From_Pragma (E);
7692 -- The pragma must apply to a first subtype, but it can also
7693 -- apply to a generic type in a generic formal part, in which
7694 -- case it will also appear in the corresponding instance.
7696 if Is_Generic_Type (E) or else In_Instance then
7699 Check_First_Subtype (Arg2);
7702 Set_Convention_From_Pragma (Base_Type (E));
7704 -- For access subprograms, we must set the convention on the
7705 -- internally generated directly designated type as well.
7707 if Ekind (E) = E_Access_Subprogram_Type then
7708 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7712 -- For the subprogram case, set proper convention for all homonyms
7713 -- in same scope and the same declarative part, i.e. the same
7714 -- compilation unit.
7717 Comp_Unit := Get_Source_Unit (E);
7718 Set_Convention_From_Pragma (E);
7720 -- Treat a pragma Import as an implicit body, and pragma import
7721 -- as implicit reference (for navigation in GPS).
7723 if Prag_Id = Pragma_Import then
7724 Generate_Reference (E, Id, 'b');
7726 -- For exported entities we restrict the generation of references
7727 -- to entities exported to foreign languages since entities
7728 -- exported to Ada do not provide further information to GPS and
7729 -- add undesired references to the output of the gnatxref tool.
7731 elsif Prag_Id = Pragma_Export
7732 and then Convention (E) /= Convention_Ada
7734 Generate_Reference (E, Id, 'i');
7737 -- If the pragma comes from an aspect, it only applies to the
7738 -- given entity, not its homonyms.
7740 if From_Aspect_Specification (N) then
7741 if C = Convention_Intrinsic
7742 and then Nkind (Ent) = N_Defining_Operator_Symbol
7744 if Is_Fixed_Point_Type (Etype (Ent))
7745 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
7746 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
7749 ("no intrinsic operator available for this fixed-point "
7752 ("\use expression functions with the desired "
7753 & "conversions made explicit", N);
7760 -- Otherwise Loop through the homonyms of the pragma argument's
7761 -- entity, an apply convention to those in the current scope.
7767 exit when No (E1) or else Scope (E1) /= Current_Scope;
7769 -- Ignore entry for which convention is already set
7771 if Has_Convention_Pragma (E1) then
7775 if Is_Subprogram (E1)
7776 and then Nkind (Parent (Declaration_Node (E1))) =
7778 and then not Relaxed_RM_Semantics
7780 Set_Has_Completion (E); -- to prevent cascaded error
7782 ("pragma% requires separate spec and must come before "
7786 -- Do not set the pragma on inherited operations or on formal
7789 if Comes_From_Source (E1)
7790 and then Comp_Unit = Get_Source_Unit (E1)
7791 and then not Is_Formal_Subprogram (E1)
7792 and then Nkind (Original_Node (Parent (E1))) /=
7793 N_Full_Type_Declaration
7795 if Present (Alias (E1))
7796 and then Scope (E1) /= Scope (Alias (E1))
7799 ("cannot apply pragma% to non-local entity& declared#",
7803 Set_Convention_From_Pragma (E1);
7805 if Prag_Id = Pragma_Import then
7806 Generate_Reference (E1, Id, 'b');
7814 end Process_Convention;
7816 ----------------------------------------
7817 -- Process_Disable_Enable_Atomic_Sync --
7818 ----------------------------------------
7820 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7822 Check_No_Identifiers;
7823 Check_At_Most_N_Arguments (1);
7825 -- Modeled internally as
7826 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7831 Pragma_Argument_Associations => New_List (
7832 Make_Pragma_Argument_Association (Loc,
7834 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7836 if Present (Arg1) then
7837 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7841 end Process_Disable_Enable_Atomic_Sync;
7843 -------------------------------------------------
7844 -- Process_Extended_Import_Export_Internal_Arg --
7845 -------------------------------------------------
7847 procedure Process_Extended_Import_Export_Internal_Arg
7848 (Arg_Internal : Node_Id := Empty)
7851 if No (Arg_Internal) then
7852 Error_Pragma ("Internal parameter required for pragma%");
7855 if Nkind (Arg_Internal) = N_Identifier then
7858 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7859 and then (Prag_Id = Pragma_Import_Function
7861 Prag_Id = Pragma_Export_Function)
7867 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7870 Check_Arg_Is_Local_Name (Arg_Internal);
7871 end Process_Extended_Import_Export_Internal_Arg;
7873 --------------------------------------------------
7874 -- Process_Extended_Import_Export_Object_Pragma --
7875 --------------------------------------------------
7877 procedure Process_Extended_Import_Export_Object_Pragma
7878 (Arg_Internal : Node_Id;
7879 Arg_External : Node_Id;
7885 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7886 Def_Id := Entity (Arg_Internal);
7888 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7890 ("pragma% must designate an object", Arg_Internal);
7893 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7895 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7898 ("previous Common/Psect_Object applies, pragma % not permitted",
7902 if Rep_Item_Too_Late (Def_Id, N) then
7906 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7908 if Present (Arg_Size) then
7909 Check_Arg_Is_External_Name (Arg_Size);
7912 -- Export_Object case
7914 if Prag_Id = Pragma_Export_Object then
7915 if not Is_Library_Level_Entity (Def_Id) then
7917 ("argument for pragma% must be library level entity",
7921 if Ekind (Current_Scope) = E_Generic_Package then
7922 Error_Pragma ("pragma& cannot appear in a generic unit");
7925 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7927 ("exported object must have compile time known size",
7931 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7932 Error_Msg_N ("??duplicate Export_Object pragma", N);
7934 Set_Exported (Def_Id, Arg_Internal);
7937 -- Import_Object case
7940 if Is_Concurrent_Type (Etype (Def_Id)) then
7942 ("cannot use pragma% for task/protected object",
7946 if Ekind (Def_Id) = E_Constant then
7948 ("cannot import a constant", Arg_Internal);
7951 if Warn_On_Export_Import
7952 and then Has_Discriminants (Etype (Def_Id))
7955 ("imported value must be initialized??", Arg_Internal);
7958 if Warn_On_Export_Import
7959 and then Is_Access_Type (Etype (Def_Id))
7962 ("cannot import object of an access type??", Arg_Internal);
7965 if Warn_On_Export_Import
7966 and then Is_Imported (Def_Id)
7968 Error_Msg_N ("??duplicate Import_Object pragma", N);
7970 -- Check for explicit initialization present. Note that an
7971 -- initialization generated by the code generator, e.g. for an
7972 -- access type, does not count here.
7974 elsif Present (Expression (Parent (Def_Id)))
7977 (Original_Node (Expression (Parent (Def_Id))))
7979 Error_Msg_Sloc := Sloc (Def_Id);
7981 ("imported entities cannot be initialized (RM B.1(24))",
7982 "\no initialization allowed for & declared#", Arg1);
7984 Set_Imported (Def_Id);
7985 Note_Possible_Modification (Arg_Internal, Sure => False);
7988 end Process_Extended_Import_Export_Object_Pragma;
7990 ------------------------------------------------------
7991 -- Process_Extended_Import_Export_Subprogram_Pragma --
7992 ------------------------------------------------------
7994 procedure Process_Extended_Import_Export_Subprogram_Pragma
7995 (Arg_Internal : Node_Id;
7996 Arg_External : Node_Id;
7997 Arg_Parameter_Types : Node_Id;
7998 Arg_Result_Type : Node_Id := Empty;
7999 Arg_Mechanism : Node_Id;
8000 Arg_Result_Mechanism : Node_Id := Empty)
8006 Ambiguous : Boolean;
8009 function Same_Base_Type
8011 Formal : Entity_Id) return Boolean;
8012 -- Determines if Ptype references the type of Formal. Note that only
8013 -- the base types need to match according to the spec. Ptype here is
8014 -- the argument from the pragma, which is either a type name, or an
8015 -- access attribute.
8017 --------------------
8018 -- Same_Base_Type --
8019 --------------------
8021 function Same_Base_Type
8023 Formal : Entity_Id) return Boolean
8025 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8029 -- Case where pragma argument is typ'Access
8031 if Nkind (Ptype) = N_Attribute_Reference
8032 and then Attribute_Name (Ptype) = Name_Access
8034 Pref := Prefix (Ptype);
8037 if not Is_Entity_Name (Pref)
8038 or else Entity (Pref) = Any_Type
8043 -- We have a match if the corresponding argument is of an
8044 -- anonymous access type, and its designated type matches the
8045 -- type of the prefix of the access attribute
8047 return Ekind (Ftyp) = E_Anonymous_Access_Type
8048 and then Base_Type (Entity (Pref)) =
8049 Base_Type (Etype (Designated_Type (Ftyp)));
8051 -- Case where pragma argument is a type name
8056 if not Is_Entity_Name (Ptype)
8057 or else Entity (Ptype) = Any_Type
8062 -- We have a match if the corresponding argument is of the type
8063 -- given in the pragma (comparing base types)
8065 return Base_Type (Entity (Ptype)) = Ftyp;
8069 -- Start of processing for
8070 -- Process_Extended_Import_Export_Subprogram_Pragma
8073 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8077 -- Loop through homonyms (overloadings) of the entity
8079 Hom_Id := Entity (Arg_Internal);
8080 while Present (Hom_Id) loop
8081 Def_Id := Get_Base_Subprogram (Hom_Id);
8083 -- We need a subprogram in the current scope
8085 if not Is_Subprogram (Def_Id)
8086 or else Scope (Def_Id) /= Current_Scope
8093 -- Pragma cannot apply to subprogram body
8095 if Is_Subprogram (Def_Id)
8096 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8100 ("pragma% requires separate spec and must come before "
8104 -- Test result type if given, note that the result type
8105 -- parameter can only be present for the function cases.
8107 if Present (Arg_Result_Type)
8108 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8112 elsif Etype (Def_Id) /= Standard_Void_Type
8113 and then Nam_In (Pname, Name_Export_Procedure,
8114 Name_Import_Procedure)
8118 -- Test parameter types if given. Note that this parameter has
8119 -- not been analyzed (and must not be, since it is semantic
8120 -- nonsense), so we get it as the parser left it.
8122 elsif Present (Arg_Parameter_Types) then
8123 Check_Matching_Types : declare
8128 Formal := First_Formal (Def_Id);
8130 if Nkind (Arg_Parameter_Types) = N_Null then
8131 if Present (Formal) then
8135 -- A list of one type, e.g. (List) is parsed as a
8136 -- parenthesized expression.
8138 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8139 and then Paren_Count (Arg_Parameter_Types) = 1
8142 or else Present (Next_Formal (Formal))
8147 Same_Base_Type (Arg_Parameter_Types, Formal);
8150 -- A list of more than one type is parsed as a aggregate
8152 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8153 and then Paren_Count (Arg_Parameter_Types) = 0
8155 Ptype := First (Expressions (Arg_Parameter_Types));
8156 while Present (Ptype) or else Present (Formal) loop
8159 or else not Same_Base_Type (Ptype, Formal)
8164 Next_Formal (Formal);
8169 -- Anything else is of the wrong form
8173 ("wrong form for Parameter_Types parameter",
8174 Arg_Parameter_Types);
8176 end Check_Matching_Types;
8179 -- Match is now False if the entry we found did not match
8180 -- either a supplied Parameter_Types or Result_Types argument
8186 -- Ambiguous case, the flag Ambiguous shows if we already
8187 -- detected this and output the initial messages.
8190 if not Ambiguous then
8192 Error_Msg_Name_1 := Pname;
8194 ("pragma% does not uniquely identify subprogram!",
8196 Error_Msg_Sloc := Sloc (Ent);
8197 Error_Msg_N ("matching subprogram #!", N);
8201 Error_Msg_Sloc := Sloc (Def_Id);
8202 Error_Msg_N ("matching subprogram #!", N);
8207 Hom_Id := Homonym (Hom_Id);
8210 -- See if we found an entry
8213 if not Ambiguous then
8214 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8216 ("pragma% cannot be given for generic subprogram");
8219 ("pragma% does not identify local subprogram");
8226 -- Import pragmas must be for imported entities
8228 if Prag_Id = Pragma_Import_Function
8230 Prag_Id = Pragma_Import_Procedure
8232 Prag_Id = Pragma_Import_Valued_Procedure
8234 if not Is_Imported (Ent) then
8236 ("pragma Import or Interface must precede pragma%");
8239 -- Here we have the Export case which can set the entity as exported
8241 -- But does not do so if the specified external name is null, since
8242 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8243 -- compatible) to request no external name.
8245 elsif Nkind (Arg_External) = N_String_Literal
8246 and then String_Length (Strval (Arg_External)) = 0
8250 -- In all other cases, set entity as exported
8253 Set_Exported (Ent, Arg_Internal);
8256 -- Special processing for Valued_Procedure cases
8258 if Prag_Id = Pragma_Import_Valued_Procedure
8260 Prag_Id = Pragma_Export_Valued_Procedure
8262 Formal := First_Formal (Ent);
8265 Error_Pragma ("at least one parameter required for pragma%");
8267 elsif Ekind (Formal) /= E_Out_Parameter then
8268 Error_Pragma ("first parameter must have mode out for pragma%");
8271 Set_Is_Valued_Procedure (Ent);
8275 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8277 -- Process Result_Mechanism argument if present. We have already
8278 -- checked that this is only allowed for the function case.
8280 if Present (Arg_Result_Mechanism) then
8281 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8284 -- Process Mechanism parameter if present. Note that this parameter
8285 -- is not analyzed, and must not be analyzed since it is semantic
8286 -- nonsense, so we get it in exactly as the parser left it.
8288 if Present (Arg_Mechanism) then
8296 -- A single mechanism association without a formal parameter
8297 -- name is parsed as a parenthesized expression. All other
8298 -- cases are parsed as aggregates, so we rewrite the single
8299 -- parameter case as an aggregate for consistency.
8301 if Nkind (Arg_Mechanism) /= N_Aggregate
8302 and then Paren_Count (Arg_Mechanism) = 1
8304 Rewrite (Arg_Mechanism,
8305 Make_Aggregate (Sloc (Arg_Mechanism),
8306 Expressions => New_List (
8307 Relocate_Node (Arg_Mechanism))));
8310 -- Case of only mechanism name given, applies to all formals
8312 if Nkind (Arg_Mechanism) /= N_Aggregate then
8313 Formal := First_Formal (Ent);
8314 while Present (Formal) loop
8315 Set_Mechanism_Value (Formal, Arg_Mechanism);
8316 Next_Formal (Formal);
8319 -- Case of list of mechanism associations given
8322 if Null_Record_Present (Arg_Mechanism) then
8324 ("inappropriate form for Mechanism parameter",
8328 -- Deal with positional ones first
8330 Formal := First_Formal (Ent);
8332 if Present (Expressions (Arg_Mechanism)) then
8333 Mname := First (Expressions (Arg_Mechanism));
8334 while Present (Mname) loop
8337 ("too many mechanism associations", Mname);
8340 Set_Mechanism_Value (Formal, Mname);
8341 Next_Formal (Formal);
8346 -- Deal with named entries
8348 if Present (Component_Associations (Arg_Mechanism)) then
8349 Massoc := First (Component_Associations (Arg_Mechanism));
8350 while Present (Massoc) loop
8351 Choice := First (Choices (Massoc));
8353 if Nkind (Choice) /= N_Identifier
8354 or else Present (Next (Choice))
8357 ("incorrect form for mechanism association",
8361 Formal := First_Formal (Ent);
8365 ("parameter name & not present", Choice);
8368 if Chars (Choice) = Chars (Formal) then
8370 (Formal, Expression (Massoc));
8372 -- Set entity on identifier (needed by ASIS)
8374 Set_Entity (Choice, Formal);
8379 Next_Formal (Formal);
8388 end Process_Extended_Import_Export_Subprogram_Pragma;
8390 --------------------------
8391 -- Process_Generic_List --
8392 --------------------------
8394 procedure Process_Generic_List is
8399 Check_No_Identifiers;
8400 Check_At_Least_N_Arguments (1);
8402 -- Check all arguments are names of generic units or instances
8405 while Present (Arg) loop
8406 Exp := Get_Pragma_Arg (Arg);
8409 if not Is_Entity_Name (Exp)
8411 (not Is_Generic_Instance (Entity (Exp))
8413 not Is_Generic_Unit (Entity (Exp)))
8416 ("pragma% argument must be name of generic unit/instance",
8422 end Process_Generic_List;
8424 ------------------------------------
8425 -- Process_Import_Predefined_Type --
8426 ------------------------------------
8428 procedure Process_Import_Predefined_Type is
8429 Loc : constant Source_Ptr := Sloc (N);
8431 Ftyp : Node_Id := Empty;
8437 Nam := String_To_Name (Strval (Expression (Arg3)));
8439 Elmt := First_Elmt (Predefined_Float_Types);
8440 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8444 Ftyp := Node (Elmt);
8446 if Present (Ftyp) then
8448 -- Don't build a derived type declaration, because predefined C
8449 -- types have no declaration anywhere, so cannot really be named.
8450 -- Instead build a full type declaration, starting with an
8451 -- appropriate type definition is built
8453 if Is_Floating_Point_Type (Ftyp) then
8454 Def := Make_Floating_Point_Definition (Loc,
8455 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8456 Make_Real_Range_Specification (Loc,
8457 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8458 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8460 -- Should never have a predefined type we cannot handle
8463 raise Program_Error;
8466 -- Build and insert a Full_Type_Declaration, which will be
8467 -- analyzed as soon as this list entry has been analyzed.
8469 Decl := Make_Full_Type_Declaration (Loc,
8470 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8471 Type_Definition => Def);
8473 Insert_After (N, Decl);
8474 Mark_Rewrite_Insertion (Decl);
8477 Error_Pragma_Arg ("no matching type found for pragma%",
8480 end Process_Import_Predefined_Type;
8482 ---------------------------------
8483 -- Process_Import_Or_Interface --
8484 ---------------------------------
8486 procedure Process_Import_Or_Interface is
8492 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8493 -- pragma Import (Entity, "external name");
8495 if Relaxed_RM_Semantics
8496 and then Arg_Count = 2
8497 and then Prag_Id = Pragma_Import
8498 and then Nkind (Expression (Arg2)) = N_String_Literal
8501 Def_Id := Get_Pragma_Arg (Arg1);
8504 if not Is_Entity_Name (Def_Id) then
8505 Error_Pragma_Arg ("entity name required", Arg1);
8508 Def_Id := Entity (Def_Id);
8509 Kill_Size_Check_Code (Def_Id);
8510 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8513 Process_Convention (C, Def_Id);
8515 -- A pragma that applies to a Ghost entity becomes Ghost for the
8516 -- purposes of legality checks and removal of ignored Ghost code.
8518 Mark_Ghost_Pragma (N, Def_Id);
8519 Kill_Size_Check_Code (Def_Id);
8520 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8523 -- Various error checks
8525 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8527 -- We do not permit Import to apply to a renaming declaration
8529 if Present (Renamed_Object (Def_Id)) then
8531 ("pragma% not allowed for object renaming", Arg2);
8533 -- User initialization is not allowed for imported object, but
8534 -- the object declaration may contain a default initialization,
8535 -- that will be discarded. Note that an explicit initialization
8536 -- only counts if it comes from source, otherwise it is simply
8537 -- the code generator making an implicit initialization explicit.
8539 elsif Present (Expression (Parent (Def_Id)))
8540 and then Comes_From_Source
8541 (Original_Node (Expression (Parent (Def_Id))))
8543 -- Set imported flag to prevent cascaded errors
8545 Set_Is_Imported (Def_Id);
8547 Error_Msg_Sloc := Sloc (Def_Id);
8549 ("no initialization allowed for declaration of& #",
8550 "\imported entities cannot be initialized (RM B.1(24))",
8554 -- If the pragma comes from an aspect specification the
8555 -- Is_Imported flag has already been set.
8557 if not From_Aspect_Specification (N) then
8558 Set_Imported (Def_Id);
8561 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8563 -- Note that we do not set Is_Public here. That's because we
8564 -- only want to set it if there is no address clause, and we
8565 -- don't know that yet, so we delay that processing till
8568 -- pragma Import completes deferred constants
8570 if Ekind (Def_Id) = E_Constant then
8571 Set_Has_Completion (Def_Id);
8574 -- It is not possible to import a constant of an unconstrained
8575 -- array type (e.g. string) because there is no simple way to
8576 -- write a meaningful subtype for it.
8578 if Is_Array_Type (Etype (Def_Id))
8579 and then not Is_Constrained (Etype (Def_Id))
8582 ("imported constant& must have a constrained subtype",
8587 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8589 -- If the name is overloaded, pragma applies to all of the denoted
8590 -- entities in the same declarative part, unless the pragma comes
8591 -- from an aspect specification or was generated by the compiler
8592 -- (such as for pragma Provide_Shift_Operators).
8595 while Present (Hom_Id) loop
8597 Def_Id := Get_Base_Subprogram (Hom_Id);
8599 -- Ignore inherited subprograms because the pragma will apply
8600 -- to the parent operation, which is the one called.
8602 if Is_Overloadable (Def_Id)
8603 and then Present (Alias (Def_Id))
8607 -- If it is not a subprogram, it must be in an outer scope and
8608 -- pragma does not apply.
8610 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8613 -- The pragma does not apply to primitives of interfaces
8615 elsif Is_Dispatching_Operation (Def_Id)
8616 and then Present (Find_Dispatching_Type (Def_Id))
8617 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8621 -- Verify that the homonym is in the same declarative part (not
8622 -- just the same scope). If the pragma comes from an aspect
8623 -- specification we know that it is part of the declaration.
8625 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8626 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8627 and then not From_Aspect_Specification (N)
8632 -- If the pragma comes from an aspect specification the
8633 -- Is_Imported flag has already been set.
8635 if not From_Aspect_Specification (N) then
8636 Set_Imported (Def_Id);
8639 -- Reject an Import applied to an abstract subprogram
8641 if Is_Subprogram (Def_Id)
8642 and then Is_Abstract_Subprogram (Def_Id)
8644 Error_Msg_Sloc := Sloc (Def_Id);
8646 ("cannot import abstract subprogram& declared#",
8650 -- Special processing for Convention_Intrinsic
8652 if C = Convention_Intrinsic then
8654 -- Link_Name argument not allowed for intrinsic
8658 Set_Is_Intrinsic_Subprogram (Def_Id);
8660 -- If no external name is present, then check that this
8661 -- is a valid intrinsic subprogram. If an external name
8662 -- is present, then this is handled by the back end.
8665 Check_Intrinsic_Subprogram
8666 (Def_Id, Get_Pragma_Arg (Arg2));
8670 -- Verify that the subprogram does not have a completion
8671 -- through a renaming declaration. For other completions the
8672 -- pragma appears as a too late representation.
8675 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8679 and then Nkind (Decl) = N_Subprogram_Declaration
8680 and then Present (Corresponding_Body (Decl))
8681 and then Nkind (Unit_Declaration_Node
8682 (Corresponding_Body (Decl))) =
8683 N_Subprogram_Renaming_Declaration
8685 Error_Msg_Sloc := Sloc (Def_Id);
8687 ("cannot import&, renaming already provided for "
8688 & "declaration #", N, Def_Id);
8692 -- If the pragma comes from an aspect specification, there
8693 -- must be an Import aspect specified as well. In the rare
8694 -- case where Import is set to False, the suprogram needs to
8695 -- have a local completion.
8698 Imp_Aspect : constant Node_Id :=
8699 Find_Aspect (Def_Id, Aspect_Import);
8703 if Present (Imp_Aspect)
8704 and then Present (Expression (Imp_Aspect))
8706 Expr := Expression (Imp_Aspect);
8707 Analyze_And_Resolve (Expr, Standard_Boolean);
8709 if Is_Entity_Name (Expr)
8710 and then Entity (Expr) = Standard_True
8712 Set_Has_Completion (Def_Id);
8715 -- If there is no expression, the default is True, as for
8716 -- all boolean aspects. Same for the older pragma.
8719 Set_Has_Completion (Def_Id);
8723 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8726 if Is_Compilation_Unit (Hom_Id) then
8728 -- Its possible homonyms are not affected by the pragma.
8729 -- Such homonyms might be present in the context of other
8730 -- units being compiled.
8734 elsif From_Aspect_Specification (N) then
8737 -- If the pragma was created by the compiler, then we don't
8738 -- want it to apply to other homonyms. This kind of case can
8739 -- occur when using pragma Provide_Shift_Operators, which
8740 -- generates implicit shift and rotate operators with Import
8741 -- pragmas that might apply to earlier explicit or implicit
8742 -- declarations marked with Import (for example, coming from
8743 -- an earlier pragma Provide_Shift_Operators for another type),
8744 -- and we don't generally want other homonyms being treated
8745 -- as imported or the pragma flagged as an illegal duplicate.
8747 elsif not Comes_From_Source (N) then
8751 Hom_Id := Homonym (Hom_Id);
8755 -- Import a CPP class
8757 elsif C = Convention_CPP
8758 and then (Is_Record_Type (Def_Id)
8759 or else Ekind (Def_Id) = E_Incomplete_Type)
8761 if Ekind (Def_Id) = E_Incomplete_Type then
8762 if Present (Full_View (Def_Id)) then
8763 Def_Id := Full_View (Def_Id);
8767 ("cannot import 'C'P'P type before full declaration seen",
8768 Get_Pragma_Arg (Arg2));
8770 -- Although we have reported the error we decorate it as
8771 -- CPP_Class to avoid reporting spurious errors
8773 Set_Is_CPP_Class (Def_Id);
8778 -- Types treated as CPP classes must be declared limited (note:
8779 -- this used to be a warning but there is no real benefit to it
8780 -- since we did effectively intend to treat the type as limited
8783 if not Is_Limited_Type (Def_Id) then
8785 ("imported 'C'P'P type must be limited",
8786 Get_Pragma_Arg (Arg2));
8789 if Etype (Def_Id) /= Def_Id
8790 and then not Is_CPP_Class (Root_Type (Def_Id))
8792 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8795 Set_Is_CPP_Class (Def_Id);
8797 -- Imported CPP types must not have discriminants (because C++
8798 -- classes do not have discriminants).
8800 if Has_Discriminants (Def_Id) then
8802 ("imported 'C'P'P type cannot have discriminants",
8803 First (Discriminant_Specifications
8804 (Declaration_Node (Def_Id))));
8807 -- Check that components of imported CPP types do not have default
8808 -- expressions. For private types this check is performed when the
8809 -- full view is analyzed (see Process_Full_View).
8811 if not Is_Private_Type (Def_Id) then
8812 Check_CPP_Type_Has_No_Defaults (Def_Id);
8815 -- Import a CPP exception
8817 elsif C = Convention_CPP
8818 and then Ekind (Def_Id) = E_Exception
8822 ("'External_'Name arguments is required for 'Cpp exception",
8825 -- As only a string is allowed, Check_Arg_Is_External_Name
8828 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8831 if Present (Arg4) then
8833 ("Link_Name argument not allowed for imported Cpp exception",
8837 -- Do not call Set_Interface_Name as the name of the exception
8838 -- shouldn't be modified (and in particular it shouldn't be
8839 -- the External_Name). For exceptions, the External_Name is the
8840 -- name of the RTTI structure.
8842 -- ??? Emit an error if pragma Import/Export_Exception is present
8844 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8846 Check_Arg_Count (3);
8847 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8849 Process_Import_Predefined_Type;
8853 ("second argument of pragma% must be object, subprogram "
8854 & "or incomplete type",
8858 -- If this pragma applies to a compilation unit, then the unit, which
8859 -- is a subprogram, does not require (or allow) a body. We also do
8860 -- not need to elaborate imported procedures.
8862 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8864 Cunit : constant Node_Id := Parent (Parent (N));
8866 Set_Body_Required (Cunit, False);
8869 end Process_Import_Or_Interface;
8871 --------------------
8872 -- Process_Inline --
8873 --------------------
8875 procedure Process_Inline (Status : Inline_Status) is
8882 Ghost_Error_Posted : Boolean := False;
8883 -- Flag set when an error concerning the illegal mix of Ghost and
8884 -- non-Ghost subprograms is emitted.
8886 Ghost_Id : Entity_Id := Empty;
8887 -- The entity of the first Ghost subprogram encountered while
8888 -- processing the arguments of the pragma.
8890 procedure Make_Inline (Subp : Entity_Id);
8891 -- Subp is the defining unit name of the subprogram declaration. If
8892 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8893 -- the corresponding body, if there is one present.
8895 procedure Set_Inline_Flags (Subp : Entity_Id);
8896 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8897 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8899 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8900 -- Returns True if it can be determined at this stage that inlining
8901 -- is not possible, for example if the body is available and contains
8902 -- exception handlers, we prevent inlining, since otherwise we can
8903 -- get undefined symbols at link time. This function also emits a
8904 -- warning if the pragma appears too late.
8906 -- ??? is business with link symbols still valid, or does it relate
8907 -- to front end ZCX which is being phased out ???
8909 ---------------------------
8910 -- Inlining_Not_Possible --
8911 ---------------------------
8913 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8914 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8918 if Nkind (Decl) = N_Subprogram_Body then
8919 Stats := Handled_Statement_Sequence (Decl);
8920 return Present (Exception_Handlers (Stats))
8921 or else Present (At_End_Proc (Stats));
8923 elsif Nkind (Decl) = N_Subprogram_Declaration
8924 and then Present (Corresponding_Body (Decl))
8926 if Analyzed (Corresponding_Body (Decl)) then
8927 Error_Msg_N ("pragma appears too late, ignored??", N);
8930 -- If the subprogram is a renaming as body, the body is just a
8931 -- call to the renamed subprogram, and inlining is trivially
8935 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8936 N_Subprogram_Renaming_Declaration
8942 Handled_Statement_Sequence
8943 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8946 Present (Exception_Handlers (Stats))
8947 or else Present (At_End_Proc (Stats));
8951 -- If body is not available, assume the best, the check is
8952 -- performed again when compiling enclosing package bodies.
8956 end Inlining_Not_Possible;
8962 procedure Make_Inline (Subp : Entity_Id) is
8963 Kind : constant Entity_Kind := Ekind (Subp);
8964 Inner_Subp : Entity_Id := Subp;
8967 -- Ignore if bad type, avoid cascaded error
8969 if Etype (Subp) = Any_Type then
8973 -- If inlining is not possible, for now do not treat as an error
8975 elsif Status /= Suppressed
8976 and then Front_End_Inlining
8977 and then Inlining_Not_Possible (Subp)
8982 -- Here we have a candidate for inlining, but we must exclude
8983 -- derived operations. Otherwise we would end up trying to inline
8984 -- a phantom declaration, and the result would be to drag in a
8985 -- body which has no direct inlining associated with it. That
8986 -- would not only be inefficient but would also result in the
8987 -- backend doing cross-unit inlining in cases where it was
8988 -- definitely inappropriate to do so.
8990 -- However, a simple Comes_From_Source test is insufficient, since
8991 -- we do want to allow inlining of generic instances which also do
8992 -- not come from source. We also need to recognize specs generated
8993 -- by the front-end for bodies that carry the pragma. Finally,
8994 -- predefined operators do not come from source but are not
8995 -- inlineable either.
8997 elsif Is_Generic_Instance (Subp)
8998 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9002 elsif not Comes_From_Source (Subp)
9003 and then Scope (Subp) /= Standard_Standard
9009 -- The referenced entity must either be the enclosing entity, or
9010 -- an entity declared within the current open scope.
9012 if Present (Scope (Subp))
9013 and then Scope (Subp) /= Current_Scope
9014 and then Subp /= Current_Scope
9017 ("argument of% must be entity in current scope", Assoc);
9021 -- Processing for procedure, operator or function. If subprogram
9022 -- is aliased (as for an instance) indicate that the renamed
9023 -- entity (if declared in the same unit) is inlined.
9024 -- If this is the anonymous subprogram created for a subprogram
9025 -- instance, the inlining applies to it directly. Otherwise we
9026 -- retrieve it as the alias of the visible subprogram instance.
9028 if Is_Subprogram (Subp) then
9029 if Is_Wrapper_Package (Scope (Subp)) then
9032 Inner_Subp := Ultimate_Alias (Inner_Subp);
9035 if In_Same_Source_Unit (Subp, Inner_Subp) then
9036 Set_Inline_Flags (Inner_Subp);
9038 Decl := Parent (Parent (Inner_Subp));
9040 if Nkind (Decl) = N_Subprogram_Declaration
9041 and then Present (Corresponding_Body (Decl))
9043 Set_Inline_Flags (Corresponding_Body (Decl));
9045 elsif Is_Generic_Instance (Subp)
9046 and then Comes_From_Source (Subp)
9048 -- Indicate that the body needs to be created for
9049 -- inlining subsequent calls. The instantiation node
9050 -- follows the declaration of the wrapper package
9051 -- created for it. The subprogram that requires the
9052 -- body is the anonymous one in the wrapper package.
9054 if Scope (Subp) /= Standard_Standard
9056 Need_Subprogram_Instance_Body
9057 (Next (Unit_Declaration_Node
9058 (Scope (Alias (Subp)))), Subp)
9063 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9064 -- appear in a formal part to apply to a formal subprogram.
9065 -- Do not apply check within an instance or a formal package
9066 -- the test will have been applied to the original generic.
9068 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9069 and then List_Containing (Decl) = List_Containing (N)
9070 and then not In_Instance
9073 ("Inline cannot apply to a formal subprogram", N);
9075 -- If Subp is a renaming, it is the renamed entity that
9076 -- will appear in any call, and be inlined. However, for
9077 -- ASIS uses it is convenient to indicate that the renaming
9078 -- itself is an inlined subprogram, so that some gnatcheck
9079 -- rules can be applied in the absence of expansion.
9081 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9082 Set_Inline_Flags (Subp);
9088 -- For a generic subprogram set flag as well, for use at the point
9089 -- of instantiation, to determine whether the body should be
9092 elsif Is_Generic_Subprogram (Subp) then
9093 Set_Inline_Flags (Subp);
9096 -- Literals are by definition inlined
9098 elsif Kind = E_Enumeration_Literal then
9101 -- Anything else is an error
9105 ("expect subprogram name for pragma%", Assoc);
9109 ----------------------
9110 -- Set_Inline_Flags --
9111 ----------------------
9113 procedure Set_Inline_Flags (Subp : Entity_Id) is
9115 -- First set the Has_Pragma_XXX flags and issue the appropriate
9116 -- errors and warnings for suspicious combinations.
9118 if Prag_Id = Pragma_No_Inline then
9119 if Has_Pragma_Inline_Always (Subp) then
9121 ("Inline_Always and No_Inline are mutually exclusive", N);
9122 elsif Has_Pragma_Inline (Subp) then
9124 ("Inline and No_Inline both specified for& ??",
9125 N, Entity (Subp_Id));
9128 Set_Has_Pragma_No_Inline (Subp);
9130 if Prag_Id = Pragma_Inline_Always then
9131 if Has_Pragma_No_Inline (Subp) then
9133 ("Inline_Always and No_Inline are mutually exclusive",
9137 Set_Has_Pragma_Inline_Always (Subp);
9139 if Has_Pragma_No_Inline (Subp) then
9141 ("Inline and No_Inline both specified for& ??",
9142 N, Entity (Subp_Id));
9146 Set_Has_Pragma_Inline (Subp);
9149 -- Then adjust the Is_Inlined flag. It can never be set if the
9150 -- subprogram is subject to pragma No_Inline.
9154 Set_Is_Inlined (Subp, False);
9160 if not Has_Pragma_No_Inline (Subp) then
9161 Set_Is_Inlined (Subp, True);
9165 -- A pragma that applies to a Ghost entity becomes Ghost for the
9166 -- purposes of legality checks and removal of ignored Ghost code.
9168 Mark_Ghost_Pragma (N, Subp);
9170 -- Capture the entity of the first Ghost subprogram being
9171 -- processed for error detection purposes.
9173 if Is_Ghost_Entity (Subp) then
9174 if No (Ghost_Id) then
9178 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9179 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9181 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9182 Ghost_Error_Posted := True;
9184 Error_Msg_Name_1 := Pname;
9186 ("pragma % cannot mention ghost and non-ghost subprograms",
9189 Error_Msg_Sloc := Sloc (Ghost_Id);
9190 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9192 Error_Msg_Sloc := Sloc (Subp);
9193 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9195 end Set_Inline_Flags;
9197 -- Start of processing for Process_Inline
9200 Check_No_Identifiers;
9201 Check_At_Least_N_Arguments (1);
9203 if Status = Enabled then
9204 Inline_Processing_Required := True;
9208 while Present (Assoc) loop
9209 Subp_Id := Get_Pragma_Arg (Assoc);
9213 if Is_Entity_Name (Subp_Id) then
9214 Subp := Entity (Subp_Id);
9216 if Subp = Any_Id then
9218 -- If previous error, avoid cascaded errors
9220 Check_Error_Detected;
9226 -- For the pragma case, climb homonym chain. This is
9227 -- what implements allowing the pragma in the renaming
9228 -- case, with the result applying to the ancestors, and
9229 -- also allows Inline to apply to all previous homonyms.
9231 if not From_Aspect_Specification (N) then
9232 while Present (Homonym (Subp))
9233 and then Scope (Homonym (Subp)) = Current_Scope
9235 Make_Inline (Homonym (Subp));
9236 Subp := Homonym (Subp);
9243 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9249 -- If the context is a package declaration, the pragma indicates
9250 -- that inlining will require the presence of the corresponding
9251 -- body. (this may be further refined).
9254 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9255 N_Package_Declaration
9257 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9261 ----------------------------
9262 -- Process_Interface_Name --
9263 ----------------------------
9265 procedure Process_Interface_Name
9266 (Subprogram_Def : Entity_Id;
9273 String_Val : String_Id;
9275 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9276 -- SN is a string literal node for an interface name. This routine
9277 -- performs some minimal checks that the name is reasonable. In
9278 -- particular that no spaces or other obviously incorrect characters
9279 -- appear. This is only a warning, since any characters are allowed.
9281 ----------------------------------
9282 -- Check_Form_Of_Interface_Name --
9283 ----------------------------------
9285 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9286 S : constant String_Id := Strval (Expr_Value_S (SN));
9287 SL : constant Nat := String_Length (S);
9292 Error_Msg_N ("interface name cannot be null string", SN);
9295 for J in 1 .. SL loop
9296 C := Get_String_Char (S, J);
9298 -- Look for dubious character and issue unconditional warning.
9299 -- Definitely dubious if not in character range.
9301 if not In_Character_Range (C)
9303 -- Commas, spaces and (back)slashes are dubious
9305 or else Get_Character (C) = ','
9306 or else Get_Character (C) = '\'
9307 or else Get_Character (C) = ' '
9308 or else Get_Character (C) = '/'
9311 ("??interface name contains illegal character",
9312 Sloc (SN) + Source_Ptr (J));
9315 end Check_Form_Of_Interface_Name;
9317 -- Start of processing for Process_Interface_Name
9320 -- If we are looking at a pragma that comes from an aspect then it
9321 -- needs to have its corresponding aspect argument expressions
9322 -- analyzed in addition to the generated pragma so that aspects
9323 -- within generic units get properly resolved.
9325 if Present (Prag) and then From_Aspect_Specification (Prag) then
9327 Asp : constant Node_Id := Corresponding_Aspect (Prag);
9335 -- Obtain all interfacing aspects used to construct the pragma
9337 Get_Interfacing_Aspects
9338 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
9340 -- Analyze the expression of aspect External_Name
9342 if Present (EN) then
9343 Analyze (Expression (EN));
9346 -- Analyze the expressio of aspect Link_Name
9348 if Present (LN) then
9349 Analyze (Expression (LN));
9354 if No (Link_Arg) then
9355 if No (Ext_Arg) then
9358 elsif Chars (Ext_Arg) = Name_Link_Name then
9360 Link_Nam := Expression (Ext_Arg);
9363 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9364 Ext_Nam := Expression (Ext_Arg);
9369 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9370 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9371 Ext_Nam := Expression (Ext_Arg);
9372 Link_Nam := Expression (Link_Arg);
9375 -- Check expressions for external name and link name are static
9377 if Present (Ext_Nam) then
9378 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9379 Check_Form_Of_Interface_Name (Ext_Nam);
9381 -- Verify that external name is not the name of a local entity,
9382 -- which would hide the imported one and could lead to run-time
9383 -- surprises. The problem can only arise for entities declared in
9384 -- a package body (otherwise the external name is fully qualified
9385 -- and will not conflict).
9393 if Prag_Id = Pragma_Import then
9394 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
9395 E := Entity_Id (Get_Name_Table_Int (Nam));
9397 if Nam /= Chars (Subprogram_Def)
9398 and then Present (E)
9399 and then not Is_Overloadable (E)
9400 and then Is_Immediately_Visible (E)
9401 and then not Is_Imported (E)
9402 and then Ekind (Scope (E)) = E_Package
9405 while Present (Par) loop
9406 if Nkind (Par) = N_Package_Body then
9407 Error_Msg_Sloc := Sloc (E);
9409 ("imported entity is hidden by & declared#",
9414 Par := Parent (Par);
9421 if Present (Link_Nam) then
9422 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9423 Check_Form_Of_Interface_Name (Link_Nam);
9426 -- If there is no link name, just set the external name
9428 if No (Link_Nam) then
9429 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9431 -- For the Link_Name case, the given literal is preceded by an
9432 -- asterisk, which indicates to GCC that the given name should be
9433 -- taken literally, and in particular that no prepending of
9434 -- underlines should occur, even in systems where this is the
9439 Store_String_Char (Get_Char_Code ('*'));
9440 String_Val := Strval (Expr_Value_S (Link_Nam));
9441 Store_String_Chars (String_Val);
9443 Make_String_Literal (Sloc (Link_Nam),
9444 Strval => End_String);
9447 -- Set the interface name. If the entity is a generic instance, use
9448 -- its alias, which is the callable entity.
9450 if Is_Generic_Instance (Subprogram_Def) then
9451 Set_Encoded_Interface_Name
9452 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9454 Set_Encoded_Interface_Name
9455 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9458 Check_Duplicated_Export_Name (Link_Nam);
9459 end Process_Interface_Name;
9461 -----------------------------------------
9462 -- Process_Interrupt_Or_Attach_Handler --
9463 -----------------------------------------
9465 procedure Process_Interrupt_Or_Attach_Handler is
9466 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9467 Prot_Typ : constant Entity_Id := Scope (Handler);
9470 -- A pragma that applies to a Ghost entity becomes Ghost for the
9471 -- purposes of legality checks and removal of ignored Ghost code.
9473 Mark_Ghost_Pragma (N, Handler);
9474 Set_Is_Interrupt_Handler (Handler);
9476 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9478 Record_Rep_Item (Prot_Typ, N);
9480 -- Chain the pragma on the contract for completeness
9482 Add_Contract_Item (N, Handler);
9483 end Process_Interrupt_Or_Attach_Handler;
9485 --------------------------------------------------
9486 -- Process_Restrictions_Or_Restriction_Warnings --
9487 --------------------------------------------------
9489 -- Note: some of the simple identifier cases were handled in par-prag,
9490 -- but it is harmless (and more straightforward) to simply handle all
9491 -- cases here, even if it means we repeat a bit of work in some cases.
9493 procedure Process_Restrictions_Or_Restriction_Warnings
9497 R_Id : Restriction_Id;
9503 -- Ignore all Restrictions pragmas in CodePeer mode
9505 if CodePeer_Mode then
9509 Check_Ada_83_Warning;
9510 Check_At_Least_N_Arguments (1);
9511 Check_Valid_Configuration_Pragma;
9514 while Present (Arg) loop
9516 Expr := Get_Pragma_Arg (Arg);
9518 -- Case of no restriction identifier present
9520 if Id = No_Name then
9521 if Nkind (Expr) /= N_Identifier then
9523 ("invalid form for restriction", Arg);
9528 (Process_Restriction_Synonyms (Expr));
9530 if R_Id not in All_Boolean_Restrictions then
9531 Error_Msg_Name_1 := Pname;
9533 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9535 -- Check for possible misspelling
9537 for J in Restriction_Id loop
9539 Rnm : constant String := Restriction_Id'Image (J);
9542 Name_Buffer (1 .. Rnm'Length) := Rnm;
9543 Name_Len := Rnm'Length;
9544 Set_Casing (All_Lower_Case);
9546 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9549 (Source_Index (Current_Sem_Unit)));
9550 Error_Msg_String (1 .. Rnm'Length) :=
9551 Name_Buffer (1 .. Name_Len);
9552 Error_Msg_Strlen := Rnm'Length;
9553 Error_Msg_N -- CODEFIX
9554 ("\possible misspelling of ""~""",
9555 Get_Pragma_Arg (Arg));
9564 if Implementation_Restriction (R_Id) then
9565 Check_Restriction (No_Implementation_Restrictions, Arg);
9568 -- Special processing for No_Elaboration_Code restriction
9570 if R_Id = No_Elaboration_Code then
9572 -- Restriction is only recognized within a configuration
9573 -- pragma file, or within a unit of the main extended
9574 -- program. Note: the test for Main_Unit is needed to
9575 -- properly include the case of configuration pragma files.
9577 if not (Current_Sem_Unit = Main_Unit
9578 or else In_Extended_Main_Source_Unit (N))
9582 -- Don't allow in a subunit unless already specified in
9585 elsif Nkind (Parent (N)) = N_Compilation_Unit
9586 and then Nkind (Unit (Parent (N))) = N_Subunit
9587 and then not Restriction_Active (No_Elaboration_Code)
9590 ("invalid specification of ""No_Elaboration_Code""",
9593 ("\restriction cannot be specified in a subunit", N);
9595 ("\unless also specified in body or spec", N);
9598 -- If we accept a No_Elaboration_Code restriction, then it
9599 -- needs to be added to the configuration restriction set so
9600 -- that we get proper application to other units in the main
9601 -- extended source as required.
9604 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9608 -- If this is a warning, then set the warning unless we already
9609 -- have a real restriction active (we never want a warning to
9610 -- override a real restriction).
9613 if not Restriction_Active (R_Id) then
9614 Set_Restriction (R_Id, N);
9615 Restriction_Warnings (R_Id) := True;
9618 -- If real restriction case, then set it and make sure that the
9619 -- restriction warning flag is off, since a real restriction
9620 -- always overrides a warning.
9623 Set_Restriction (R_Id, N);
9624 Restriction_Warnings (R_Id) := False;
9627 -- Check for obsolescent restrictions in Ada 2005 mode
9630 and then Ada_Version >= Ada_2005
9631 and then (R_Id = No_Asynchronous_Control
9633 R_Id = No_Unchecked_Deallocation
9635 R_Id = No_Unchecked_Conversion)
9637 Check_Restriction (No_Obsolescent_Features, N);
9640 -- A very special case that must be processed here: pragma
9641 -- Restrictions (No_Exceptions) turns off all run-time
9642 -- checking. This is a bit dubious in terms of the formal
9643 -- language definition, but it is what is intended by RM
9644 -- H.4(12). Restriction_Warnings never affects generated code
9645 -- so this is done only in the real restriction case.
9647 -- Atomic_Synchronization is not a real check, so it is not
9648 -- affected by this processing).
9650 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9651 -- run-time checks in CodePeer and GNATprove modes: we want to
9652 -- generate checks for analysis purposes, as set respectively
9653 -- by -gnatC and -gnatd.F
9656 and then not (CodePeer_Mode or GNATprove_Mode)
9657 and then R_Id = No_Exceptions
9659 for J in Scope_Suppress.Suppress'Range loop
9660 if J /= Atomic_Synchronization then
9661 Scope_Suppress.Suppress (J) := True;
9666 -- Case of No_Dependence => unit-name. Note that the parser
9667 -- already made the necessary entry in the No_Dependence table.
9669 elsif Id = Name_No_Dependence then
9670 if not OK_No_Dependence_Unit_Name (Expr) then
9674 -- Case of No_Specification_Of_Aspect => aspect-identifier
9676 elsif Id = Name_No_Specification_Of_Aspect then
9681 if Nkind (Expr) /= N_Identifier then
9684 A_Id := Get_Aspect_Id (Chars (Expr));
9687 if A_Id = No_Aspect then
9688 Error_Pragma_Arg ("invalid restriction name", Arg);
9690 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9694 -- Case of No_Use_Of_Attribute => attribute-identifier
9696 elsif Id = Name_No_Use_Of_Attribute then
9697 if Nkind (Expr) /= N_Identifier
9698 or else not Is_Attribute_Name (Chars (Expr))
9700 Error_Msg_N ("unknown attribute name??", Expr);
9703 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9706 -- Case of No_Use_Of_Entity => fully-qualified-name
9708 elsif Id = Name_No_Use_Of_Entity then
9710 -- Restriction is only recognized within a configuration
9711 -- pragma file, or within a unit of the main extended
9712 -- program. Note: the test for Main_Unit is needed to
9713 -- properly include the case of configuration pragma files.
9715 if Current_Sem_Unit = Main_Unit
9716 or else In_Extended_Main_Source_Unit (N)
9718 if not OK_No_Dependence_Unit_Name (Expr) then
9719 Error_Msg_N ("wrong form for entity name", Expr);
9721 Set_Restriction_No_Use_Of_Entity
9722 (Expr, Warn, No_Profile);
9726 -- Case of No_Use_Of_Pragma => pragma-identifier
9728 elsif Id = Name_No_Use_Of_Pragma then
9729 if Nkind (Expr) /= N_Identifier
9730 or else not Is_Pragma_Name (Chars (Expr))
9732 Error_Msg_N ("unknown pragma name??", Expr);
9734 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9737 -- All other cases of restriction identifier present
9740 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9741 Analyze_And_Resolve (Expr, Any_Integer);
9743 if R_Id not in All_Parameter_Restrictions then
9745 ("invalid restriction parameter identifier", Arg);
9747 elsif not Is_OK_Static_Expression (Expr) then
9748 Flag_Non_Static_Expr
9749 ("value must be static expression!", Expr);
9752 elsif not Is_Integer_Type (Etype (Expr))
9753 or else Expr_Value (Expr) < 0
9756 ("value must be non-negative integer", Arg);
9759 -- Restriction pragma is active
9761 Val := Expr_Value (Expr);
9763 if not UI_Is_In_Int_Range (Val) then
9765 ("pragma ignored, value too large??", Arg);
9768 -- Warning case. If the real restriction is active, then we
9769 -- ignore the request, since warning never overrides a real
9770 -- restriction. Otherwise we set the proper warning. Note that
9771 -- this circuit sets the warning again if it is already set,
9772 -- which is what we want, since the constant may have changed.
9775 if not Restriction_Active (R_Id) then
9777 (R_Id, N, Integer (UI_To_Int (Val)));
9778 Restriction_Warnings (R_Id) := True;
9781 -- Real restriction case, set restriction and make sure warning
9782 -- flag is off since real restriction always overrides warning.
9785 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9786 Restriction_Warnings (R_Id) := False;
9792 end Process_Restrictions_Or_Restriction_Warnings;
9794 ---------------------------------
9795 -- Process_Suppress_Unsuppress --
9796 ---------------------------------
9798 -- Note: this procedure makes entries in the check suppress data
9799 -- structures managed by Sem. See spec of package Sem for full
9800 -- details on how we handle recording of check suppression.
9802 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9807 In_Package_Spec : constant Boolean :=
9808 Is_Package_Or_Generic_Package (Current_Scope)
9809 and then not In_Package_Body (Current_Scope);
9811 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9812 -- Used to suppress a single check on the given entity
9814 --------------------------------
9815 -- Suppress_Unsuppress_Echeck --
9816 --------------------------------
9818 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9820 -- Check for error of trying to set atomic synchronization for
9821 -- a non-atomic variable.
9823 if C = Atomic_Synchronization
9824 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9827 ("pragma & requires atomic type or variable",
9828 Pragma_Identifier (Original_Node (N)));
9831 Set_Checks_May_Be_Suppressed (E);
9833 if In_Package_Spec then
9834 Push_Global_Suppress_Stack_Entry
9837 Suppress => Suppress_Case);
9839 Push_Local_Suppress_Stack_Entry
9842 Suppress => Suppress_Case);
9845 -- If this is a first subtype, and the base type is distinct,
9846 -- then also set the suppress flags on the base type.
9848 if Is_First_Subtype (E) and then Etype (E) /= E then
9849 Suppress_Unsuppress_Echeck (Etype (E), C);
9851 end Suppress_Unsuppress_Echeck;
9853 -- Start of processing for Process_Suppress_Unsuppress
9856 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9857 -- on user code: we want to generate checks for analysis purposes, as
9858 -- set respectively by -gnatC and -gnatd.F
9860 if Comes_From_Source (N)
9861 and then (CodePeer_Mode or GNATprove_Mode)
9866 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9867 -- declarative part or a package spec (RM 11.5(5)).
9869 if not Is_Configuration_Pragma then
9870 Check_Is_In_Decl_Part_Or_Package_Spec;
9873 Check_At_Least_N_Arguments (1);
9874 Check_At_Most_N_Arguments (2);
9875 Check_No_Identifier (Arg1);
9876 Check_Arg_Is_Identifier (Arg1);
9878 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9880 if C = No_Check_Id then
9882 ("argument of pragma% is not valid check name", Arg1);
9885 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9887 if C = Elaboration_Check and then SPARK_Mode = On then
9889 ("Suppress of Elaboration_Check ignored in SPARK??",
9890 "\elaboration checking rules are statically enforced "
9891 & "(SPARK RM 7.7)", Arg1);
9894 -- One-argument case
9896 if Arg_Count = 1 then
9898 -- Make an entry in the local scope suppress table. This is the
9899 -- table that directly shows the current value of the scope
9900 -- suppress check for any check id value.
9902 if C = All_Checks then
9904 -- For All_Checks, we set all specific predefined checks with
9905 -- the exception of Elaboration_Check, which is handled
9906 -- specially because of not wanting All_Checks to have the
9907 -- effect of deactivating static elaboration order processing.
9908 -- Atomic_Synchronization is also not affected, since this is
9909 -- not a real check.
9911 for J in Scope_Suppress.Suppress'Range loop
9912 if J /= Elaboration_Check
9914 J /= Atomic_Synchronization
9916 Scope_Suppress.Suppress (J) := Suppress_Case;
9920 -- If not All_Checks, and predefined check, then set appropriate
9921 -- scope entry. Note that we will set Elaboration_Check if this
9922 -- is explicitly specified. Atomic_Synchronization is allowed
9923 -- only if internally generated and entity is atomic.
9925 elsif C in Predefined_Check_Id
9926 and then (not Comes_From_Source (N)
9927 or else C /= Atomic_Synchronization)
9929 Scope_Suppress.Suppress (C) := Suppress_Case;
9932 -- Also make an entry in the Local_Entity_Suppress table
9934 Push_Local_Suppress_Stack_Entry
9937 Suppress => Suppress_Case);
9939 -- Case of two arguments present, where the check is suppressed for
9940 -- a specified entity (given as the second argument of the pragma)
9943 -- This is obsolescent in Ada 2005 mode
9945 if Ada_Version >= Ada_2005 then
9946 Check_Restriction (No_Obsolescent_Features, Arg2);
9949 Check_Optional_Identifier (Arg2, Name_On);
9950 E_Id := Get_Pragma_Arg (Arg2);
9953 if not Is_Entity_Name (E_Id) then
9955 ("second argument of pragma% must be entity name", Arg2);
9964 -- A pragma that applies to a Ghost entity becomes Ghost for the
9965 -- purposes of legality checks and removal of ignored Ghost code.
9967 Mark_Ghost_Pragma (N, E);
9969 -- Enforce RM 11.5(7) which requires that for a pragma that
9970 -- appears within a package spec, the named entity must be
9971 -- within the package spec. We allow the package name itself
9972 -- to be mentioned since that makes sense, although it is not
9973 -- strictly allowed by 11.5(7).
9976 and then E /= Current_Scope
9977 and then Scope (E) /= Current_Scope
9980 ("entity in pragma% is not in package spec (RM 11.5(7))",
9984 -- Loop through homonyms. As noted below, in the case of a package
9985 -- spec, only homonyms within the package spec are considered.
9988 Suppress_Unsuppress_Echeck (E, C);
9990 if Is_Generic_Instance (E)
9991 and then Is_Subprogram (E)
9992 and then Present (Alias (E))
9994 Suppress_Unsuppress_Echeck (Alias (E), C);
9997 -- Move to next homonym if not aspect spec case
9999 exit when From_Aspect_Specification (N);
10003 -- If we are within a package specification, the pragma only
10004 -- applies to homonyms in the same scope.
10006 exit when In_Package_Spec
10007 and then Scope (E) /= Current_Scope;
10010 end Process_Suppress_Unsuppress;
10012 -------------------------------
10013 -- Record_Independence_Check --
10014 -------------------------------
10016 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10018 -- For GCC back ends the validation is done a priori
10020 if not AAMP_On_Target then
10024 Independence_Checks.Append ((N, E));
10025 end Record_Independence_Check;
10031 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10033 if Is_Imported (E) then
10035 ("cannot export entity& that was previously imported", Arg);
10037 elsif Present (Address_Clause (E))
10038 and then not Relaxed_RM_Semantics
10041 ("cannot export entity& that has an address clause", Arg);
10044 Set_Is_Exported (E);
10046 -- Generate a reference for entity explicitly, because the
10047 -- identifier may be overloaded and name resolution will not
10050 Generate_Reference (E, Arg);
10052 -- Deal with exporting non-library level entity
10054 if not Is_Library_Level_Entity (E) then
10056 -- Not allowed at all for subprograms
10058 if Is_Subprogram (E) then
10059 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10061 -- Otherwise set public and statically allocated
10065 Set_Is_Statically_Allocated (E);
10067 -- Warn if the corresponding W flag is set
10069 if Warn_On_Export_Import
10071 -- Only do this for something that was in the source. Not
10072 -- clear if this can be False now (there used for sure to be
10073 -- cases on some systems where it was False), but anyway the
10074 -- test is harmless if not needed, so it is retained.
10076 and then Comes_From_Source (Arg)
10079 ("?x?& has been made static as a result of Export",
10082 ("\?x?this usage is non-standard and non-portable",
10088 if Warn_On_Export_Import and then Is_Type (E) then
10089 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10092 if Warn_On_Export_Import and Inside_A_Generic then
10094 ("all instances of& will have the same external name?x?",
10099 ----------------------------------------------
10100 -- Set_Extended_Import_Export_External_Name --
10101 ----------------------------------------------
10103 procedure Set_Extended_Import_Export_External_Name
10104 (Internal_Ent : Entity_Id;
10105 Arg_External : Node_Id)
10107 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10108 New_Name : Node_Id;
10111 if No (Arg_External) then
10115 Check_Arg_Is_External_Name (Arg_External);
10117 if Nkind (Arg_External) = N_String_Literal then
10118 if String_Length (Strval (Arg_External)) = 0 then
10121 New_Name := Adjust_External_Name_Case (Arg_External);
10124 elsif Nkind (Arg_External) = N_Identifier then
10125 New_Name := Get_Default_External_Name (Arg_External);
10127 -- Check_Arg_Is_External_Name should let through only identifiers and
10128 -- string literals or static string expressions (which are folded to
10129 -- string literals).
10132 raise Program_Error;
10135 -- If we already have an external name set (by a prior normal Import
10136 -- or Export pragma), then the external names must match
10138 if Present (Interface_Name (Internal_Ent)) then
10140 -- Ignore mismatching names in CodePeer mode, to support some
10141 -- old compilers which would export the same procedure under
10142 -- different names, e.g:
10144 -- pragma Export_Procedure (P, "a");
10145 -- pragma Export_Procedure (P, "b");
10147 if CodePeer_Mode then
10151 Check_Matching_Internal_Names : declare
10152 S1 : constant String_Id := Strval (Old_Name);
10153 S2 : constant String_Id := Strval (New_Name);
10155 procedure Mismatch;
10156 pragma No_Return (Mismatch);
10157 -- Called if names do not match
10163 procedure Mismatch is
10165 Error_Msg_Sloc := Sloc (Old_Name);
10167 ("external name does not match that given #",
10171 -- Start of processing for Check_Matching_Internal_Names
10174 if String_Length (S1) /= String_Length (S2) then
10178 for J in 1 .. String_Length (S1) loop
10179 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10184 end Check_Matching_Internal_Names;
10186 -- Otherwise set the given name
10189 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10190 Check_Duplicated_Export_Name (New_Name);
10192 end Set_Extended_Import_Export_External_Name;
10198 procedure Set_Imported (E : Entity_Id) is
10200 -- Error message if already imported or exported
10202 if Is_Exported (E) or else Is_Imported (E) then
10204 -- Error if being set Exported twice
10206 if Is_Exported (E) then
10207 Error_Msg_NE ("entity& was previously exported", N, E);
10209 -- Ignore error in CodePeer mode where we treat all imported
10210 -- subprograms as unknown.
10212 elsif CodePeer_Mode then
10215 -- OK if Import/Interface case
10217 elsif Import_Interface_Present (N) then
10220 -- Error if being set Imported twice
10223 Error_Msg_NE ("entity& was previously imported", N, E);
10226 Error_Msg_Name_1 := Pname;
10228 ("\(pragma% applies to all previous entities)", N);
10230 Error_Msg_Sloc := Sloc (E);
10231 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10233 -- Here if not previously imported or exported, OK to import
10236 Set_Is_Imported (E);
10238 -- For subprogram, set Import_Pragma field
10240 if Is_Subprogram (E) then
10241 Set_Import_Pragma (E, N);
10244 -- If the entity is an object that is not at the library level,
10245 -- then it is statically allocated. We do not worry about objects
10246 -- with address clauses in this context since they are not really
10247 -- imported in the linker sense.
10250 and then not Is_Library_Level_Entity (E)
10251 and then No (Address_Clause (E))
10253 Set_Is_Statically_Allocated (E);
10260 -------------------------
10261 -- Set_Mechanism_Value --
10262 -------------------------
10264 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10265 -- analyzed, since it is semantic nonsense), so we get it in the exact
10266 -- form created by the parser.
10268 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10269 procedure Bad_Mechanism;
10270 pragma No_Return (Bad_Mechanism);
10271 -- Signal bad mechanism name
10273 -------------------------
10274 -- Bad_Mechanism_Value --
10275 -------------------------
10277 procedure Bad_Mechanism is
10279 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10282 -- Start of processing for Set_Mechanism_Value
10285 if Mechanism (Ent) /= Default_Mechanism then
10287 ("mechanism for & has already been set", Mech_Name, Ent);
10290 -- MECHANISM_NAME ::= value | reference
10292 if Nkind (Mech_Name) = N_Identifier then
10293 if Chars (Mech_Name) = Name_Value then
10294 Set_Mechanism (Ent, By_Copy);
10297 elsif Chars (Mech_Name) = Name_Reference then
10298 Set_Mechanism (Ent, By_Reference);
10301 elsif Chars (Mech_Name) = Name_Copy then
10303 ("bad mechanism name, Value assumed", Mech_Name);
10312 end Set_Mechanism_Value;
10314 --------------------------
10315 -- Set_Rational_Profile --
10316 --------------------------
10318 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10319 -- extension to the semantics of renaming declarations.
10321 procedure Set_Rational_Profile is
10323 Implicit_Packing := True;
10324 Overriding_Renamings := True;
10325 Use_VADS_Size := True;
10326 end Set_Rational_Profile;
10328 ---------------------------
10329 -- Set_Ravenscar_Profile --
10330 ---------------------------
10332 -- The tasks to be done here are
10334 -- Set required policies
10336 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10337 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10338 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10339 -- (For GNAT_Ravenscar_EDF profile)
10340 -- pragma Locking_Policy (Ceiling_Locking)
10342 -- Set Detect_Blocking mode
10344 -- Set required restrictions (see System.Rident for detailed list)
10346 -- Set the No_Dependence rules
10347 -- No_Dependence => Ada.Asynchronous_Task_Control
10348 -- No_Dependence => Ada.Calendar
10349 -- No_Dependence => Ada.Execution_Time.Group_Budget
10350 -- No_Dependence => Ada.Execution_Time.Timers
10351 -- No_Dependence => Ada.Task_Attributes
10352 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10354 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10355 procedure Set_Error_Msg_To_Profile_Name;
10356 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10359 -----------------------------------
10360 -- Set_Error_Msg_To_Profile_Name --
10361 -----------------------------------
10363 procedure Set_Error_Msg_To_Profile_Name is
10364 Prof_Nam : constant Node_Id :=
10366 (First (Pragma_Argument_Associations (N)));
10369 Get_Name_String (Chars (Prof_Nam));
10370 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10371 Error_Msg_Strlen := Name_Len;
10372 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10373 end Set_Error_Msg_To_Profile_Name;
10382 Profile_Dispatching_Policy : Character;
10384 -- Start of processing for Set_Ravenscar_Profile
10387 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10389 if Profile = GNAT_Ravenscar_EDF then
10390 Profile_Dispatching_Policy := 'E';
10392 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10395 Profile_Dispatching_Policy := 'F';
10398 if Task_Dispatching_Policy /= ' '
10399 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
10401 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10402 Set_Error_Msg_To_Profile_Name;
10403 Error_Pragma ("Profile (~) incompatible with policy#");
10405 -- Set the FIFO_Within_Priorities policy, but always preserve
10406 -- System_Location since we like the error message with the run time
10410 Task_Dispatching_Policy := Profile_Dispatching_Policy;
10412 if Task_Dispatching_Policy_Sloc /= System_Location then
10413 Task_Dispatching_Policy_Sloc := Loc;
10417 -- pragma Locking_Policy (Ceiling_Locking)
10419 if Locking_Policy /= ' '
10420 and then Locking_Policy /= 'C'
10422 Error_Msg_Sloc := Locking_Policy_Sloc;
10423 Set_Error_Msg_To_Profile_Name;
10424 Error_Pragma ("Profile (~) incompatible with policy#");
10426 -- Set the Ceiling_Locking policy, but preserve System_Location since
10427 -- we like the error message with the run time name.
10430 Locking_Policy := 'C';
10432 if Locking_Policy_Sloc /= System_Location then
10433 Locking_Policy_Sloc := Loc;
10437 -- pragma Detect_Blocking
10439 Detect_Blocking := True;
10441 -- Set the corresponding restrictions
10443 Set_Profile_Restrictions
10444 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10446 -- Set the No_Dependence restrictions
10448 -- The following No_Dependence restrictions:
10449 -- No_Dependence => Ada.Asynchronous_Task_Control
10450 -- No_Dependence => Ada.Calendar
10451 -- No_Dependence => Ada.Task_Attributes
10452 -- are already set by previous call to Set_Profile_Restrictions.
10454 -- Set the following restrictions which were added to Ada 2005:
10455 -- No_Dependence => Ada.Execution_Time.Group_Budget
10456 -- No_Dependence => Ada.Execution_Time.Timers
10458 if Ada_Version >= Ada_2005 then
10459 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
10460 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
10463 Make_Selected_Component
10466 Selector_Name => Sel_Id);
10468 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
10471 Make_Selected_Component
10474 Selector_Name => Sel_Id);
10476 Set_Restriction_No_Dependence
10478 Warn => Treat_Restrictions_As_Warnings,
10479 Profile => Ravenscar);
10481 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
10484 Make_Selected_Component
10487 Selector_Name => Sel_Id);
10489 Set_Restriction_No_Dependence
10491 Warn => Treat_Restrictions_As_Warnings,
10492 Profile => Ravenscar);
10495 -- Set the following restriction which was added to Ada 2012 (see
10497 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10499 if Ada_Version >= Ada_2012 then
10500 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
10501 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
10504 Make_Selected_Component
10507 Selector_Name => Sel_Id);
10509 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
10512 Make_Selected_Component
10515 Selector_Name => Sel_Id);
10517 Set_Restriction_No_Dependence
10519 Warn => Treat_Restrictions_As_Warnings,
10520 Profile => Ravenscar);
10522 end Set_Ravenscar_Profile;
10524 -- Start of processing for Analyze_Pragma
10527 -- The following code is a defense against recursion. Not clear that
10528 -- this can happen legitimately, but perhaps some error situations can
10529 -- cause it, and we did see this recursion during testing.
10531 if Analyzed (N) then
10537 Check_Restriction_No_Use_Of_Pragma (N);
10539 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10540 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10542 if Should_Ignore_Pragma_Sem (N)
10543 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
10544 and then Ignore_Rep_Clauses)
10549 -- Deal with unrecognized pragma
10551 if not Is_Pragma_Name (Pname) then
10552 if Warn_On_Unrecognized_Pragma then
10553 Error_Msg_Name_1 := Pname;
10554 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10556 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10557 if Is_Bad_Spelling_Of (Pname, PN) then
10558 Error_Msg_Name_1 := PN;
10559 Error_Msg_N -- CODEFIX
10560 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10569 -- Here to start processing for recognized pragma
10571 Pname := Original_Aspect_Pragma_Name (N);
10573 -- Capture setting of Opt.Uneval_Old
10575 case Opt.Uneval_Old is
10577 Set_Uneval_Old_Accept (N);
10583 Set_Uneval_Old_Warn (N);
10586 raise Program_Error;
10589 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10590 -- is already set, indicating that we have already checked the policy
10591 -- at the right point. This happens for example in the case of a pragma
10592 -- that is derived from an Aspect.
10594 if Is_Ignored (N) or else Is_Checked (N) then
10597 -- For a pragma that is a rewriting of another pragma, copy the
10598 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10600 elsif Is_Rewrite_Substitution (N)
10601 and then Nkind (Original_Node (N)) = N_Pragma
10602 and then Original_Node (N) /= N
10604 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10605 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10607 -- Otherwise query the applicable policy at this point
10610 Check_Applicable_Policy (N);
10612 -- If pragma is disabled, rewrite as NULL and skip analysis
10614 if Is_Disabled (N) then
10615 Rewrite (N, Make_Null_Statement (Loc));
10621 -- Preset arguments
10629 if Present (Pragma_Argument_Associations (N)) then
10630 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10631 Arg1 := First (Pragma_Argument_Associations (N));
10633 if Present (Arg1) then
10634 Arg2 := Next (Arg1);
10636 if Present (Arg2) then
10637 Arg3 := Next (Arg2);
10639 if Present (Arg3) then
10640 Arg4 := Next (Arg3);
10646 -- An enumeration type defines the pragmas that are supported by the
10647 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10648 -- into the corresponding enumeration value for the following case.
10656 -- pragma Abort_Defer;
10658 when Pragma_Abort_Defer =>
10660 Check_Arg_Count (0);
10662 -- The only required semantic processing is to check the
10663 -- placement. This pragma must appear at the start of the
10664 -- statement sequence of a handled sequence of statements.
10666 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10667 or else N /= First (Statements (Parent (N)))
10672 --------------------
10673 -- Abstract_State --
10674 --------------------
10676 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10678 -- ABSTRACT_STATE_LIST ::=
10680 -- | STATE_NAME_WITH_OPTIONS
10681 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10683 -- STATE_NAME_WITH_OPTIONS ::=
10685 -- | (STATE_NAME with OPTION_LIST)
10687 -- OPTION_LIST ::= OPTION {, OPTION}
10691 -- | NAME_VALUE_OPTION
10693 -- SIMPLE_OPTION ::= Ghost | Synchronous
10695 -- NAME_VALUE_OPTION ::=
10696 -- Part_Of => ABSTRACT_STATE
10697 -- | External [=> EXTERNAL_PROPERTY_LIST]
10699 -- EXTERNAL_PROPERTY_LIST ::=
10700 -- EXTERNAL_PROPERTY
10701 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10703 -- EXTERNAL_PROPERTY ::=
10704 -- Async_Readers [=> boolean_EXPRESSION]
10705 -- | Async_Writers [=> boolean_EXPRESSION]
10706 -- | Effective_Reads [=> boolean_EXPRESSION]
10707 -- | Effective_Writes [=> boolean_EXPRESSION]
10708 -- others => boolean_EXPRESSION
10710 -- STATE_NAME ::= defining_identifier
10712 -- ABSTRACT_STATE ::= name
10714 -- Characteristics:
10716 -- * Analysis - The annotation is fully analyzed immediately upon
10717 -- elaboration as it cannot forward reference entities.
10719 -- * Expansion - None.
10721 -- * Template - The annotation utilizes the generic template of the
10722 -- related package declaration.
10724 -- * Globals - The annotation cannot reference global entities.
10726 -- * Instance - The annotation is instantiated automatically when
10727 -- the related generic package is instantiated.
10729 when Pragma_Abstract_State => Abstract_State : declare
10730 Missing_Parentheses : Boolean := False;
10731 -- Flag set when a state declaration with options is not properly
10734 -- Flags used to verify the consistency of states
10736 Non_Null_Seen : Boolean := False;
10737 Null_Seen : Boolean := False;
10739 procedure Analyze_Abstract_State
10741 Pack_Id : Entity_Id);
10742 -- Verify the legality of a single state declaration. Create and
10743 -- decorate a state abstraction entity and introduce it into the
10744 -- visibility chain. Pack_Id denotes the entity or the related
10745 -- package where pragma Abstract_State appears.
10747 procedure Malformed_State_Error (State : Node_Id);
10748 -- Emit an error concerning the illegal declaration of abstract
10749 -- state State. This routine diagnoses syntax errors that lead to
10750 -- a different parse tree. The error is issued regardless of the
10751 -- SPARK mode in effect.
10753 ----------------------------
10754 -- Analyze_Abstract_State --
10755 ----------------------------
10757 procedure Analyze_Abstract_State
10759 Pack_Id : Entity_Id)
10761 -- Flags used to verify the consistency of options
10763 AR_Seen : Boolean := False;
10764 AW_Seen : Boolean := False;
10765 ER_Seen : Boolean := False;
10766 EW_Seen : Boolean := False;
10767 External_Seen : Boolean := False;
10768 Ghost_Seen : Boolean := False;
10769 Others_Seen : Boolean := False;
10770 Part_Of_Seen : Boolean := False;
10771 Synchronous_Seen : Boolean := False;
10773 -- Flags used to store the static value of all external states'
10776 AR_Val : Boolean := False;
10777 AW_Val : Boolean := False;
10778 ER_Val : Boolean := False;
10779 EW_Val : Boolean := False;
10781 State_Id : Entity_Id := Empty;
10782 -- The entity to be generated for the current state declaration
10784 procedure Analyze_External_Option (Opt : Node_Id);
10785 -- Verify the legality of option External
10787 procedure Analyze_External_Property
10789 Expr : Node_Id := Empty);
10790 -- Verify the legailty of a single external property. Prop
10791 -- denotes the external property. Expr is the expression used
10792 -- to set the property.
10794 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10795 -- Verify the legality of option Part_Of
10797 procedure Check_Duplicate_Option
10799 Status : in out Boolean);
10800 -- Flag Status denotes whether a particular option has been
10801 -- seen while processing a state. This routine verifies that
10802 -- Opt is not a duplicate option and sets the flag Status
10803 -- (SPARK RM 7.1.4(1)).
10805 procedure Check_Duplicate_Property
10807 Status : in out Boolean);
10808 -- Flag Status denotes whether a particular property has been
10809 -- seen while processing option External. This routine verifies
10810 -- that Prop is not a duplicate property and sets flag Status.
10811 -- Opt is not a duplicate property and sets the flag Status.
10812 -- (SPARK RM 7.1.4(2))
10814 procedure Check_Ghost_Synchronous;
10815 -- Ensure that the abstract state is not subject to both Ghost
10816 -- and Synchronous simple options. Emit an error if this is the
10819 procedure Create_Abstract_State
10823 Is_Null : Boolean);
10824 -- Generate an abstract state entity with name Nam and enter it
10825 -- into visibility. Decl is the "declaration" of the state as
10826 -- it appears in pragma Abstract_State. Loc is the location of
10827 -- the related state "declaration". Flag Is_Null should be set
10828 -- when the associated Abstract_State pragma defines a null
10831 -----------------------------
10832 -- Analyze_External_Option --
10833 -----------------------------
10835 procedure Analyze_External_Option (Opt : Node_Id) is
10836 Errors : constant Nat := Serious_Errors_Detected;
10838 Props : Node_Id := Empty;
10841 if Nkind (Opt) = N_Component_Association then
10842 Props := Expression (Opt);
10845 -- External state with properties
10847 if Present (Props) then
10849 -- Multiple properties appear as an aggregate
10851 if Nkind (Props) = N_Aggregate then
10853 -- Simple property form
10855 Prop := First (Expressions (Props));
10856 while Present (Prop) loop
10857 Analyze_External_Property (Prop);
10861 -- Property with expression form
10863 Prop := First (Component_Associations (Props));
10864 while Present (Prop) loop
10865 Analyze_External_Property
10866 (Prop => First (Choices (Prop)),
10867 Expr => Expression (Prop));
10875 Analyze_External_Property (Props);
10878 -- An external state defined without any properties defaults
10879 -- all properties to True.
10888 -- Once all external properties have been processed, verify
10889 -- their mutual interaction. Do not perform the check when
10890 -- at least one of the properties is illegal as this will
10891 -- produce a bogus error.
10893 if Errors = Serious_Errors_Detected then
10894 Check_External_Properties
10895 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10897 end Analyze_External_Option;
10899 -------------------------------
10900 -- Analyze_External_Property --
10901 -------------------------------
10903 procedure Analyze_External_Property
10905 Expr : Node_Id := Empty)
10907 Expr_Val : Boolean;
10910 -- Check the placement of "others" (if available)
10912 if Nkind (Prop) = N_Others_Choice then
10913 if Others_Seen then
10915 ("only one others choice allowed in option External",
10918 Others_Seen := True;
10921 elsif Others_Seen then
10923 ("others must be the last property in option External",
10926 -- The only remaining legal options are the four predefined
10927 -- external properties.
10929 elsif Nkind (Prop) = N_Identifier
10930 and then Nam_In (Chars (Prop), Name_Async_Readers,
10931 Name_Async_Writers,
10932 Name_Effective_Reads,
10933 Name_Effective_Writes)
10937 -- Otherwise the construct is not a valid property
10940 SPARK_Msg_N ("invalid external state property", Prop);
10944 -- Ensure that the expression of the external state property
10945 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10947 if Present (Expr) then
10948 Analyze_And_Resolve (Expr, Standard_Boolean);
10950 if Is_OK_Static_Expression (Expr) then
10951 Expr_Val := Is_True (Expr_Value (Expr));
10954 ("expression of external state property must be "
10958 -- The lack of expression defaults the property to True
10964 -- Named properties
10966 if Nkind (Prop) = N_Identifier then
10967 if Chars (Prop) = Name_Async_Readers then
10968 Check_Duplicate_Property (Prop, AR_Seen);
10969 AR_Val := Expr_Val;
10971 elsif Chars (Prop) = Name_Async_Writers then
10972 Check_Duplicate_Property (Prop, AW_Seen);
10973 AW_Val := Expr_Val;
10975 elsif Chars (Prop) = Name_Effective_Reads then
10976 Check_Duplicate_Property (Prop, ER_Seen);
10977 ER_Val := Expr_Val;
10980 Check_Duplicate_Property (Prop, EW_Seen);
10981 EW_Val := Expr_Val;
10984 -- The handling of property "others" must take into account
10985 -- all other named properties that have been encountered so
10986 -- far. Only those that have not been seen are affected by
10990 if not AR_Seen then
10991 AR_Val := Expr_Val;
10994 if not AW_Seen then
10995 AW_Val := Expr_Val;
10998 if not ER_Seen then
10999 ER_Val := Expr_Val;
11002 if not EW_Seen then
11003 EW_Val := Expr_Val;
11006 end Analyze_External_Property;
11008 ----------------------------
11009 -- Analyze_Part_Of_Option --
11010 ----------------------------
11012 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11013 Encap : constant Node_Id := Expression (Opt);
11014 Constits : Elist_Id;
11015 Encap_Id : Entity_Id;
11019 Check_Duplicate_Option (Opt, Part_Of_Seen);
11022 (Indic => First (Choices (Opt)),
11023 Item_Id => State_Id,
11025 Encap_Id => Encap_Id,
11028 -- The Part_Of indicator transforms the abstract state into
11029 -- a constituent of the encapsulating state or single
11030 -- concurrent type.
11033 pragma Assert (Present (Encap_Id));
11034 Constits := Part_Of_Constituents (Encap_Id);
11036 if No (Constits) then
11037 Constits := New_Elmt_List;
11038 Set_Part_Of_Constituents (Encap_Id, Constits);
11041 Append_Elmt (State_Id, Constits);
11042 Set_Encapsulating_State (State_Id, Encap_Id);
11044 end Analyze_Part_Of_Option;
11046 ----------------------------
11047 -- Check_Duplicate_Option --
11048 ----------------------------
11050 procedure Check_Duplicate_Option
11052 Status : in out Boolean)
11056 SPARK_Msg_N ("duplicate state option", Opt);
11060 end Check_Duplicate_Option;
11062 ------------------------------
11063 -- Check_Duplicate_Property --
11064 ------------------------------
11066 procedure Check_Duplicate_Property
11068 Status : in out Boolean)
11072 SPARK_Msg_N ("duplicate external property", Prop);
11076 end Check_Duplicate_Property;
11078 -----------------------------
11079 -- Check_Ghost_Synchronous --
11080 -----------------------------
11082 procedure Check_Ghost_Synchronous is
11084 -- A synchronized abstract state cannot be Ghost and vice
11085 -- versa (SPARK RM 6.9(19)).
11087 if Ghost_Seen and Synchronous_Seen then
11088 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11090 end Check_Ghost_Synchronous;
11092 ---------------------------
11093 -- Create_Abstract_State --
11094 ---------------------------
11096 procedure Create_Abstract_State
11103 -- The abstract state may be semi-declared when the related
11104 -- package was withed through a limited with clause. In that
11105 -- case reuse the entity to fully declare the state.
11107 if Present (Decl) and then Present (Entity (Decl)) then
11108 State_Id := Entity (Decl);
11110 -- Otherwise the elaboration of pragma Abstract_State
11111 -- declares the state.
11114 State_Id := Make_Defining_Identifier (Loc, Nam);
11116 if Present (Decl) then
11117 Set_Entity (Decl, State_Id);
11121 -- Null states never come from source
11123 Set_Comes_From_Source (State_Id, not Is_Null);
11124 Set_Parent (State_Id, State);
11125 Set_Ekind (State_Id, E_Abstract_State);
11126 Set_Etype (State_Id, Standard_Void_Type);
11127 Set_Encapsulating_State (State_Id, Empty);
11129 -- An abstract state declared within a Ghost region becomes
11130 -- Ghost (SPARK RM 6.9(2)).
11132 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11133 Set_Is_Ghost_Entity (State_Id);
11136 -- Establish a link between the state declaration and the
11137 -- abstract state entity. Note that a null state remains as
11138 -- N_Null and does not carry any linkages.
11140 if not Is_Null then
11141 if Present (Decl) then
11142 Set_Entity (Decl, State_Id);
11143 Set_Etype (Decl, Standard_Void_Type);
11146 -- Every non-null state must be defined, nameable and
11149 Push_Scope (Pack_Id);
11150 Generate_Definition (State_Id);
11151 Enter_Name (State_Id);
11154 end Create_Abstract_State;
11161 -- Start of processing for Analyze_Abstract_State
11164 -- A package with a null abstract state is not allowed to
11165 -- declare additional states.
11169 ("package & has null abstract state", State, Pack_Id);
11171 -- Null states appear as internally generated entities
11173 elsif Nkind (State) = N_Null then
11174 Create_Abstract_State
11175 (Nam => New_Internal_Name ('S'),
11177 Loc => Sloc (State),
11181 -- Catch a case where a null state appears in a list of
11182 -- non-null states.
11184 if Non_Null_Seen then
11186 ("package & has non-null abstract state",
11190 -- Simple state declaration
11192 elsif Nkind (State) = N_Identifier then
11193 Create_Abstract_State
11194 (Nam => Chars (State),
11196 Loc => Sloc (State),
11198 Non_Null_Seen := True;
11200 -- State declaration with various options. This construct
11201 -- appears as an extension aggregate in the tree.
11203 elsif Nkind (State) = N_Extension_Aggregate then
11204 if Nkind (Ancestor_Part (State)) = N_Identifier then
11205 Create_Abstract_State
11206 (Nam => Chars (Ancestor_Part (State)),
11207 Decl => Ancestor_Part (State),
11208 Loc => Sloc (Ancestor_Part (State)),
11210 Non_Null_Seen := True;
11213 ("state name must be an identifier",
11214 Ancestor_Part (State));
11217 -- Options External, Ghost and Synchronous appear as
11220 Opt := First (Expressions (State));
11221 while Present (Opt) loop
11222 if Nkind (Opt) = N_Identifier then
11226 if Chars (Opt) = Name_External then
11227 Check_Duplicate_Option (Opt, External_Seen);
11228 Analyze_External_Option (Opt);
11232 elsif Chars (Opt) = Name_Ghost then
11233 Check_Duplicate_Option (Opt, Ghost_Seen);
11234 Check_Ghost_Synchronous;
11236 if Present (State_Id) then
11237 Set_Is_Ghost_Entity (State_Id);
11242 elsif Chars (Opt) = Name_Synchronous then
11243 Check_Duplicate_Option (Opt, Synchronous_Seen);
11244 Check_Ghost_Synchronous;
11246 -- Option Part_Of without an encapsulating state is
11247 -- illegal (SPARK RM 7.1.4(9)).
11249 elsif Chars (Opt) = Name_Part_Of then
11251 ("indicator Part_Of must denote abstract state, "
11252 & "single protected type or single task type",
11255 -- Do not emit an error message when a previous state
11256 -- declaration with options was not parenthesized as
11257 -- the option is actually another state declaration.
11259 -- with Abstract_State
11260 -- (State_1 with ..., -- missing parentheses
11261 -- (State_2 with ...),
11262 -- State_3) -- ok state declaration
11264 elsif Missing_Parentheses then
11267 -- Otherwise the option is not allowed. Note that it
11268 -- is not possible to distinguish between an option
11269 -- and a state declaration when a previous state with
11270 -- options not properly parentheses.
11272 -- with Abstract_State
11273 -- (State_1 with ..., -- missing parentheses
11274 -- State_2); -- could be an option
11278 ("simple option not allowed in state declaration",
11282 -- Catch a case where missing parentheses around a state
11283 -- declaration with options cause a subsequent state
11284 -- declaration with options to be treated as an option.
11286 -- with Abstract_State
11287 -- (State_1 with ..., -- missing parentheses
11288 -- (State_2 with ...))
11290 elsif Nkind (Opt) = N_Extension_Aggregate then
11291 Missing_Parentheses := True;
11293 ("state declaration must be parenthesized",
11294 Ancestor_Part (State));
11296 -- Otherwise the option is malformed
11299 SPARK_Msg_N ("malformed option", Opt);
11305 -- Options External and Part_Of appear as component
11308 Opt := First (Component_Associations (State));
11309 while Present (Opt) loop
11310 Opt_Nam := First (Choices (Opt));
11312 if Nkind (Opt_Nam) = N_Identifier then
11313 if Chars (Opt_Nam) = Name_External then
11314 Analyze_External_Option (Opt);
11316 elsif Chars (Opt_Nam) = Name_Part_Of then
11317 Analyze_Part_Of_Option (Opt);
11320 SPARK_Msg_N ("invalid state option", Opt);
11323 SPARK_Msg_N ("invalid state option", Opt);
11329 -- Any other attempt to declare a state is illegal
11332 Malformed_State_Error (State);
11336 -- Guard against a junk state. In such cases no entity is
11337 -- generated and the subsequent checks cannot be applied.
11339 if Present (State_Id) then
11341 -- Verify whether the state does not introduce an illegal
11342 -- hidden state within a package subject to a null abstract
11345 Check_No_Hidden_State (State_Id);
11347 -- Check whether the lack of option Part_Of agrees with the
11348 -- placement of the abstract state with respect to the state
11351 if not Part_Of_Seen then
11352 Check_Missing_Part_Of (State_Id);
11355 -- Associate the state with its related package
11357 if No (Abstract_States (Pack_Id)) then
11358 Set_Abstract_States (Pack_Id, New_Elmt_List);
11361 Append_Elmt (State_Id, Abstract_States (Pack_Id));
11363 end Analyze_Abstract_State;
11365 ---------------------------
11366 -- Malformed_State_Error --
11367 ---------------------------
11369 procedure Malformed_State_Error (State : Node_Id) is
11371 Error_Msg_N ("malformed abstract state declaration", State);
11373 -- An abstract state with a simple option is being declared
11374 -- with "=>" rather than the legal "with". The state appears
11375 -- as a component association.
11377 if Nkind (State) = N_Component_Association then
11378 Error_Msg_N ("\use WITH to specify simple option", State);
11380 end Malformed_State_Error;
11384 Pack_Decl : Node_Id;
11385 Pack_Id : Entity_Id;
11389 -- Start of processing for Abstract_State
11393 Check_No_Identifiers;
11394 Check_Arg_Count (1);
11396 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11398 -- Ensure the proper placement of the pragma. Abstract states must
11399 -- be associated with a package declaration.
11401 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11402 N_Package_Declaration)
11406 -- Otherwise the pragma is associated with an illegal construct
11413 Pack_Id := Defining_Entity (Pack_Decl);
11415 -- A pragma that applies to a Ghost entity becomes Ghost for the
11416 -- purposes of legality checks and removal of ignored Ghost code.
11418 Mark_Ghost_Pragma (N, Pack_Id);
11419 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11421 -- Chain the pragma on the contract for completeness
11423 Add_Contract_Item (N, Pack_Id);
11425 -- The legality checks of pragmas Abstract_State, Initializes, and
11426 -- Initial_Condition are affected by the SPARK mode in effect. In
11427 -- addition, these three pragmas are subject to an inherent order:
11429 -- 1) Abstract_State
11431 -- 3) Initial_Condition
11433 -- Analyze all these pragmas in the order outlined above
11435 Analyze_If_Present (Pragma_SPARK_Mode);
11436 States := Expression (Get_Argument (N, Pack_Id));
11438 -- Multiple non-null abstract states appear as an aggregate
11440 if Nkind (States) = N_Aggregate then
11441 State := First (Expressions (States));
11442 while Present (State) loop
11443 Analyze_Abstract_State (State, Pack_Id);
11447 -- An abstract state with a simple option is being illegaly
11448 -- declared with "=>" rather than "with". In this case the
11449 -- state declaration appears as a component association.
11451 if Present (Component_Associations (States)) then
11452 State := First (Component_Associations (States));
11453 while Present (State) loop
11454 Malformed_State_Error (State);
11459 -- Various forms of a single abstract state. Note that these may
11460 -- include malformed state declarations.
11463 Analyze_Abstract_State (States, Pack_Id);
11466 Analyze_If_Present (Pragma_Initializes);
11467 Analyze_If_Present (Pragma_Initial_Condition);
11468 end Abstract_State;
11476 -- Note: this pragma also has some specific processing in Par.Prag
11477 -- because we want to set the Ada version mode during parsing.
11479 when Pragma_Ada_83 =>
11481 Check_Arg_Count (0);
11483 -- We really should check unconditionally for proper configuration
11484 -- pragma placement, since we really don't want mixed Ada modes
11485 -- within a single unit, and the GNAT reference manual has always
11486 -- said this was a configuration pragma, but we did not check and
11487 -- are hesitant to add the check now.
11489 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11490 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11491 -- or Ada 2012 mode.
11493 if Ada_Version >= Ada_2005 then
11494 Check_Valid_Configuration_Pragma;
11497 -- Now set Ada 83 mode
11499 if Latest_Ada_Only then
11500 Error_Pragma ("??pragma% ignored");
11502 Ada_Version := Ada_83;
11503 Ada_Version_Explicit := Ada_83;
11504 Ada_Version_Pragma := N;
11513 -- Note: this pragma also has some specific processing in Par.Prag
11514 -- because we want to set the Ada 83 version mode during parsing.
11516 when Pragma_Ada_95 =>
11518 Check_Arg_Count (0);
11520 -- We really should check unconditionally for proper configuration
11521 -- pragma placement, since we really don't want mixed Ada modes
11522 -- within a single unit, and the GNAT reference manual has always
11523 -- said this was a configuration pragma, but we did not check and
11524 -- are hesitant to add the check now.
11526 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11527 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11529 if Ada_Version >= Ada_2005 then
11530 Check_Valid_Configuration_Pragma;
11533 -- Now set Ada 95 mode
11535 if Latest_Ada_Only then
11536 Error_Pragma ("??pragma% ignored");
11538 Ada_Version := Ada_95;
11539 Ada_Version_Explicit := Ada_95;
11540 Ada_Version_Pragma := N;
11543 ---------------------
11544 -- Ada_05/Ada_2005 --
11545 ---------------------
11548 -- pragma Ada_05 (LOCAL_NAME);
11550 -- pragma Ada_2005;
11551 -- pragma Ada_2005 (LOCAL_NAME):
11553 -- Note: these pragmas also have some specific processing in Par.Prag
11554 -- because we want to set the Ada 2005 version mode during parsing.
11556 -- The one argument form is used for managing the transition from
11557 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11558 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11559 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11560 -- mode, a preference rule is established which does not choose
11561 -- such an entity unless it is unambiguously specified. This avoids
11562 -- extra subprograms marked this way from generating ambiguities in
11563 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11564 -- intended for exclusive use in the GNAT run-time library.
11575 if Arg_Count = 1 then
11576 Check_Arg_Is_Local_Name (Arg1);
11577 E_Id := Get_Pragma_Arg (Arg1);
11579 if Etype (E_Id) = Any_Type then
11583 Set_Is_Ada_2005_Only (Entity (E_Id));
11584 Record_Rep_Item (Entity (E_Id), N);
11587 Check_Arg_Count (0);
11589 -- For Ada_2005 we unconditionally enforce the documented
11590 -- configuration pragma placement, since we do not want to
11591 -- tolerate mixed modes in a unit involving Ada 2005. That
11592 -- would cause real difficulties for those cases where there
11593 -- are incompatibilities between Ada 95 and Ada 2005.
11595 Check_Valid_Configuration_Pragma;
11597 -- Now set appropriate Ada mode
11599 if Latest_Ada_Only then
11600 Error_Pragma ("??pragma% ignored");
11602 Ada_Version := Ada_2005;
11603 Ada_Version_Explicit := Ada_2005;
11604 Ada_Version_Pragma := N;
11609 ---------------------
11610 -- Ada_12/Ada_2012 --
11611 ---------------------
11614 -- pragma Ada_12 (LOCAL_NAME);
11616 -- pragma Ada_2012;
11617 -- pragma Ada_2012 (LOCAL_NAME):
11619 -- Note: these pragmas also have some specific processing in Par.Prag
11620 -- because we want to set the Ada 2012 version mode during parsing.
11622 -- The one argument form is used for managing the transition from Ada
11623 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11624 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11625 -- mode will generate a warning. In addition, in any pre-Ada_2012
11626 -- mode, a preference rule is established which does not choose
11627 -- such an entity unless it is unambiguously specified. This avoids
11628 -- extra subprograms marked this way from generating ambiguities in
11629 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11630 -- intended for exclusive use in the GNAT run-time library.
11641 if Arg_Count = 1 then
11642 Check_Arg_Is_Local_Name (Arg1);
11643 E_Id := Get_Pragma_Arg (Arg1);
11645 if Etype (E_Id) = Any_Type then
11649 Set_Is_Ada_2012_Only (Entity (E_Id));
11650 Record_Rep_Item (Entity (E_Id), N);
11653 Check_Arg_Count (0);
11655 -- For Ada_2012 we unconditionally enforce the documented
11656 -- configuration pragma placement, since we do not want to
11657 -- tolerate mixed modes in a unit involving Ada 2012. That
11658 -- would cause real difficulties for those cases where there
11659 -- are incompatibilities between Ada 95 and Ada 2012. We could
11660 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11662 Check_Valid_Configuration_Pragma;
11664 -- Now set appropriate Ada mode
11666 Ada_Version := Ada_2012;
11667 Ada_Version_Explicit := Ada_2012;
11668 Ada_Version_Pragma := N;
11672 ----------------------
11673 -- All_Calls_Remote --
11674 ----------------------
11676 -- pragma All_Calls_Remote [(library_package_NAME)];
11678 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11679 Lib_Entity : Entity_Id;
11682 Check_Ada_83_Warning;
11683 Check_Valid_Library_Unit_Pragma;
11685 if Nkind (N) = N_Null_Statement then
11689 Lib_Entity := Find_Lib_Unit_Name;
11691 -- A pragma that applies to a Ghost entity becomes Ghost for the
11692 -- purposes of legality checks and removal of ignored Ghost code.
11694 Mark_Ghost_Pragma (N, Lib_Entity);
11696 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11698 if Present (Lib_Entity) and then not Debug_Flag_U then
11699 if not Is_Remote_Call_Interface (Lib_Entity) then
11700 Error_Pragma ("pragma% only apply to rci unit");
11702 -- Set flag for entity of the library unit
11705 Set_Has_All_Calls_Remote (Lib_Entity);
11708 end All_Calls_Remote;
11710 ---------------------------
11711 -- Allow_Integer_Address --
11712 ---------------------------
11714 -- pragma Allow_Integer_Address;
11716 when Pragma_Allow_Integer_Address =>
11718 Check_Valid_Configuration_Pragma;
11719 Check_Arg_Count (0);
11721 -- If Address is a private type, then set the flag to allow
11722 -- integer address values. If Address is not private, then this
11723 -- pragma has no purpose, so it is simply ignored. Not clear if
11724 -- there are any such targets now.
11726 if Opt.Address_Is_Private then
11727 Opt.Allow_Integer_Address := True;
11735 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11736 -- ARG ::= NAME | EXPRESSION
11738 -- The first two arguments are by convention intended to refer to an
11739 -- external tool and a tool-specific function. These arguments are
11742 when Pragma_Annotate => Annotate : declare
11749 Check_At_Least_N_Arguments (1);
11751 Nam_Arg := Last (Pragma_Argument_Associations (N));
11753 -- Determine whether the last argument is "Entity => local_NAME"
11754 -- and if it is, perform the required semantic checks. Remove the
11755 -- argument from further processing.
11757 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11758 and then Chars (Nam_Arg) = Name_Entity
11760 Check_Arg_Is_Local_Name (Nam_Arg);
11761 Arg_Count := Arg_Count - 1;
11763 -- A pragma that applies to a Ghost entity becomes Ghost for
11764 -- the purposes of legality checks and removal of ignored Ghost
11767 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11768 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11770 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11773 -- Not allowed in compiler units (bootstrap issues)
11775 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11778 -- Continue the processing with last argument removed for now
11780 Check_Arg_Is_Identifier (Arg1);
11781 Check_No_Identifiers;
11784 -- The second parameter is optional, it is never analyzed
11789 -- Otherwise there is a second parameter
11792 -- The second parameter must be an identifier
11794 Check_Arg_Is_Identifier (Arg2);
11796 -- Process the remaining parameters (if any)
11798 Arg := Next (Arg2);
11799 while Present (Arg) loop
11800 Expr := Get_Pragma_Arg (Arg);
11803 if Is_Entity_Name (Expr) then
11806 -- For string literals, we assume Standard_String as the
11807 -- type, unless the string contains wide or wide_wide
11810 elsif Nkind (Expr) = N_String_Literal then
11811 if Has_Wide_Wide_Character (Expr) then
11812 Resolve (Expr, Standard_Wide_Wide_String);
11813 elsif Has_Wide_Character (Expr) then
11814 Resolve (Expr, Standard_Wide_String);
11816 Resolve (Expr, Standard_String);
11819 elsif Is_Overloaded (Expr) then
11820 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11831 -------------------------------------------------
11832 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11833 -------------------------------------------------
11836 -- ( [Check => ] Boolean_EXPRESSION
11837 -- [, [Message =>] Static_String_EXPRESSION]);
11839 -- pragma Assert_And_Cut
11840 -- ( [Check => ] Boolean_EXPRESSION
11841 -- [, [Message =>] Static_String_EXPRESSION]);
11844 -- ( [Check => ] Boolean_EXPRESSION
11845 -- [, [Message =>] Static_String_EXPRESSION]);
11847 -- pragma Loop_Invariant
11848 -- ( [Check => ] Boolean_EXPRESSION
11849 -- [, [Message =>] Static_String_EXPRESSION]);
11852 | Pragma_Assert_And_Cut
11854 | Pragma_Loop_Invariant
11857 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11858 -- Determine whether expression Expr contains a Loop_Entry
11859 -- attribute reference.
11861 -------------------------
11862 -- Contains_Loop_Entry --
11863 -------------------------
11865 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11866 Has_Loop_Entry : Boolean := False;
11868 function Process (N : Node_Id) return Traverse_Result;
11869 -- Process function for traversal to look for Loop_Entry
11875 function Process (N : Node_Id) return Traverse_Result is
11877 if Nkind (N) = N_Attribute_Reference
11878 and then Attribute_Name (N) = Name_Loop_Entry
11880 Has_Loop_Entry := True;
11887 procedure Traverse is new Traverse_Proc (Process);
11889 -- Start of processing for Contains_Loop_Entry
11893 return Has_Loop_Entry;
11894 end Contains_Loop_Entry;
11899 New_Args : List_Id;
11901 -- Start of processing for Assert
11904 -- Assert is an Ada 2005 RM-defined pragma
11906 if Prag_Id = Pragma_Assert then
11909 -- The remaining ones are GNAT pragmas
11915 Check_At_Least_N_Arguments (1);
11916 Check_At_Most_N_Arguments (2);
11917 Check_Arg_Order ((Name_Check, Name_Message));
11918 Check_Optional_Identifier (Arg1, Name_Check);
11919 Expr := Get_Pragma_Arg (Arg1);
11921 -- Special processing for Loop_Invariant, Loop_Variant or for
11922 -- other cases where a Loop_Entry attribute is present. If the
11923 -- assertion pragma contains attribute Loop_Entry, ensure that
11924 -- the related pragma is within a loop.
11926 if Prag_Id = Pragma_Loop_Invariant
11927 or else Prag_Id = Pragma_Loop_Variant
11928 or else Contains_Loop_Entry (Expr)
11930 Check_Loop_Pragma_Placement;
11932 -- Perform preanalysis to deal with embedded Loop_Entry
11935 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11938 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11939 -- a corresponding Check pragma:
11941 -- pragma Check (name, condition [, msg]);
11943 -- Where name is the identifier matching the pragma name. So
11944 -- rewrite pragma in this manner, transfer the message argument
11945 -- if present, and analyze the result
11947 -- Note: When dealing with a semantically analyzed tree, the
11948 -- information that a Check node N corresponds to a source Assert,
11949 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11950 -- pragma kind of Original_Node(N).
11952 New_Args := New_List (
11953 Make_Pragma_Argument_Association (Loc,
11954 Expression => Make_Identifier (Loc, Pname)),
11955 Make_Pragma_Argument_Association (Sloc (Expr),
11956 Expression => Expr));
11958 if Arg_Count > 1 then
11959 Check_Optional_Identifier (Arg2, Name_Message);
11961 -- Provide semantic annnotations for optional argument, for
11962 -- ASIS use, before rewriting.
11964 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11965 Append_To (New_Args, New_Copy_Tree (Arg2));
11968 -- Rewrite as Check pragma
11972 Chars => Name_Check,
11973 Pragma_Argument_Associations => New_Args));
11978 ----------------------
11979 -- Assertion_Policy --
11980 ----------------------
11982 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11984 -- The following form is Ada 2012 only, but we allow it in all modes
11986 -- Pragma Assertion_Policy (
11987 -- ASSERTION_KIND => POLICY_IDENTIFIER
11988 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11990 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11992 -- RM_ASSERTION_KIND ::= Assert |
11993 -- Static_Predicate |
11994 -- Dynamic_Predicate |
11999 -- Type_Invariant |
12000 -- Type_Invariant'Class
12002 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12004 -- Contract_Cases |
12006 -- Default_Initial_Condition |
12008 -- Initial_Condition |
12009 -- Loop_Invariant |
12015 -- Statement_Assertions
12017 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12018 -- ID_ASSERTION_KIND list contains implementation-defined additions
12019 -- recognized by GNAT. The effect is to control the behavior of
12020 -- identically named aspects and pragmas, depending on the specified
12021 -- policy identifier:
12023 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12025 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12026 -- implementation-defined addition that results in totally ignoring
12027 -- the corresponding assertion. If Disable is specified, then the
12028 -- argument of the assertion is not even analyzed. This is useful
12029 -- when the aspect/pragma argument references entities in a with'ed
12030 -- package that is replaced by a dummy package in the final build.
12032 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12033 -- and Type_Invariant'Class were recognized by the parser and
12034 -- transformed into references to the special internal identifiers
12035 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12036 -- processing is required here.
12038 when Pragma_Assertion_Policy => Assertion_Policy : declare
12039 procedure Resolve_Suppressible (Policy : Node_Id);
12040 -- Converts the assertion policy 'Suppressible' to either Check or
12041 -- Ignore based on whether checks are suppressed via -gnatp.
12043 --------------------------
12044 -- Resolve_Suppressible --
12045 --------------------------
12047 procedure Resolve_Suppressible (Policy : Node_Id) is
12048 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12052 -- Transform policy argument Suppressible into either Ignore or
12053 -- Check depending on whether checks are enabled or suppressed.
12055 if Chars (Arg) = Name_Suppressible then
12056 if Suppress_Checks then
12057 Nam := Name_Ignore;
12062 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12064 end Resolve_Suppressible;
12076 -- This can always appear as a configuration pragma
12078 if Is_Configuration_Pragma then
12081 -- It can also appear in a declarative part or package spec in Ada
12082 -- 2012 mode. We allow this in other modes, but in that case we
12083 -- consider that we have an Ada 2012 pragma on our hands.
12086 Check_Is_In_Decl_Part_Or_Package_Spec;
12090 -- One argument case with no identifier (first form above)
12093 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
12094 or else Chars (Arg1) = No_Name)
12096 Check_Arg_Is_One_Of (Arg1,
12097 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12099 Resolve_Suppressible (Arg1);
12101 -- Treat one argument Assertion_Policy as equivalent to:
12103 -- pragma Check_Policy (Assertion, policy)
12105 -- So rewrite pragma in that manner and link on to the chain
12106 -- of Check_Policy pragmas, marking the pragma as analyzed.
12108 Policy := Get_Pragma_Arg (Arg1);
12112 Chars => Name_Check_Policy,
12113 Pragma_Argument_Associations => New_List (
12114 Make_Pragma_Argument_Association (Loc,
12115 Expression => Make_Identifier (Loc, Name_Assertion)),
12117 Make_Pragma_Argument_Association (Loc,
12119 Make_Identifier (Sloc (Policy), Chars (Policy))))));
12122 -- Here if we have two or more arguments
12125 Check_At_Least_N_Arguments (1);
12128 -- Loop through arguments
12131 while Present (Arg) loop
12132 LocP := Sloc (Arg);
12134 -- Kind must be specified
12136 if Nkind (Arg) /= N_Pragma_Argument_Association
12137 or else Chars (Arg) = No_Name
12140 ("missing assertion kind for pragma%", Arg);
12143 -- Check Kind and Policy have allowed forms
12145 Kind := Chars (Arg);
12146 Policy := Get_Pragma_Arg (Arg);
12148 if not Is_Valid_Assertion_Kind (Kind) then
12150 ("invalid assertion kind for pragma%", Arg);
12153 Check_Arg_Is_One_Of (Arg,
12154 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12156 Resolve_Suppressible (Arg);
12158 if Kind = Name_Ghost then
12160 -- The Ghost policy must be either Check or Ignore
12161 -- (SPARK RM 6.9(6)).
12163 if not Nam_In (Chars (Policy), Name_Check,
12167 ("argument of pragma % Ghost must be Check or "
12168 & "Ignore", Policy);
12171 -- Pragma Assertion_Policy specifying a Ghost policy
12172 -- cannot occur within a Ghost subprogram or package
12173 -- (SPARK RM 6.9(14)).
12175 if Ghost_Mode > None then
12177 ("pragma % cannot appear within ghost subprogram or "
12182 -- Rewrite the Assertion_Policy pragma as a series of
12183 -- Check_Policy pragmas of the form:
12185 -- Check_Policy (Kind, Policy);
12187 -- Note: the insertion of the pragmas cannot be done with
12188 -- Insert_Action because in the configuration case, there
12189 -- are no scopes on the scope stack and the mechanism will
12192 Insert_Before_And_Analyze (N,
12194 Chars => Name_Check_Policy,
12195 Pragma_Argument_Associations => New_List (
12196 Make_Pragma_Argument_Association (LocP,
12197 Expression => Make_Identifier (LocP, Kind)),
12198 Make_Pragma_Argument_Association (LocP,
12199 Expression => Policy))));
12204 -- Rewrite the Assertion_Policy pragma as null since we have
12205 -- now inserted all the equivalent Check pragmas.
12207 Rewrite (N, Make_Null_Statement (Loc));
12210 end Assertion_Policy;
12212 ------------------------------
12213 -- Assume_No_Invalid_Values --
12214 ------------------------------
12216 -- pragma Assume_No_Invalid_Values (On | Off);
12218 when Pragma_Assume_No_Invalid_Values =>
12220 Check_Valid_Configuration_Pragma;
12221 Check_Arg_Count (1);
12222 Check_No_Identifiers;
12223 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12225 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12226 Assume_No_Invalid_Values := True;
12228 Assume_No_Invalid_Values := False;
12231 --------------------------
12232 -- Attribute_Definition --
12233 --------------------------
12235 -- pragma Attribute_Definition
12236 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12237 -- [Entity =>] LOCAL_NAME,
12238 -- [Expression =>] EXPRESSION | NAME);
12240 when Pragma_Attribute_Definition => Attribute_Definition : declare
12241 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12246 Check_Arg_Count (3);
12247 Check_Optional_Identifier (Arg1, "attribute");
12248 Check_Optional_Identifier (Arg2, "entity");
12249 Check_Optional_Identifier (Arg3, "expression");
12251 if Nkind (Attribute_Designator) /= N_Identifier then
12252 Error_Msg_N ("attribute name expected", Attribute_Designator);
12256 Check_Arg_Is_Local_Name (Arg2);
12258 -- If the attribute is not recognized, then issue a warning (not
12259 -- an error), and ignore the pragma.
12261 Aname := Chars (Attribute_Designator);
12263 if not Is_Attribute_Name (Aname) then
12264 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12268 -- Otherwise, rewrite the pragma as an attribute definition clause
12271 Make_Attribute_Definition_Clause (Loc,
12272 Name => Get_Pragma_Arg (Arg2),
12274 Expression => Get_Pragma_Arg (Arg3)));
12276 end Attribute_Definition;
12278 ------------------------------------------------------------------
12279 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12280 ------------------------------------------------------------------
12282 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12283 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12284 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12285 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12287 when Pragma_Async_Readers
12288 | Pragma_Async_Writers
12289 | Pragma_Effective_Reads
12290 | Pragma_Effective_Writes
12292 Async_Effective : declare
12293 Obj_Decl : Node_Id;
12294 Obj_Id : Entity_Id;
12298 Check_No_Identifiers;
12299 Check_At_Most_N_Arguments (1);
12301 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12303 -- Object declaration
12305 if Nkind (Obj_Decl) = N_Object_Declaration then
12308 -- Otherwise the pragma is associated with an illegal construact
12315 Obj_Id := Defining_Entity (Obj_Decl);
12317 -- Perform minimal verification to ensure that the argument is at
12318 -- least a variable. Subsequent finer grained checks will be done
12319 -- at the end of the declarative region the contains the pragma.
12321 if Ekind (Obj_Id) = E_Variable then
12323 -- A pragma that applies to a Ghost entity becomes Ghost for
12324 -- the purposes of legality checks and removal of ignored Ghost
12327 Mark_Ghost_Pragma (N, Obj_Id);
12329 -- Chain the pragma on the contract for further processing by
12330 -- Analyze_External_Property_In_Decl_Part.
12332 Add_Contract_Item (N, Obj_Id);
12334 -- Analyze the Boolean expression (if any)
12336 if Present (Arg1) then
12337 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12340 -- Otherwise the external property applies to a constant
12343 Error_Pragma ("pragma % must apply to a volatile object");
12345 end Async_Effective;
12351 -- pragma Asynchronous (LOCAL_NAME);
12353 when Pragma_Asynchronous => Asynchronous : declare
12356 Formal : Entity_Id;
12361 procedure Process_Async_Pragma;
12362 -- Common processing for procedure and access-to-procedure case
12364 --------------------------
12365 -- Process_Async_Pragma --
12366 --------------------------
12368 procedure Process_Async_Pragma is
12371 Set_Is_Asynchronous (Nm);
12375 -- The formals should be of mode IN (RM E.4.1(6))
12378 while Present (S) loop
12379 Formal := Defining_Identifier (S);
12381 if Nkind (Formal) = N_Defining_Identifier
12382 and then Ekind (Formal) /= E_In_Parameter
12385 ("pragma% procedure can only have IN parameter",
12392 Set_Is_Asynchronous (Nm);
12393 end Process_Async_Pragma;
12395 -- Start of processing for pragma Asynchronous
12398 Check_Ada_83_Warning;
12399 Check_No_Identifiers;
12400 Check_Arg_Count (1);
12401 Check_Arg_Is_Local_Name (Arg1);
12403 if Debug_Flag_U then
12407 C_Ent := Cunit_Entity (Current_Sem_Unit);
12408 Analyze (Get_Pragma_Arg (Arg1));
12409 Nm := Entity (Get_Pragma_Arg (Arg1));
12411 -- A pragma that applies to a Ghost entity becomes Ghost for the
12412 -- purposes of legality checks and removal of ignored Ghost code.
12414 Mark_Ghost_Pragma (N, Nm);
12416 if not Is_Remote_Call_Interface (C_Ent)
12417 and then not Is_Remote_Types (C_Ent)
12419 -- This pragma should only appear in an RCI or Remote Types
12420 -- unit (RM E.4.1(4)).
12423 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12426 if Ekind (Nm) = E_Procedure
12427 and then Nkind (Parent (Nm)) = N_Procedure_Specification
12429 if not Is_Remote_Call_Interface (Nm) then
12431 ("pragma% cannot be applied on non-remote procedure",
12435 L := Parameter_Specifications (Parent (Nm));
12436 Process_Async_Pragma;
12439 elsif Ekind (Nm) = E_Function then
12441 ("pragma% cannot be applied to function", Arg1);
12443 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12444 if Is_Record_Type (Nm) then
12446 -- A record type that is the Equivalent_Type for a remote
12447 -- access-to-subprogram type.
12449 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12452 -- A non-expanded RAS type (distribution is not enabled)
12454 Decl := Declaration_Node (Nm);
12457 if Nkind (Decl) = N_Full_Type_Declaration
12458 and then Nkind (Type_Definition (Decl)) =
12459 N_Access_Procedure_Definition
12461 L := Parameter_Specifications (Type_Definition (Decl));
12462 Process_Async_Pragma;
12464 if Is_Asynchronous (Nm)
12465 and then Expander_Active
12466 and then Get_PCS_Name /= Name_No_DSA
12468 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12473 ("pragma% cannot reference access-to-function type",
12477 -- Only other possibility is Access-to-class-wide type
12479 elsif Is_Access_Type (Nm)
12480 and then Is_Class_Wide_Type (Designated_Type (Nm))
12482 Check_First_Subtype (Arg1);
12483 Set_Is_Asynchronous (Nm);
12484 if Expander_Active then
12485 RACW_Type_Is_Asynchronous (Nm);
12489 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12497 -- pragma Atomic (LOCAL_NAME);
12499 when Pragma_Atomic =>
12500 Process_Atomic_Independent_Shared_Volatile;
12502 -----------------------
12503 -- Atomic_Components --
12504 -----------------------
12506 -- pragma Atomic_Components (array_LOCAL_NAME);
12508 -- This processing is shared by Volatile_Components
12510 when Pragma_Atomic_Components
12511 | Pragma_Volatile_Components
12513 Atomic_Components : declare
12520 Check_Ada_83_Warning;
12521 Check_No_Identifiers;
12522 Check_Arg_Count (1);
12523 Check_Arg_Is_Local_Name (Arg1);
12524 E_Id := Get_Pragma_Arg (Arg1);
12526 if Etype (E_Id) = Any_Type then
12530 E := Entity (E_Id);
12532 -- A pragma that applies to a Ghost entity becomes Ghost for the
12533 -- purposes of legality checks and removal of ignored Ghost code.
12535 Mark_Ghost_Pragma (N, E);
12536 Check_Duplicate_Pragma (E);
12538 if Rep_Item_Too_Early (E, N)
12540 Rep_Item_Too_Late (E, N)
12545 D := Declaration_Node (E);
12548 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12550 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12551 and then Nkind (D) = N_Object_Declaration
12552 and then Nkind (Object_Definition (D)) =
12553 N_Constrained_Array_Definition)
12555 -- The flag is set on the object, or on the base type
12557 if Nkind (D) /= N_Object_Declaration then
12558 E := Base_Type (E);
12561 -- Atomic implies both Independent and Volatile
12563 if Prag_Id = Pragma_Atomic_Components then
12564 Set_Has_Atomic_Components (E);
12565 Set_Has_Independent_Components (E);
12568 Set_Has_Volatile_Components (E);
12571 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12573 end Atomic_Components;
12575 --------------------
12576 -- Attach_Handler --
12577 --------------------
12579 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12581 when Pragma_Attach_Handler =>
12582 Check_Ada_83_Warning;
12583 Check_No_Identifiers;
12584 Check_Arg_Count (2);
12586 if No_Run_Time_Mode then
12587 Error_Msg_CRT ("Attach_Handler pragma", N);
12589 Check_Interrupt_Or_Attach_Handler;
12591 -- The expression that designates the attribute may depend on a
12592 -- discriminant, and is therefore a per-object expression, to
12593 -- be expanded in the init proc. If expansion is enabled, then
12594 -- perform semantic checks on a copy only.
12599 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12602 -- In Relaxed_RM_Semantics mode, we allow any static
12603 -- integer value, for compatibility with other compilers.
12605 if Relaxed_RM_Semantics
12606 and then Nkind (Parg2) = N_Integer_Literal
12608 Typ := Standard_Integer;
12610 Typ := RTE (RE_Interrupt_ID);
12613 if Expander_Active then
12614 Temp := New_Copy_Tree (Parg2);
12615 Set_Parent (Temp, N);
12616 Preanalyze_And_Resolve (Temp, Typ);
12619 Resolve (Parg2, Typ);
12623 Process_Interrupt_Or_Attach_Handler;
12626 --------------------
12627 -- C_Pass_By_Copy --
12628 --------------------
12630 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12632 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12638 Check_Valid_Configuration_Pragma;
12639 Check_Arg_Count (1);
12640 Check_Optional_Identifier (Arg1, "max_size");
12642 Arg := Get_Pragma_Arg (Arg1);
12643 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12645 Val := Expr_Value (Arg);
12649 ("maximum size for pragma% must be positive", Arg1);
12651 elsif UI_Is_In_Int_Range (Val) then
12652 Default_C_Record_Mechanism := UI_To_Int (Val);
12654 -- If a giant value is given, Int'Last will do well enough.
12655 -- If sometime someone complains that a record larger than
12656 -- two gigabytes is not copied, we will worry about it then.
12659 Default_C_Record_Mechanism := Mechanism_Type'Last;
12661 end C_Pass_By_Copy;
12667 -- pragma Check ([Name =>] CHECK_KIND,
12668 -- [Check =>] Boolean_EXPRESSION
12669 -- [,[Message =>] String_EXPRESSION]);
12671 -- CHECK_KIND ::= IDENTIFIER |
12674 -- Invariant'Class |
12675 -- Type_Invariant'Class
12677 -- The identifiers Assertions and Statement_Assertions are not
12678 -- allowed, since they have special meaning for Check_Policy.
12680 -- WARNING: The code below manages Ghost regions. Return statements
12681 -- must be replaced by gotos which jump to the end of the code and
12682 -- restore the Ghost mode.
12684 when Pragma_Check => Check : declare
12685 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
12686 -- Save the Ghost mode to restore on exit
12692 pragma Warnings (Off, Str);
12695 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12696 -- the mode now to ensure that any nodes generated during analysis
12697 -- and expansion are marked as Ghost.
12699 Set_Ghost_Mode (N);
12702 Check_At_Least_N_Arguments (2);
12703 Check_At_Most_N_Arguments (3);
12704 Check_Optional_Identifier (Arg1, Name_Name);
12705 Check_Optional_Identifier (Arg2, Name_Check);
12707 if Arg_Count = 3 then
12708 Check_Optional_Identifier (Arg3, Name_Message);
12709 Str := Get_Pragma_Arg (Arg3);
12712 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12713 Check_Arg_Is_Identifier (Arg1);
12714 Cname := Chars (Get_Pragma_Arg (Arg1));
12716 -- Check forbidden name Assertions or Statement_Assertions
12719 when Name_Assertions =>
12721 ("""Assertions"" is not allowed as a check kind for "
12722 & "pragma%", Arg1);
12724 when Name_Statement_Assertions =>
12726 ("""Statement_Assertions"" is not allowed as a check kind "
12727 & "for pragma%", Arg1);
12733 -- Check applicable policy. We skip this if Checked/Ignored status
12734 -- is already set (e.g. in the case of a pragma from an aspect).
12736 if Is_Checked (N) or else Is_Ignored (N) then
12739 -- For a non-source pragma that is a rewriting of another pragma,
12740 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12742 elsif Is_Rewrite_Substitution (N)
12743 and then Nkind (Original_Node (N)) = N_Pragma
12744 and then Original_Node (N) /= N
12746 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12747 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12749 -- Otherwise query the applicable policy at this point
12752 case Check_Kind (Cname) is
12753 when Name_Ignore =>
12754 Set_Is_Ignored (N, True);
12755 Set_Is_Checked (N, False);
12758 Set_Is_Ignored (N, False);
12759 Set_Is_Checked (N, True);
12761 -- For disable, rewrite pragma as null statement and skip
12762 -- rest of the analysis of the pragma.
12764 when Name_Disable =>
12765 Rewrite (N, Make_Null_Statement (Loc));
12769 -- No other possibilities
12772 raise Program_Error;
12776 -- If check kind was not Disable, then continue pragma analysis
12778 Expr := Get_Pragma_Arg (Arg2);
12780 -- Deal with SCO generation
12782 if Is_Checked (N) and then not Split_PPC (N) then
12783 Set_SCO_Pragma_Enabled (Loc);
12786 -- Deal with analyzing the string argument
12788 if Arg_Count = 3 then
12790 -- If checks are not on we don't want any expansion (since
12791 -- such expansion would not get properly deleted) but
12792 -- we do want to analyze (to get proper references).
12793 -- The Preanalyze_And_Resolve routine does just what we want
12795 if Is_Ignored (N) then
12796 Preanalyze_And_Resolve (Str, Standard_String);
12798 -- Otherwise we need a proper analysis and expansion
12801 Analyze_And_Resolve (Str, Standard_String);
12805 -- Now you might think we could just do the same with the Boolean
12806 -- expression if checks are off (and expansion is on) and then
12807 -- rewrite the check as a null statement. This would work but we
12808 -- would lose the useful warnings about an assertion being bound
12809 -- to fail even if assertions are turned off.
12811 -- So instead we wrap the boolean expression in an if statement
12812 -- that looks like:
12814 -- if False and then condition then
12818 -- The reason we do this rewriting during semantic analysis rather
12819 -- than as part of normal expansion is that we cannot analyze and
12820 -- expand the code for the boolean expression directly, or it may
12821 -- cause insertion of actions that would escape the attempt to
12822 -- suppress the check code.
12824 -- Note that the Sloc for the if statement corresponds to the
12825 -- argument condition, not the pragma itself. The reason for
12826 -- this is that we may generate a warning if the condition is
12827 -- False at compile time, and we do not want to delete this
12828 -- warning when we delete the if statement.
12830 if Expander_Active and Is_Ignored (N) then
12831 Eloc := Sloc (Expr);
12834 Make_If_Statement (Eloc,
12836 Make_And_Then (Eloc,
12837 Left_Opnd => Make_Identifier (Eloc, Name_False),
12838 Right_Opnd => Expr),
12839 Then_Statements => New_List (
12840 Make_Null_Statement (Eloc))));
12842 -- Now go ahead and analyze the if statement
12844 In_Assertion_Expr := In_Assertion_Expr + 1;
12846 -- One rather special treatment. If we are now in Eliminated
12847 -- overflow mode, then suppress overflow checking since we do
12848 -- not want to drag in the bignum stuff if we are in Ignore
12849 -- mode anyway. This is particularly important if we are using
12850 -- a configurable run time that does not support bignum ops.
12852 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12854 Svo : constant Boolean :=
12855 Scope_Suppress.Suppress (Overflow_Check);
12857 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12858 Scope_Suppress.Suppress (Overflow_Check) := True;
12860 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12861 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12864 -- Not that special case
12870 -- All done with this check
12872 In_Assertion_Expr := In_Assertion_Expr - 1;
12874 -- Check is active or expansion not active. In these cases we can
12875 -- just go ahead and analyze the boolean with no worries.
12878 In_Assertion_Expr := In_Assertion_Expr + 1;
12879 Analyze_And_Resolve (Expr, Any_Boolean);
12880 In_Assertion_Expr := In_Assertion_Expr - 1;
12883 Restore_Ghost_Mode (Saved_GM);
12886 --------------------------
12887 -- Check_Float_Overflow --
12888 --------------------------
12890 -- pragma Check_Float_Overflow;
12892 when Pragma_Check_Float_Overflow =>
12894 Check_Valid_Configuration_Pragma;
12895 Check_Arg_Count (0);
12896 Check_Float_Overflow := not Machine_Overflows_On_Target;
12902 -- pragma Check_Name (check_IDENTIFIER);
12904 when Pragma_Check_Name =>
12906 Check_No_Identifiers;
12907 Check_Valid_Configuration_Pragma;
12908 Check_Arg_Count (1);
12909 Check_Arg_Is_Identifier (Arg1);
12912 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12915 for J in Check_Names.First .. Check_Names.Last loop
12916 if Check_Names.Table (J) = Nam then
12921 Check_Names.Append (Nam);
12928 -- This is the old style syntax, which is still allowed in all modes:
12930 -- pragma Check_Policy ([Name =>] CHECK_KIND
12931 -- [Policy =>] POLICY_IDENTIFIER);
12933 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12935 -- CHECK_KIND ::= IDENTIFIER |
12938 -- Type_Invariant'Class |
12941 -- This is the new style syntax, compatible with Assertion_Policy
12942 -- and also allowed in all modes.
12944 -- Pragma Check_Policy (
12945 -- CHECK_KIND => POLICY_IDENTIFIER
12946 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12948 -- Note: the identifiers Name and Policy are not allowed as
12949 -- Check_Kind values. This avoids ambiguities between the old and
12950 -- new form syntax.
12952 when Pragma_Check_Policy => Check_Policy : declare
12957 Check_At_Least_N_Arguments (1);
12959 -- A Check_Policy pragma can appear either as a configuration
12960 -- pragma, or in a declarative part or a package spec (see RM
12961 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12962 -- followed for Check_Policy).
12964 if not Is_Configuration_Pragma then
12965 Check_Is_In_Decl_Part_Or_Package_Spec;
12968 -- Figure out if we have the old or new syntax. We have the
12969 -- old syntax if the first argument has no identifier, or the
12970 -- identifier is Name.
12972 if Nkind (Arg1) /= N_Pragma_Argument_Association
12973 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12977 Check_Arg_Count (2);
12978 Check_Optional_Identifier (Arg1, Name_Name);
12979 Kind := Get_Pragma_Arg (Arg1);
12980 Rewrite_Assertion_Kind (Kind,
12981 From_Policy => Comes_From_Source (N));
12982 Check_Arg_Is_Identifier (Arg1);
12984 -- Check forbidden check kind
12986 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12987 Error_Msg_Name_2 := Chars (Kind);
12989 ("pragma% does not allow% as check name", Arg1);
12994 Check_Optional_Identifier (Arg2, Name_Policy);
12995 Check_Arg_Is_One_Of
12997 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12999 -- And chain pragma on the Check_Policy_List for search
13001 Set_Next_Pragma (N, Opt.Check_Policy_List);
13002 Opt.Check_Policy_List := N;
13004 -- For the new syntax, what we do is to convert each argument to
13005 -- an old syntax equivalent. We do that because we want to chain
13006 -- old style Check_Policy pragmas for the search (we don't want
13007 -- to have to deal with multiple arguments in the search).
13018 while Present (Arg) loop
13019 LocP := Sloc (Arg);
13020 Argx := Get_Pragma_Arg (Arg);
13022 -- Kind must be specified
13024 if Nkind (Arg) /= N_Pragma_Argument_Association
13025 or else Chars (Arg) = No_Name
13028 ("missing assertion kind for pragma%", Arg);
13031 -- Construct equivalent old form syntax Check_Policy
13032 -- pragma and insert it to get remaining checks.
13036 Chars => Name_Check_Policy,
13037 Pragma_Argument_Associations => New_List (
13038 Make_Pragma_Argument_Association (LocP,
13040 Make_Identifier (LocP, Chars (Arg))),
13041 Make_Pragma_Argument_Association (Sloc (Argx),
13042 Expression => Argx)));
13046 -- For a configuration pragma, insert old form in
13047 -- the corresponding file.
13049 if Is_Configuration_Pragma then
13050 Insert_After (N, New_P);
13054 Insert_Action (N, New_P);
13058 -- Rewrite original Check_Policy pragma to null, since we
13059 -- have converted it into a series of old syntax pragmas.
13061 Rewrite (N, Make_Null_Statement (Loc));
13071 -- pragma Comment (static_string_EXPRESSION)
13073 -- Processing for pragma Comment shares the circuitry for pragma
13074 -- Ident. The only differences are that Ident enforces a limit of 31
13075 -- characters on its argument, and also enforces limitations on
13076 -- placement for DEC compatibility. Pragma Comment shares neither of
13077 -- these restrictions.
13079 -------------------
13080 -- Common_Object --
13081 -------------------
13083 -- pragma Common_Object (
13084 -- [Internal =>] LOCAL_NAME
13085 -- [, [External =>] EXTERNAL_SYMBOL]
13086 -- [, [Size =>] EXTERNAL_SYMBOL]);
13088 -- Processing for this pragma is shared with Psect_Object
13090 ------------------------
13091 -- Compile_Time_Error --
13092 ------------------------
13094 -- pragma Compile_Time_Error
13095 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13097 when Pragma_Compile_Time_Error =>
13099 Process_Compile_Time_Warning_Or_Error;
13101 --------------------------
13102 -- Compile_Time_Warning --
13103 --------------------------
13105 -- pragma Compile_Time_Warning
13106 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13108 when Pragma_Compile_Time_Warning =>
13110 Process_Compile_Time_Warning_Or_Error;
13112 ---------------------------
13113 -- Compiler_Unit_Warning --
13114 ---------------------------
13116 -- pragma Compiler_Unit_Warning;
13120 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13121 -- errors not warnings. This means that we had introduced a big extra
13122 -- inertia to compiler changes, since even if we implemented a new
13123 -- feature, and even if all versions to be used for bootstrapping
13124 -- implemented this new feature, we could not use it, since old
13125 -- compilers would give errors for using this feature in units
13126 -- having Compiler_Unit pragmas.
13128 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13129 -- problem. We no longer have any units mentioning Compiler_Unit,
13130 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13131 -- and thus generates a warning which can be ignored. So that deals
13132 -- with the problem of old compilers not implementing the newer form
13135 -- Newer compilers recognize the new pragma, but generate warning
13136 -- messages instead of errors, which again can be ignored in the
13137 -- case of an old compiler which implements a wanted new feature
13138 -- but at the time felt like warning about it for older compilers.
13140 -- We retain Compiler_Unit so that new compilers can be used to build
13141 -- older run-times that use this pragma. That's an unusual case, but
13142 -- it's easy enough to handle, so why not?
13144 when Pragma_Compiler_Unit
13145 | Pragma_Compiler_Unit_Warning
13148 Check_Arg_Count (0);
13150 -- Only recognized in main unit
13152 if Current_Sem_Unit = Main_Unit then
13153 Compiler_Unit := True;
13156 -----------------------------
13157 -- Complete_Representation --
13158 -----------------------------
13160 -- pragma Complete_Representation;
13162 when Pragma_Complete_Representation =>
13164 Check_Arg_Count (0);
13166 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
13168 ("pragma & must appear within record representation clause");
13171 ----------------------------
13172 -- Complex_Representation --
13173 ----------------------------
13175 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13177 when Pragma_Complex_Representation => Complex_Representation : declare
13184 Check_Arg_Count (1);
13185 Check_Optional_Identifier (Arg1, Name_Entity);
13186 Check_Arg_Is_Local_Name (Arg1);
13187 E_Id := Get_Pragma_Arg (Arg1);
13189 if Etype (E_Id) = Any_Type then
13193 E := Entity (E_Id);
13195 if not Is_Record_Type (E) then
13197 ("argument for pragma% must be record type", Arg1);
13200 Ent := First_Entity (E);
13203 or else No (Next_Entity (Ent))
13204 or else Present (Next_Entity (Next_Entity (Ent)))
13205 or else not Is_Floating_Point_Type (Etype (Ent))
13206 or else Etype (Ent) /= Etype (Next_Entity (Ent))
13209 ("record for pragma% must have two fields of the same "
13210 & "floating-point type", Arg1);
13213 Set_Has_Complex_Representation (Base_Type (E));
13215 -- We need to treat the type has having a non-standard
13216 -- representation, for back-end purposes, even though in
13217 -- general a complex will have the default representation
13218 -- of a record with two real components.
13220 Set_Has_Non_Standard_Rep (Base_Type (E));
13222 end Complex_Representation;
13224 -------------------------
13225 -- Component_Alignment --
13226 -------------------------
13228 -- pragma Component_Alignment (
13229 -- [Form =>] ALIGNMENT_CHOICE
13230 -- [, [Name =>] type_LOCAL_NAME]);
13232 -- ALIGNMENT_CHOICE ::=
13234 -- | Component_Size_4
13238 when Pragma_Component_Alignment => Component_AlignmentP : declare
13239 Args : Args_List (1 .. 2);
13240 Names : constant Name_List (1 .. 2) := (
13244 Form : Node_Id renames Args (1);
13245 Name : Node_Id renames Args (2);
13247 Atype : Component_Alignment_Kind;
13252 Gather_Associations (Names, Args);
13255 Error_Pragma ("missing Form argument for pragma%");
13258 Check_Arg_Is_Identifier (Form);
13260 -- Get proper alignment, note that Default = Component_Size on all
13261 -- machines we have so far, and we want to set this value rather
13262 -- than the default value to indicate that it has been explicitly
13263 -- set (and thus will not get overridden by the default component
13264 -- alignment for the current scope)
13266 if Chars (Form) = Name_Component_Size then
13267 Atype := Calign_Component_Size;
13269 elsif Chars (Form) = Name_Component_Size_4 then
13270 Atype := Calign_Component_Size_4;
13272 elsif Chars (Form) = Name_Default then
13273 Atype := Calign_Component_Size;
13275 elsif Chars (Form) = Name_Storage_Unit then
13276 Atype := Calign_Storage_Unit;
13280 ("invalid Form parameter for pragma%", Form);
13283 -- The pragma appears in a configuration file
13285 if No (Parent (N)) then
13286 Check_Valid_Configuration_Pragma;
13288 -- Capture the component alignment in a global variable when
13289 -- the pragma appears in a configuration file. Note that the
13290 -- scope stack is empty at this point and cannot be used to
13291 -- store the alignment value.
13293 Configuration_Component_Alignment := Atype;
13295 -- Case with no name, supplied, affects scope table entry
13297 elsif No (Name) then
13299 (Scope_Stack.Last).Component_Alignment_Default := Atype;
13301 -- Case of name supplied
13304 Check_Arg_Is_Local_Name (Name);
13306 Typ := Entity (Name);
13309 or else Rep_Item_Too_Early (Typ, N)
13313 Typ := Underlying_Type (Typ);
13316 if not Is_Record_Type (Typ)
13317 and then not Is_Array_Type (Typ)
13320 ("Name parameter of pragma% must identify record or "
13321 & "array type", Name);
13324 -- An explicit Component_Alignment pragma overrides an
13325 -- implicit pragma Pack, but not an explicit one.
13327 if not Has_Pragma_Pack (Base_Type (Typ)) then
13328 Set_Is_Packed (Base_Type (Typ), False);
13329 Set_Component_Alignment (Base_Type (Typ), Atype);
13332 end Component_AlignmentP;
13334 --------------------------------
13335 -- Constant_After_Elaboration --
13336 --------------------------------
13338 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13340 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13342 Obj_Decl : Node_Id;
13343 Obj_Id : Entity_Id;
13347 Check_No_Identifiers;
13348 Check_At_Most_N_Arguments (1);
13350 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13352 -- Object declaration
13354 if Nkind (Obj_Decl) = N_Object_Declaration then
13357 -- Otherwise the pragma is associated with an illegal construct
13364 Obj_Id := Defining_Entity (Obj_Decl);
13366 -- The object declaration must be a library-level variable which
13367 -- is either explicitly initialized or obtains a value during the
13368 -- elaboration of a package body (SPARK RM 3.3.1).
13370 if Ekind (Obj_Id) = E_Variable then
13371 if not Is_Library_Level_Entity (Obj_Id) then
13373 ("pragma % must apply to a library level variable");
13377 -- Otherwise the pragma applies to a constant, which is illegal
13380 Error_Pragma ("pragma % must apply to a variable declaration");
13384 -- A pragma that applies to a Ghost entity becomes Ghost for the
13385 -- purposes of legality checks and removal of ignored Ghost code.
13387 Mark_Ghost_Pragma (N, Obj_Id);
13389 -- Chain the pragma on the contract for completeness
13391 Add_Contract_Item (N, Obj_Id);
13393 -- Analyze the Boolean expression (if any)
13395 if Present (Arg1) then
13396 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13398 end Constant_After_Elaboration;
13400 --------------------
13401 -- Contract_Cases --
13402 --------------------
13404 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13406 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13408 -- CASE_GUARD ::= boolean_EXPRESSION | others
13410 -- CONSEQUENCE ::= boolean_EXPRESSION
13412 -- Characteristics:
13414 -- * Analysis - The annotation undergoes initial checks to verify
13415 -- the legal placement and context. Secondary checks preanalyze the
13418 -- Analyze_Contract_Cases_In_Decl_Part
13420 -- * Expansion - The annotation is expanded during the expansion of
13421 -- the related subprogram [body] contract as performed in:
13423 -- Expand_Subprogram_Contract
13425 -- * Template - The annotation utilizes the generic template of the
13426 -- related subprogram [body] when it is:
13428 -- aspect on subprogram declaration
13429 -- aspect on stand alone subprogram body
13430 -- pragma on stand alone subprogram body
13432 -- The annotation must prepare its own template when it is:
13434 -- pragma on subprogram declaration
13436 -- * Globals - Capture of global references must occur after full
13439 -- * Instance - The annotation is instantiated automatically when
13440 -- the related generic subprogram [body] is instantiated except for
13441 -- the "pragma on subprogram declaration" case. In that scenario
13442 -- the annotation must instantiate itself.
13444 when Pragma_Contract_Cases => Contract_Cases : declare
13445 Spec_Id : Entity_Id;
13446 Subp_Decl : Node_Id;
13447 Subp_Spec : Node_Id;
13451 Check_No_Identifiers;
13452 Check_Arg_Count (1);
13454 -- Ensure the proper placement of the pragma. Contract_Cases must
13455 -- be associated with a subprogram declaration or a body that acts
13459 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13463 if Nkind (Subp_Decl) = N_Entry_Declaration then
13466 -- Generic subprogram
13468 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13471 -- Body acts as spec
13473 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13474 and then No (Corresponding_Spec (Subp_Decl))
13478 -- Body stub acts as spec
13480 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13481 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13487 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13488 Subp_Spec := Specification (Subp_Decl);
13490 -- Pragma Contract_Cases is forbidden on null procedures, as
13491 -- this may lead to potential ambiguities in behavior when
13492 -- interface null procedures are involved.
13494 if Nkind (Subp_Spec) = N_Procedure_Specification
13495 and then Null_Present (Subp_Spec)
13497 Error_Msg_N (Fix_Error
13498 ("pragma % cannot apply to null procedure"), N);
13507 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13509 -- A pragma that applies to a Ghost entity becomes Ghost for the
13510 -- purposes of legality checks and removal of ignored Ghost code.
13512 Mark_Ghost_Pragma (N, Spec_Id);
13513 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13515 -- Chain the pragma on the contract for further processing by
13516 -- Analyze_Contract_Cases_In_Decl_Part.
13518 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13520 -- Fully analyze the pragma when it appears inside an entry
13521 -- or subprogram body because it cannot benefit from forward
13524 if Nkind_In (Subp_Decl, N_Entry_Body,
13526 N_Subprogram_Body_Stub)
13528 -- The legality checks of pragma Contract_Cases are affected by
13529 -- the SPARK mode in effect and the volatility of the context.
13530 -- Analyze all pragmas in a specific order.
13532 Analyze_If_Present (Pragma_SPARK_Mode);
13533 Analyze_If_Present (Pragma_Volatile_Function);
13534 Analyze_Contract_Cases_In_Decl_Part (N);
13536 end Contract_Cases;
13542 -- pragma Controlled (first_subtype_LOCAL_NAME);
13544 when Pragma_Controlled => Controlled : declare
13548 Check_No_Identifiers;
13549 Check_Arg_Count (1);
13550 Check_Arg_Is_Local_Name (Arg1);
13551 Arg := Get_Pragma_Arg (Arg1);
13553 if not Is_Entity_Name (Arg)
13554 or else not Is_Access_Type (Entity (Arg))
13556 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13558 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13566 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13567 -- [Entity =>] LOCAL_NAME);
13569 when Pragma_Convention => Convention : declare
13572 pragma Warnings (Off, C);
13573 pragma Warnings (Off, E);
13576 Check_Arg_Order ((Name_Convention, Name_Entity));
13577 Check_Ada_83_Warning;
13578 Check_Arg_Count (2);
13579 Process_Convention (C, E);
13581 -- A pragma that applies to a Ghost entity becomes Ghost for the
13582 -- purposes of legality checks and removal of ignored Ghost code.
13584 Mark_Ghost_Pragma (N, E);
13587 ---------------------------
13588 -- Convention_Identifier --
13589 ---------------------------
13591 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13592 -- [Convention =>] convention_IDENTIFIER);
13594 when Pragma_Convention_Identifier => Convention_Identifier : declare
13600 Check_Arg_Order ((Name_Name, Name_Convention));
13601 Check_Arg_Count (2);
13602 Check_Optional_Identifier (Arg1, Name_Name);
13603 Check_Optional_Identifier (Arg2, Name_Convention);
13604 Check_Arg_Is_Identifier (Arg1);
13605 Check_Arg_Is_Identifier (Arg2);
13606 Idnam := Chars (Get_Pragma_Arg (Arg1));
13607 Cname := Chars (Get_Pragma_Arg (Arg2));
13609 if Is_Convention_Name (Cname) then
13610 Record_Convention_Identifier
13611 (Idnam, Get_Convention_Id (Cname));
13614 ("second arg for % pragma must be convention", Arg2);
13616 end Convention_Identifier;
13622 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13624 when Pragma_CPP_Class =>
13627 if Warn_On_Obsolescent_Feature then
13629 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13630 & "effect; replace it by pragma import?j?", N);
13633 Check_Arg_Count (1);
13637 Chars => Name_Import,
13638 Pragma_Argument_Associations => New_List (
13639 Make_Pragma_Argument_Association (Loc,
13640 Expression => Make_Identifier (Loc, Name_CPP)),
13641 New_Copy (First (Pragma_Argument_Associations (N))))));
13644 ---------------------
13645 -- CPP_Constructor --
13646 ---------------------
13648 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13649 -- [, [External_Name =>] static_string_EXPRESSION ]
13650 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13652 when Pragma_CPP_Constructor => CPP_Constructor : declare
13655 Def_Id : Entity_Id;
13656 Tag_Typ : Entity_Id;
13660 Check_At_Least_N_Arguments (1);
13661 Check_At_Most_N_Arguments (3);
13662 Check_Optional_Identifier (Arg1, Name_Entity);
13663 Check_Arg_Is_Local_Name (Arg1);
13665 Id := Get_Pragma_Arg (Arg1);
13666 Find_Program_Unit_Name (Id);
13668 -- If we did not find the name, we are done
13670 if Etype (Id) = Any_Type then
13674 Def_Id := Entity (Id);
13676 -- Check if already defined as constructor
13678 if Is_Constructor (Def_Id) then
13680 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13684 if Ekind (Def_Id) = E_Function
13685 and then (Is_CPP_Class (Etype (Def_Id))
13686 or else (Is_Class_Wide_Type (Etype (Def_Id))
13688 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13690 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13692 ("'C'P'P constructor must be defined in the scope of "
13693 & "its returned type", Arg1);
13696 if Arg_Count >= 2 then
13697 Set_Imported (Def_Id);
13698 Set_Is_Public (Def_Id);
13699 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
13702 Set_Has_Completion (Def_Id);
13703 Set_Is_Constructor (Def_Id);
13704 Set_Convention (Def_Id, Convention_CPP);
13706 -- Imported C++ constructors are not dispatching primitives
13707 -- because in C++ they don't have a dispatch table slot.
13708 -- However, in Ada the constructor has the profile of a
13709 -- function that returns a tagged type and therefore it has
13710 -- been treated as a primitive operation during semantic
13711 -- analysis. We now remove it from the list of primitive
13712 -- operations of the type.
13714 if Is_Tagged_Type (Etype (Def_Id))
13715 and then not Is_Class_Wide_Type (Etype (Def_Id))
13716 and then Is_Dispatching_Operation (Def_Id)
13718 Tag_Typ := Etype (Def_Id);
13720 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13721 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13725 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13726 Set_Is_Dispatching_Operation (Def_Id, False);
13729 -- For backward compatibility, if the constructor returns a
13730 -- class wide type, and we internally change the return type to
13731 -- the corresponding root type.
13733 if Is_Class_Wide_Type (Etype (Def_Id)) then
13734 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13738 ("pragma% requires function returning a 'C'P'P_Class type",
13741 end CPP_Constructor;
13747 when Pragma_CPP_Virtual =>
13750 if Warn_On_Obsolescent_Feature then
13752 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13760 when Pragma_CPP_Vtable =>
13763 if Warn_On_Obsolescent_Feature then
13765 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13773 -- pragma CPU (EXPRESSION);
13775 when Pragma_CPU => CPU : declare
13776 P : constant Node_Id := Parent (N);
13782 Check_No_Identifiers;
13783 Check_Arg_Count (1);
13787 if Nkind (P) = N_Subprogram_Body then
13788 Check_In_Main_Program;
13790 Arg := Get_Pragma_Arg (Arg1);
13791 Analyze_And_Resolve (Arg, Any_Integer);
13793 Ent := Defining_Unit_Name (Specification (P));
13795 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13796 Ent := Defining_Identifier (Ent);
13801 if not Is_OK_Static_Expression (Arg) then
13802 Flag_Non_Static_Expr
13803 ("main subprogram affinity is not static!", Arg);
13806 -- If constraint error, then we already signalled an error
13808 elsif Raises_Constraint_Error (Arg) then
13811 -- Otherwise check in range
13815 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13816 -- This is the entity System.Multiprocessors.CPU_Range;
13818 Val : constant Uint := Expr_Value (Arg);
13821 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13823 Val > Expr_Value (Type_High_Bound (CPU_Id))
13826 ("main subprogram CPU is out of range", Arg1);
13832 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13836 elsif Nkind (P) = N_Task_Definition then
13837 Arg := Get_Pragma_Arg (Arg1);
13838 Ent := Defining_Identifier (Parent (P));
13840 -- The expression must be analyzed in the special manner
13841 -- described in "Handling of Default and Per-Object
13842 -- Expressions" in sem.ads.
13844 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13846 -- Anything else is incorrect
13852 -- Check duplicate pragma before we chain the pragma in the Rep
13853 -- Item chain of Ent.
13855 Check_Duplicate_Pragma (Ent);
13856 Record_Rep_Item (Ent, N);
13859 --------------------
13860 -- Deadline_Floor --
13861 --------------------
13863 -- pragma Deadline_Floor (time_span_EXPRESSION);
13865 when Pragma_Deadline_Floor => Deadline_Floor : declare
13866 P : constant Node_Id := Parent (N);
13872 Check_No_Identifiers;
13873 Check_Arg_Count (1);
13875 Arg := Get_Pragma_Arg (Arg1);
13877 -- The expression must be analyzed in the special manner described
13878 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
13880 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
13882 -- Only protected types allowed
13884 if Nkind (P) /= N_Protected_Definition then
13888 Ent := Defining_Identifier (Parent (P));
13890 -- Check duplicate pragma before we chain the pragma in the Rep
13891 -- Item chain of Ent.
13893 Check_Duplicate_Pragma (Ent);
13894 Record_Rep_Item (Ent, N);
13896 end Deadline_Floor;
13902 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13904 when Pragma_Debug => Debug : declare
13911 -- The condition for executing the call is that the expander
13912 -- is active and that we are not ignoring this debug pragma.
13917 (Expander_Active and then not Is_Ignored (N)),
13920 if not Is_Ignored (N) then
13921 Set_SCO_Pragma_Enabled (Loc);
13924 if Arg_Count = 2 then
13926 Make_And_Then (Loc,
13927 Left_Opnd => Relocate_Node (Cond),
13928 Right_Opnd => Get_Pragma_Arg (Arg1));
13929 Call := Get_Pragma_Arg (Arg2);
13931 Call := Get_Pragma_Arg (Arg1);
13935 N_Indexed_Component,
13939 N_Selected_Component)
13941 -- If this pragma Debug comes from source, its argument was
13942 -- parsed as a name form (which is syntactically identical).
13943 -- In a generic context a parameterless call will be left as
13944 -- an expanded name (if global) or selected_component if local.
13945 -- Change it to a procedure call statement now.
13947 Change_Name_To_Procedure_Call_Statement (Call);
13949 elsif Nkind (Call) = N_Procedure_Call_Statement then
13951 -- Already in the form of a procedure call statement: nothing
13952 -- to do (could happen in case of an internally generated
13958 -- All other cases: diagnose error
13961 ("argument of pragma ""Debug"" is not procedure call",
13966 -- Rewrite into a conditional with an appropriate condition. We
13967 -- wrap the procedure call in a block so that overhead from e.g.
13968 -- use of the secondary stack does not generate execution overhead
13969 -- for suppressed conditions.
13971 -- Normally the analysis that follows will freeze the subprogram
13972 -- being called. However, if the call is to a null procedure,
13973 -- we want to freeze it before creating the block, because the
13974 -- analysis that follows may be done with expansion disabled, in
13975 -- which case the body will not be generated, leading to spurious
13978 if Nkind (Call) = N_Procedure_Call_Statement
13979 and then Is_Entity_Name (Name (Call))
13981 Analyze (Name (Call));
13982 Freeze_Before (N, Entity (Name (Call)));
13986 Make_Implicit_If_Statement (N,
13988 Then_Statements => New_List (
13989 Make_Block_Statement (Loc,
13990 Handled_Statement_Sequence =>
13991 Make_Handled_Sequence_Of_Statements (Loc,
13992 Statements => New_List (Relocate_Node (Call)))))));
13995 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13996 -- after analysis of the normally rewritten node, to capture all
13997 -- references to entities, which avoids issuing wrong warnings
13998 -- about unused entities.
14000 if GNATprove_Mode then
14001 Rewrite (N, Make_Null_Statement (Loc));
14009 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14011 when Pragma_Debug_Policy =>
14013 Check_Arg_Count (1);
14014 Check_No_Identifiers;
14015 Check_Arg_Is_Identifier (Arg1);
14017 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14018 -- rewrite it that way, and let the rest of the checking come
14019 -- from analyzing the rewritten pragma.
14023 Chars => Name_Check_Policy,
14024 Pragma_Argument_Associations => New_List (
14025 Make_Pragma_Argument_Association (Loc,
14026 Expression => Make_Identifier (Loc, Name_Debug)),
14028 Make_Pragma_Argument_Association (Loc,
14029 Expression => Get_Pragma_Arg (Arg1)))));
14032 -------------------------------
14033 -- Default_Initial_Condition --
14034 -------------------------------
14036 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14038 when Pragma_Default_Initial_Condition => DIC : declare
14045 Check_No_Identifiers;
14046 Check_At_Most_N_Arguments (1);
14050 while Present (Stmt) loop
14052 -- Skip prior pragmas, but check for duplicates
14054 if Nkind (Stmt) = N_Pragma then
14055 if Pragma_Name (Stmt) = Pname then
14062 -- Skip internally generated code. Note that derived type
14063 -- declarations of untagged types with discriminants are
14064 -- rewritten as private type declarations.
14066 elsif not Comes_From_Source (Stmt)
14067 and then Nkind (Stmt) /= N_Private_Type_Declaration
14071 -- The associated private type [extension] has been found, stop
14074 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
14075 N_Private_Type_Declaration)
14077 Typ := Defining_Entity (Stmt);
14080 -- The pragma does not apply to a legal construct, issue an
14081 -- error and stop the analysis.
14088 Stmt := Prev (Stmt);
14091 -- The pragma does not apply to a legal construct, issue an error
14092 -- and stop the analysis.
14099 -- A pragma that applies to a Ghost entity becomes Ghost for the
14100 -- purposes of legality checks and removal of ignored Ghost code.
14102 Mark_Ghost_Pragma (N, Typ);
14104 -- The pragma signals that the type defines its own DIC assertion
14107 Set_Has_Own_DIC (Typ);
14109 -- Chain the pragma on the rep item chain for further processing
14111 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14113 -- Create the declaration of the procedure which verifies the
14114 -- assertion expression of pragma DIC at runtime.
14116 Build_DIC_Procedure_Declaration (Typ);
14119 ----------------------------------
14120 -- Default_Scalar_Storage_Order --
14121 ----------------------------------
14123 -- pragma Default_Scalar_Storage_Order
14124 -- (High_Order_First | Low_Order_First);
14126 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
14127 Default : Character;
14131 Check_Arg_Count (1);
14133 -- Default_Scalar_Storage_Order can appear as a configuration
14134 -- pragma, or in a declarative part of a package spec.
14136 if not Is_Configuration_Pragma then
14137 Check_Is_In_Decl_Part_Or_Package_Spec;
14140 Check_No_Identifiers;
14141 Check_Arg_Is_One_Of
14142 (Arg1, Name_High_Order_First, Name_Low_Order_First);
14143 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14144 Default := Fold_Upper (Name_Buffer (1));
14146 if not Support_Nondefault_SSO_On_Target
14147 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
14149 if Warn_On_Unrecognized_Pragma then
14151 ("non-default Scalar_Storage_Order not supported "
14152 & "on target?g?", N);
14154 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
14157 -- Here set the specified default
14160 Opt.Default_SSO := Default;
14164 --------------------------
14165 -- Default_Storage_Pool --
14166 --------------------------
14168 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14170 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
14175 Check_Arg_Count (1);
14177 -- Default_Storage_Pool can appear as a configuration pragma, or
14178 -- in a declarative part of a package spec.
14180 if not Is_Configuration_Pragma then
14181 Check_Is_In_Decl_Part_Or_Package_Spec;
14184 if From_Aspect_Specification (N) then
14186 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
14188 if not In_Open_Scopes (E) then
14190 ("aspect must apply to package or subprogram", N);
14195 if Present (Arg1) then
14196 Pool := Get_Pragma_Arg (Arg1);
14198 -- Case of Default_Storage_Pool (null);
14200 if Nkind (Pool) = N_Null then
14203 -- This is an odd case, this is not really an expression,
14204 -- so we don't have a type for it. So just set the type to
14207 Set_Etype (Pool, Empty);
14209 -- Case of Default_Storage_Pool (storage_pool_NAME);
14212 -- If it's a configuration pragma, then the only allowed
14213 -- argument is "null".
14215 if Is_Configuration_Pragma then
14216 Error_Pragma_Arg ("NULL expected", Arg1);
14219 -- The expected type for a non-"null" argument is
14220 -- Root_Storage_Pool'Class, and the pool must be a variable.
14222 Analyze_And_Resolve
14223 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
14225 if Is_Variable (Pool) then
14227 -- A pragma that applies to a Ghost entity becomes Ghost
14228 -- for the purposes of legality checks and removal of
14229 -- ignored Ghost code.
14231 Mark_Ghost_Pragma (N, Entity (Pool));
14235 ("default storage pool must be a variable", Arg1);
14239 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14240 -- access type will use this information to set the appropriate
14241 -- attributes of the access type.
14243 Default_Pool := Pool;
14245 end Default_Storage_Pool;
14251 -- pragma Depends (DEPENDENCY_RELATION);
14253 -- DEPENDENCY_RELATION ::=
14255 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14257 -- DEPENDENCY_CLAUSE ::=
14258 -- OUTPUT_LIST =>[+] INPUT_LIST
14259 -- | NULL_DEPENDENCY_CLAUSE
14261 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14263 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14265 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14267 -- OUTPUT ::= NAME | FUNCTION_RESULT
14270 -- where FUNCTION_RESULT is a function Result attribute_reference
14272 -- Characteristics:
14274 -- * Analysis - The annotation undergoes initial checks to verify
14275 -- the legal placement and context. Secondary checks fully analyze
14276 -- the dependency clauses in:
14278 -- Analyze_Depends_In_Decl_Part
14280 -- * Expansion - None.
14282 -- * Template - The annotation utilizes the generic template of the
14283 -- related subprogram [body] when it is:
14285 -- aspect on subprogram declaration
14286 -- aspect on stand alone subprogram body
14287 -- pragma on stand alone subprogram body
14289 -- The annotation must prepare its own template when it is:
14291 -- pragma on subprogram declaration
14293 -- * Globals - Capture of global references must occur after full
14296 -- * Instance - The annotation is instantiated automatically when
14297 -- the related generic subprogram [body] is instantiated except for
14298 -- the "pragma on subprogram declaration" case. In that scenario
14299 -- the annotation must instantiate itself.
14301 when Pragma_Depends => Depends : declare
14303 Spec_Id : Entity_Id;
14304 Subp_Decl : Node_Id;
14307 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14311 -- Chain the pragma on the contract for further processing by
14312 -- Analyze_Depends_In_Decl_Part.
14314 Add_Contract_Item (N, Spec_Id);
14316 -- Fully analyze the pragma when it appears inside an entry
14317 -- or subprogram body because it cannot benefit from forward
14320 if Nkind_In (Subp_Decl, N_Entry_Body,
14322 N_Subprogram_Body_Stub)
14324 -- The legality checks of pragmas Depends and Global are
14325 -- affected by the SPARK mode in effect and the volatility
14326 -- of the context. In addition these two pragmas are subject
14327 -- to an inherent order:
14332 -- Analyze all these pragmas in the order outlined above
14334 Analyze_If_Present (Pragma_SPARK_Mode);
14335 Analyze_If_Present (Pragma_Volatile_Function);
14336 Analyze_If_Present (Pragma_Global);
14337 Analyze_Depends_In_Decl_Part (N);
14342 ---------------------
14343 -- Detect_Blocking --
14344 ---------------------
14346 -- pragma Detect_Blocking;
14348 when Pragma_Detect_Blocking =>
14350 Check_Arg_Count (0);
14351 Check_Valid_Configuration_Pragma;
14352 Detect_Blocking := True;
14354 ------------------------------------
14355 -- Disable_Atomic_Synchronization --
14356 ------------------------------------
14358 -- pragma Disable_Atomic_Synchronization [(Entity)];
14360 when Pragma_Disable_Atomic_Synchronization =>
14362 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14364 -------------------
14365 -- Discard_Names --
14366 -------------------
14368 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14370 when Pragma_Discard_Names => Discard_Names : declare
14375 Check_Ada_83_Warning;
14377 -- Deal with configuration pragma case
14379 if Arg_Count = 0 and then Is_Configuration_Pragma then
14380 Global_Discard_Names := True;
14383 -- Otherwise, check correct appropriate context
14386 Check_Is_In_Decl_Part_Or_Package_Spec;
14388 if Arg_Count = 0 then
14390 -- If there is no parameter, then from now on this pragma
14391 -- applies to any enumeration, exception or tagged type
14392 -- defined in the current declarative part, and recursively
14393 -- to any nested scope.
14395 Set_Discard_Names (Current_Scope);
14399 Check_Arg_Count (1);
14400 Check_Optional_Identifier (Arg1, Name_On);
14401 Check_Arg_Is_Local_Name (Arg1);
14403 E_Id := Get_Pragma_Arg (Arg1);
14405 if Etype (E_Id) = Any_Type then
14409 E := Entity (E_Id);
14411 -- A pragma that applies to a Ghost entity becomes Ghost for
14412 -- the purposes of legality checks and removal of ignored
14415 Mark_Ghost_Pragma (N, E);
14417 if (Is_First_Subtype (E)
14419 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14420 or else Ekind (E) = E_Exception
14422 Set_Discard_Names (E);
14423 Record_Rep_Item (E, N);
14427 ("inappropriate entity for pragma%", Arg1);
14433 ------------------------
14434 -- Dispatching_Domain --
14435 ------------------------
14437 -- pragma Dispatching_Domain (EXPRESSION);
14439 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14440 P : constant Node_Id := Parent (N);
14446 Check_No_Identifiers;
14447 Check_Arg_Count (1);
14449 -- This pragma is born obsolete, but not the aspect
14451 if not From_Aspect_Specification (N) then
14453 (No_Obsolescent_Features, Pragma_Identifier (N));
14456 if Nkind (P) = N_Task_Definition then
14457 Arg := Get_Pragma_Arg (Arg1);
14458 Ent := Defining_Identifier (Parent (P));
14460 -- A pragma that applies to a Ghost entity becomes Ghost for
14461 -- the purposes of legality checks and removal of ignored Ghost
14464 Mark_Ghost_Pragma (N, Ent);
14466 -- The expression must be analyzed in the special manner
14467 -- described in "Handling of Default and Per-Object
14468 -- Expressions" in sem.ads.
14470 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14472 -- Check duplicate pragma before we chain the pragma in the Rep
14473 -- Item chain of Ent.
14475 Check_Duplicate_Pragma (Ent);
14476 Record_Rep_Item (Ent, N);
14478 -- Anything else is incorrect
14483 end Dispatching_Domain;
14489 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14491 when Pragma_Elaborate => Elaborate : declare
14496 -- Pragma must be in context items list of a compilation unit
14498 if not Is_In_Context_Clause then
14502 -- Must be at least one argument
14504 if Arg_Count = 0 then
14505 Error_Pragma ("pragma% requires at least one argument");
14508 -- In Ada 83 mode, there can be no items following it in the
14509 -- context list except other pragmas and implicit with clauses
14510 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14511 -- placement rule does not apply.
14513 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14515 while Present (Citem) loop
14516 if Nkind (Citem) = N_Pragma
14517 or else (Nkind (Citem) = N_With_Clause
14518 and then Implicit_With (Citem))
14523 ("(Ada 83) pragma% must be at end of context clause");
14530 -- Finally, the arguments must all be units mentioned in a with
14531 -- clause in the same context clause. Note we already checked (in
14532 -- Par.Prag) that the arguments are all identifiers or selected
14536 Outer : while Present (Arg) loop
14537 Citem := First (List_Containing (N));
14538 Inner : while Citem /= N loop
14539 if Nkind (Citem) = N_With_Clause
14540 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14542 Set_Elaborate_Present (Citem, True);
14543 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14545 -- With the pragma present, elaboration calls on
14546 -- subprograms from the named unit need no further
14547 -- checks, as long as the pragma appears in the current
14548 -- compilation unit. If the pragma appears in some unit
14549 -- in the context, there might still be a need for an
14550 -- Elaborate_All_Desirable from the current compilation
14551 -- to the named unit, so we keep the check enabled.
14553 if In_Extended_Main_Source_Unit (N) then
14555 -- This does not apply in SPARK mode, where we allow
14556 -- pragma Elaborate, but we don't trust it to be right
14557 -- so we will still insist on the Elaborate_All.
14559 if SPARK_Mode /= On then
14560 Set_Suppress_Elaboration_Warnings
14561 (Entity (Name (Citem)));
14573 ("argument of pragma% is not withed unit", Arg);
14579 -- Give a warning if operating in static mode with one of the
14580 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14583 and not Dynamic_Elaboration_Checks
14585 -- pragma Elaborate not allowed in SPARK mode anyway. We
14586 -- already complained about it, no point in generating any
14587 -- further complaint.
14589 and SPARK_Mode /= On
14592 ("?l?use of pragma Elaborate may not be safe", N);
14594 ("?l?use pragma Elaborate_All instead if possible", N);
14598 -------------------
14599 -- Elaborate_All --
14600 -------------------
14602 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14604 when Pragma_Elaborate_All => Elaborate_All : declare
14609 Check_Ada_83_Warning;
14611 -- Pragma must be in context items list of a compilation unit
14613 if not Is_In_Context_Clause then
14617 -- Must be at least one argument
14619 if Arg_Count = 0 then
14620 Error_Pragma ("pragma% requires at least one argument");
14623 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14624 -- have to appear at the end of the context clause, but may
14625 -- appear mixed in with other items, even in Ada 83 mode.
14627 -- Final check: the arguments must all be units mentioned in
14628 -- a with clause in the same context clause. Note that we
14629 -- already checked (in Par.Prag) that all the arguments are
14630 -- either identifiers or selected components.
14633 Outr : while Present (Arg) loop
14634 Citem := First (List_Containing (N));
14635 Innr : while Citem /= N loop
14636 if Nkind (Citem) = N_With_Clause
14637 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14639 Set_Elaborate_All_Present (Citem, True);
14640 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14642 -- Suppress warnings and elaboration checks on the named
14643 -- unit if the pragma is in the current compilation, as
14644 -- for pragma Elaborate.
14646 if In_Extended_Main_Source_Unit (N) then
14647 Set_Suppress_Elaboration_Warnings
14648 (Entity (Name (Citem)));
14657 Set_Error_Posted (N);
14659 ("argument of pragma% is not withed unit", Arg);
14666 --------------------
14667 -- Elaborate_Body --
14668 --------------------
14670 -- pragma Elaborate_Body [( library_unit_NAME )];
14672 when Pragma_Elaborate_Body => Elaborate_Body : declare
14673 Cunit_Node : Node_Id;
14674 Cunit_Ent : Entity_Id;
14677 Check_Ada_83_Warning;
14678 Check_Valid_Library_Unit_Pragma;
14680 if Nkind (N) = N_Null_Statement then
14684 Cunit_Node := Cunit (Current_Sem_Unit);
14685 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14687 -- A pragma that applies to a Ghost entity becomes Ghost for the
14688 -- purposes of legality checks and removal of ignored Ghost code.
14690 Mark_Ghost_Pragma (N, Cunit_Ent);
14692 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14695 Error_Pragma ("pragma% must refer to a spec, not a body");
14697 Set_Body_Required (Cunit_Node, True);
14698 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14700 -- If we are in dynamic elaboration mode, then we suppress
14701 -- elaboration warnings for the unit, since it is definitely
14702 -- fine NOT to do dynamic checks at the first level (and such
14703 -- checks will be suppressed because no elaboration boolean
14704 -- is created for Elaborate_Body packages).
14706 -- But in the static model of elaboration, Elaborate_Body is
14707 -- definitely NOT good enough to ensure elaboration safety on
14708 -- its own, since the body may WITH other units that are not
14709 -- safe from an elaboration point of view, so a client must
14710 -- still do an Elaborate_All on such units.
14712 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14713 -- Elaborate_Body always suppressed elab warnings.
14715 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14716 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14719 end Elaborate_Body;
14721 ------------------------
14722 -- Elaboration_Checks --
14723 ------------------------
14725 -- pragma Elaboration_Checks (Static | Dynamic);
14727 when Pragma_Elaboration_Checks =>
14729 Check_Arg_Count (1);
14730 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14732 -- Set flag accordingly (ignore attempt at dynamic elaboration
14733 -- checks in SPARK mode).
14735 Dynamic_Elaboration_Checks :=
14736 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14742 -- pragma Eliminate (
14743 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14744 -- [Entity =>] IDENTIFIER |
14745 -- SELECTED_COMPONENT |
14747 -- [, Source_Location => SOURCE_TRACE]);
14749 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14750 -- SOURCE_TRACE ::= STRING_LITERAL
14752 when Pragma_Eliminate => Eliminate : declare
14753 Args : Args_List (1 .. 5);
14754 Names : constant Name_List (1 .. 5) := (
14757 Name_Parameter_Types,
14759 Name_Source_Location);
14761 -- Note : Parameter_Types and Result_Type are leftovers from
14762 -- prior implementations of the pragma. They are not generated
14763 -- by the gnatelim tool, and play no role in selecting which
14764 -- of a set of overloaded names is chosen for elimination.
14766 Unit_Name : Node_Id renames Args (1);
14767 Entity : Node_Id renames Args (2);
14768 Parameter_Types : Node_Id renames Args (3);
14769 Result_Type : Node_Id renames Args (4);
14770 Source_Location : Node_Id renames Args (5);
14774 Check_Valid_Configuration_Pragma;
14775 Gather_Associations (Names, Args);
14777 if No (Unit_Name) then
14778 Error_Pragma ("missing Unit_Name argument for pragma%");
14782 and then (Present (Parameter_Types)
14784 Present (Result_Type)
14786 Present (Source_Location))
14788 Error_Pragma ("missing Entity argument for pragma%");
14791 if (Present (Parameter_Types)
14793 Present (Result_Type))
14795 Present (Source_Location)
14798 ("parameter profile and source location cannot be used "
14799 & "together in pragma%");
14802 Process_Eliminate_Pragma
14811 -----------------------------------
14812 -- Enable_Atomic_Synchronization --
14813 -----------------------------------
14815 -- pragma Enable_Atomic_Synchronization [(Entity)];
14817 when Pragma_Enable_Atomic_Synchronization =>
14819 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14826 -- [ Convention =>] convention_IDENTIFIER,
14827 -- [ Entity =>] LOCAL_NAME
14828 -- [, [External_Name =>] static_string_EXPRESSION ]
14829 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14831 when Pragma_Export => Export : declare
14833 Def_Id : Entity_Id;
14835 pragma Warnings (Off, C);
14838 Check_Ada_83_Warning;
14842 Name_External_Name,
14845 Check_At_Least_N_Arguments (2);
14846 Check_At_Most_N_Arguments (4);
14848 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14849 -- pragma Export (Entity, "external name");
14851 if Relaxed_RM_Semantics
14852 and then Arg_Count = 2
14853 and then Nkind (Expression (Arg2)) = N_String_Literal
14856 Def_Id := Get_Pragma_Arg (Arg1);
14859 if not Is_Entity_Name (Def_Id) then
14860 Error_Pragma_Arg ("entity name required", Arg1);
14863 Def_Id := Entity (Def_Id);
14864 Set_Exported (Def_Id, Arg1);
14867 Process_Convention (C, Def_Id);
14869 -- A pragma that applies to a Ghost entity becomes Ghost for
14870 -- the purposes of legality checks and removal of ignored Ghost
14873 Mark_Ghost_Pragma (N, Def_Id);
14875 if Ekind (Def_Id) /= E_Constant then
14876 Note_Possible_Modification
14877 (Get_Pragma_Arg (Arg2), Sure => False);
14880 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
14881 Set_Exported (Def_Id, Arg2);
14884 -- If the entity is a deferred constant, propagate the information
14885 -- to the full view, because gigi elaborates the full view only.
14887 if Ekind (Def_Id) = E_Constant
14888 and then Present (Full_View (Def_Id))
14891 Id2 : constant Entity_Id := Full_View (Def_Id);
14893 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14894 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14895 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14900 ---------------------
14901 -- Export_Function --
14902 ---------------------
14904 -- pragma Export_Function (
14905 -- [Internal =>] LOCAL_NAME
14906 -- [, [External =>] EXTERNAL_SYMBOL]
14907 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14908 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14909 -- [, [Mechanism =>] MECHANISM]
14910 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14912 -- EXTERNAL_SYMBOL ::=
14914 -- | static_string_EXPRESSION
14916 -- PARAMETER_TYPES ::=
14918 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14920 -- TYPE_DESIGNATOR ::=
14922 -- | subtype_Name ' Access
14926 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14928 -- MECHANISM_ASSOCIATION ::=
14929 -- [formal_parameter_NAME =>] MECHANISM_NAME
14931 -- MECHANISM_NAME ::=
14935 when Pragma_Export_Function => Export_Function : declare
14936 Args : Args_List (1 .. 6);
14937 Names : constant Name_List (1 .. 6) := (
14940 Name_Parameter_Types,
14943 Name_Result_Mechanism);
14945 Internal : Node_Id renames Args (1);
14946 External : Node_Id renames Args (2);
14947 Parameter_Types : Node_Id renames Args (3);
14948 Result_Type : Node_Id renames Args (4);
14949 Mechanism : Node_Id renames Args (5);
14950 Result_Mechanism : Node_Id renames Args (6);
14954 Gather_Associations (Names, Args);
14955 Process_Extended_Import_Export_Subprogram_Pragma (
14956 Arg_Internal => Internal,
14957 Arg_External => External,
14958 Arg_Parameter_Types => Parameter_Types,
14959 Arg_Result_Type => Result_Type,
14960 Arg_Mechanism => Mechanism,
14961 Arg_Result_Mechanism => Result_Mechanism);
14962 end Export_Function;
14964 -------------------
14965 -- Export_Object --
14966 -------------------
14968 -- pragma Export_Object (
14969 -- [Internal =>] LOCAL_NAME
14970 -- [, [External =>] EXTERNAL_SYMBOL]
14971 -- [, [Size =>] EXTERNAL_SYMBOL]);
14973 -- EXTERNAL_SYMBOL ::=
14975 -- | static_string_EXPRESSION
14977 -- PARAMETER_TYPES ::=
14979 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14981 -- TYPE_DESIGNATOR ::=
14983 -- | subtype_Name ' Access
14987 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14989 -- MECHANISM_ASSOCIATION ::=
14990 -- [formal_parameter_NAME =>] MECHANISM_NAME
14992 -- MECHANISM_NAME ::=
14996 when Pragma_Export_Object => Export_Object : declare
14997 Args : Args_List (1 .. 3);
14998 Names : constant Name_List (1 .. 3) := (
15003 Internal : Node_Id renames Args (1);
15004 External : Node_Id renames Args (2);
15005 Size : Node_Id renames Args (3);
15009 Gather_Associations (Names, Args);
15010 Process_Extended_Import_Export_Object_Pragma (
15011 Arg_Internal => Internal,
15012 Arg_External => External,
15016 ----------------------
15017 -- Export_Procedure --
15018 ----------------------
15020 -- pragma Export_Procedure (
15021 -- [Internal =>] LOCAL_NAME
15022 -- [, [External =>] EXTERNAL_SYMBOL]
15023 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15024 -- [, [Mechanism =>] MECHANISM]);
15026 -- EXTERNAL_SYMBOL ::=
15028 -- | static_string_EXPRESSION
15030 -- PARAMETER_TYPES ::=
15032 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15034 -- TYPE_DESIGNATOR ::=
15036 -- | subtype_Name ' Access
15040 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15042 -- MECHANISM_ASSOCIATION ::=
15043 -- [formal_parameter_NAME =>] MECHANISM_NAME
15045 -- MECHANISM_NAME ::=
15049 when Pragma_Export_Procedure => Export_Procedure : declare
15050 Args : Args_List (1 .. 4);
15051 Names : constant Name_List (1 .. 4) := (
15054 Name_Parameter_Types,
15057 Internal : Node_Id renames Args (1);
15058 External : Node_Id renames Args (2);
15059 Parameter_Types : Node_Id renames Args (3);
15060 Mechanism : Node_Id renames Args (4);
15064 Gather_Associations (Names, Args);
15065 Process_Extended_Import_Export_Subprogram_Pragma (
15066 Arg_Internal => Internal,
15067 Arg_External => External,
15068 Arg_Parameter_Types => Parameter_Types,
15069 Arg_Mechanism => Mechanism);
15070 end Export_Procedure;
15076 -- pragma Export_Value (
15077 -- [Value =>] static_integer_EXPRESSION,
15078 -- [Link_Name =>] static_string_EXPRESSION);
15080 when Pragma_Export_Value =>
15082 Check_Arg_Order ((Name_Value, Name_Link_Name));
15083 Check_Arg_Count (2);
15085 Check_Optional_Identifier (Arg1, Name_Value);
15086 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
15088 Check_Optional_Identifier (Arg2, Name_Link_Name);
15089 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
15091 -----------------------------
15092 -- Export_Valued_Procedure --
15093 -----------------------------
15095 -- pragma Export_Valued_Procedure (
15096 -- [Internal =>] LOCAL_NAME
15097 -- [, [External =>] EXTERNAL_SYMBOL,]
15098 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15099 -- [, [Mechanism =>] MECHANISM]);
15101 -- EXTERNAL_SYMBOL ::=
15103 -- | static_string_EXPRESSION
15105 -- PARAMETER_TYPES ::=
15107 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15109 -- TYPE_DESIGNATOR ::=
15111 -- | subtype_Name ' Access
15115 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15117 -- MECHANISM_ASSOCIATION ::=
15118 -- [formal_parameter_NAME =>] MECHANISM_NAME
15120 -- MECHANISM_NAME ::=
15124 when Pragma_Export_Valued_Procedure =>
15125 Export_Valued_Procedure : declare
15126 Args : Args_List (1 .. 4);
15127 Names : constant Name_List (1 .. 4) := (
15130 Name_Parameter_Types,
15133 Internal : Node_Id renames Args (1);
15134 External : Node_Id renames Args (2);
15135 Parameter_Types : Node_Id renames Args (3);
15136 Mechanism : Node_Id renames Args (4);
15140 Gather_Associations (Names, Args);
15141 Process_Extended_Import_Export_Subprogram_Pragma (
15142 Arg_Internal => Internal,
15143 Arg_External => External,
15144 Arg_Parameter_Types => Parameter_Types,
15145 Arg_Mechanism => Mechanism);
15146 end Export_Valued_Procedure;
15148 -------------------
15149 -- Extend_System --
15150 -------------------
15152 -- pragma Extend_System ([Name =>] Identifier);
15154 when Pragma_Extend_System =>
15156 Check_Valid_Configuration_Pragma;
15157 Check_Arg_Count (1);
15158 Check_Optional_Identifier (Arg1, Name_Name);
15159 Check_Arg_Is_Identifier (Arg1);
15161 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15164 and then Name_Buffer (1 .. 4) = "aux_"
15166 if Present (System_Extend_Pragma_Arg) then
15167 if Chars (Get_Pragma_Arg (Arg1)) =
15168 Chars (Expression (System_Extend_Pragma_Arg))
15172 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
15173 Error_Pragma ("pragma% conflicts with that #");
15177 System_Extend_Pragma_Arg := Arg1;
15179 if not GNAT_Mode then
15180 System_Extend_Unit := Arg1;
15184 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
15187 ------------------------
15188 -- Extensions_Allowed --
15189 ------------------------
15191 -- pragma Extensions_Allowed (ON | OFF);
15193 when Pragma_Extensions_Allowed =>
15195 Check_Arg_Count (1);
15196 Check_No_Identifiers;
15197 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
15199 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
15200 Extensions_Allowed := True;
15201 Ada_Version := Ada_Version_Type'Last;
15204 Extensions_Allowed := False;
15205 Ada_Version := Ada_Version_Explicit;
15206 Ada_Version_Pragma := Empty;
15209 ------------------------
15210 -- Extensions_Visible --
15211 ------------------------
15213 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15215 -- Characteristics:
15217 -- * Analysis - The annotation is fully analyzed immediately upon
15218 -- elaboration as its expression must be static.
15220 -- * Expansion - None.
15222 -- * Template - The annotation utilizes the generic template of the
15223 -- related subprogram [body] when it is:
15225 -- aspect on subprogram declaration
15226 -- aspect on stand alone subprogram body
15227 -- pragma on stand alone subprogram body
15229 -- The annotation must prepare its own template when it is:
15231 -- pragma on subprogram declaration
15233 -- * Globals - Capture of global references must occur after full
15236 -- * Instance - The annotation is instantiated automatically when
15237 -- the related generic subprogram [body] is instantiated except for
15238 -- the "pragma on subprogram declaration" case. In that scenario
15239 -- the annotation must instantiate itself.
15241 when Pragma_Extensions_Visible => Extensions_Visible : declare
15242 Formal : Entity_Id;
15243 Has_OK_Formal : Boolean := False;
15244 Spec_Id : Entity_Id;
15245 Subp_Decl : Node_Id;
15249 Check_No_Identifiers;
15250 Check_At_Most_N_Arguments (1);
15253 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15255 -- Abstract subprogram declaration
15257 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15260 -- Generic subprogram declaration
15262 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15265 -- Body acts as spec
15267 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15268 and then No (Corresponding_Spec (Subp_Decl))
15272 -- Body stub acts as spec
15274 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15275 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15279 -- Subprogram declaration
15281 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15284 -- Otherwise the pragma is associated with an illegal construct
15287 Error_Pragma ("pragma % must apply to a subprogram");
15291 -- Mark the pragma as Ghost if the related subprogram is also
15292 -- Ghost. This also ensures that any expansion performed further
15293 -- below will produce Ghost nodes.
15295 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15296 Mark_Ghost_Pragma (N, Spec_Id);
15298 -- Chain the pragma on the contract for completeness
15300 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15302 -- The legality checks of pragma Extension_Visible are affected
15303 -- by the SPARK mode in effect. Analyze all pragmas in specific
15306 Analyze_If_Present (Pragma_SPARK_Mode);
15308 -- Examine the formals of the related subprogram
15310 Formal := First_Formal (Spec_Id);
15311 while Present (Formal) loop
15313 -- At least one of the formals is of a specific tagged type,
15314 -- the pragma is legal.
15316 if Is_Specific_Tagged_Type (Etype (Formal)) then
15317 Has_OK_Formal := True;
15320 -- A generic subprogram with at least one formal of a private
15321 -- type ensures the legality of the pragma because the actual
15322 -- may be specifically tagged. Note that this is verified by
15323 -- the check above at instantiation time.
15325 elsif Is_Private_Type (Etype (Formal))
15326 and then Is_Generic_Type (Etype (Formal))
15328 Has_OK_Formal := True;
15332 Next_Formal (Formal);
15335 if not Has_OK_Formal then
15336 Error_Msg_Name_1 := Pname;
15337 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15339 ("\subprogram & lacks parameter of specific tagged or "
15340 & "generic private type", N, Spec_Id);
15345 -- Analyze the Boolean expression (if any)
15347 if Present (Arg1) then
15348 Check_Static_Boolean_Expression
15349 (Expression (Get_Argument (N, Spec_Id)));
15351 end Extensions_Visible;
15357 -- pragma External (
15358 -- [ Convention =>] convention_IDENTIFIER,
15359 -- [ Entity =>] LOCAL_NAME
15360 -- [, [External_Name =>] static_string_EXPRESSION ]
15361 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15363 when Pragma_External => External : declare
15366 pragma Warnings (Off, C);
15373 Name_External_Name,
15375 Check_At_Least_N_Arguments (2);
15376 Check_At_Most_N_Arguments (4);
15377 Process_Convention (C, E);
15379 -- A pragma that applies to a Ghost entity becomes Ghost for the
15380 -- purposes of legality checks and removal of ignored Ghost code.
15382 Mark_Ghost_Pragma (N, E);
15384 Note_Possible_Modification
15385 (Get_Pragma_Arg (Arg2), Sure => False);
15386 Process_Interface_Name (E, Arg3, Arg4, N);
15387 Set_Exported (E, Arg2);
15390 --------------------------
15391 -- External_Name_Casing --
15392 --------------------------
15394 -- pragma External_Name_Casing (
15395 -- UPPERCASE | LOWERCASE
15396 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15398 when Pragma_External_Name_Casing =>
15400 Check_No_Identifiers;
15402 if Arg_Count = 2 then
15403 Check_Arg_Is_One_Of
15404 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15406 case Chars (Get_Pragma_Arg (Arg2)) is
15408 Opt.External_Name_Exp_Casing := As_Is;
15410 when Name_Uppercase =>
15411 Opt.External_Name_Exp_Casing := Uppercase;
15413 when Name_Lowercase =>
15414 Opt.External_Name_Exp_Casing := Lowercase;
15421 Check_Arg_Count (1);
15424 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15426 case Chars (Get_Pragma_Arg (Arg1)) is
15427 when Name_Uppercase =>
15428 Opt.External_Name_Imp_Casing := Uppercase;
15430 when Name_Lowercase =>
15431 Opt.External_Name_Imp_Casing := Lowercase;
15441 -- pragma Fast_Math;
15443 when Pragma_Fast_Math =>
15445 Check_No_Identifiers;
15446 Check_Valid_Configuration_Pragma;
15449 --------------------------
15450 -- Favor_Top_Level --
15451 --------------------------
15453 -- pragma Favor_Top_Level (type_NAME);
15455 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15460 Check_No_Identifiers;
15461 Check_Arg_Count (1);
15462 Check_Arg_Is_Local_Name (Arg1);
15463 Typ := Entity (Get_Pragma_Arg (Arg1));
15465 -- A pragma that applies to a Ghost entity becomes Ghost for the
15466 -- purposes of legality checks and removal of ignored Ghost code.
15468 Mark_Ghost_Pragma (N, Typ);
15470 -- If it's an access-to-subprogram type (in particular, not a
15471 -- subtype), set the flag on that type.
15473 if Is_Access_Subprogram_Type (Typ) then
15474 Set_Can_Use_Internal_Rep (Typ, False);
15476 -- Otherwise it's an error (name denotes the wrong sort of entity)
15480 ("access-to-subprogram type expected",
15481 Get_Pragma_Arg (Arg1));
15483 end Favor_Top_Level;
15485 ---------------------------
15486 -- Finalize_Storage_Only --
15487 ---------------------------
15489 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15491 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15492 Assoc : constant Node_Id := Arg1;
15493 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15498 Check_No_Identifiers;
15499 Check_Arg_Count (1);
15500 Check_Arg_Is_Local_Name (Arg1);
15502 Find_Type (Type_Id);
15503 Typ := Entity (Type_Id);
15506 or else Rep_Item_Too_Early (Typ, N)
15510 Typ := Underlying_Type (Typ);
15513 if not Is_Controlled (Typ) then
15514 Error_Pragma ("pragma% must specify controlled type");
15517 Check_First_Subtype (Arg1);
15519 if Finalize_Storage_Only (Typ) then
15520 Error_Pragma ("duplicate pragma%, only one allowed");
15522 elsif not Rep_Item_Too_Late (Typ, N) then
15523 Set_Finalize_Storage_Only (Base_Type (Typ), True);
15525 end Finalize_Storage;
15531 -- pragma Ghost [ (boolean_EXPRESSION) ];
15533 when Pragma_Ghost => Ghost : declare
15537 Orig_Stmt : Node_Id;
15538 Prev_Id : Entity_Id;
15543 Check_No_Identifiers;
15544 Check_At_Most_N_Arguments (1);
15548 while Present (Stmt) loop
15550 -- Skip prior pragmas, but check for duplicates
15552 if Nkind (Stmt) = N_Pragma then
15553 if Pragma_Name (Stmt) = Pname then
15560 -- Task unit declared without a definition cannot be subject to
15561 -- pragma Ghost (SPARK RM 6.9(19)).
15563 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15564 N_Task_Type_Declaration)
15566 Error_Pragma ("pragma % cannot apply to a task type");
15569 -- Skip internally generated code
15571 elsif not Comes_From_Source (Stmt) then
15572 Orig_Stmt := Original_Node (Stmt);
15574 -- When pragma Ghost applies to an untagged derivation, the
15575 -- derivation is transformed into a [sub]type declaration.
15577 if Nkind_In (Stmt, N_Full_Type_Declaration,
15578 N_Subtype_Declaration)
15579 and then Comes_From_Source (Orig_Stmt)
15580 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15581 and then Nkind (Type_Definition (Orig_Stmt)) =
15582 N_Derived_Type_Definition
15584 Id := Defining_Entity (Stmt);
15587 -- When pragma Ghost applies to an object declaration which
15588 -- is initialized by means of a function call that returns
15589 -- on the secondary stack, the object declaration becomes a
15592 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15593 and then Comes_From_Source (Orig_Stmt)
15594 and then Nkind (Orig_Stmt) = N_Object_Declaration
15596 Id := Defining_Entity (Stmt);
15599 -- When pragma Ghost applies to an expression function, the
15600 -- expression function is transformed into a subprogram.
15602 elsif Nkind (Stmt) = N_Subprogram_Declaration
15603 and then Comes_From_Source (Orig_Stmt)
15604 and then Nkind (Orig_Stmt) = N_Expression_Function
15606 Id := Defining_Entity (Stmt);
15610 -- The pragma applies to a legal construct, stop the traversal
15612 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15613 N_Full_Type_Declaration,
15614 N_Generic_Subprogram_Declaration,
15615 N_Object_Declaration,
15616 N_Private_Extension_Declaration,
15617 N_Private_Type_Declaration,
15618 N_Subprogram_Declaration,
15619 N_Subtype_Declaration)
15621 Id := Defining_Entity (Stmt);
15624 -- The pragma does not apply to a legal construct, issue an
15625 -- error and stop the analysis.
15629 ("pragma % must apply to an object, package, subprogram "
15634 Stmt := Prev (Stmt);
15637 Context := Parent (N);
15639 -- Handle compilation units
15641 if Nkind (Context) = N_Compilation_Unit_Aux then
15642 Context := Unit (Parent (Context));
15645 -- Protected and task types cannot be subject to pragma Ghost
15646 -- (SPARK RM 6.9(19)).
15648 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15650 Error_Pragma ("pragma % cannot apply to a protected type");
15653 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15654 Error_Pragma ("pragma % cannot apply to a task type");
15660 -- When pragma Ghost is associated with a [generic] package, it
15661 -- appears in the visible declarations.
15663 if Nkind (Context) = N_Package_Specification
15664 and then Present (Visible_Declarations (Context))
15665 and then List_Containing (N) = Visible_Declarations (Context)
15667 Id := Defining_Entity (Context);
15669 -- Pragma Ghost applies to a stand alone subprogram body
15671 elsif Nkind (Context) = N_Subprogram_Body
15672 and then No (Corresponding_Spec (Context))
15674 Id := Defining_Entity (Context);
15676 -- Pragma Ghost applies to a subprogram declaration that acts
15677 -- as a compilation unit.
15679 elsif Nkind (Context) = N_Subprogram_Declaration then
15680 Id := Defining_Entity (Context);
15686 ("pragma % must apply to an object, package, subprogram or "
15691 -- Handle completions of types and constants that are subject to
15694 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15695 Prev_Id := Incomplete_Or_Partial_View (Id);
15697 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15698 Error_Msg_Name_1 := Pname;
15700 -- The full declaration of a deferred constant cannot be
15701 -- subject to pragma Ghost unless the deferred declaration
15702 -- is also Ghost (SPARK RM 6.9(9)).
15704 if Ekind (Prev_Id) = E_Constant then
15705 Error_Msg_Name_1 := Pname;
15706 Error_Msg_NE (Fix_Error
15707 ("pragma % must apply to declaration of deferred "
15708 & "constant &"), N, Id);
15711 -- Pragma Ghost may appear on the full view of an incomplete
15712 -- type because the incomplete declaration lacks aspects and
15713 -- cannot be subject to pragma Ghost.
15715 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15718 -- The full declaration of a type cannot be subject to
15719 -- pragma Ghost unless the partial view is also Ghost
15720 -- (SPARK RM 6.9(9)).
15723 Error_Msg_NE (Fix_Error
15724 ("pragma % must apply to partial view of type &"),
15730 -- A synchronized object cannot be subject to pragma Ghost
15731 -- (SPARK RM 6.9(19)).
15733 elsif Ekind (Id) = E_Variable then
15734 if Is_Protected_Type (Etype (Id)) then
15735 Error_Pragma ("pragma % cannot apply to a protected object");
15738 elsif Is_Task_Type (Etype (Id)) then
15739 Error_Pragma ("pragma % cannot apply to a task object");
15744 -- Analyze the Boolean expression (if any)
15746 if Present (Arg1) then
15747 Expr := Get_Pragma_Arg (Arg1);
15749 Analyze_And_Resolve (Expr, Standard_Boolean);
15751 if Is_OK_Static_Expression (Expr) then
15753 -- "Ghostness" cannot be turned off once enabled within a
15754 -- region (SPARK RM 6.9(6)).
15756 if Is_False (Expr_Value (Expr))
15757 and then Ghost_Mode > None
15760 ("pragma % with value False cannot appear in enabled "
15765 -- Otherwie the expression is not static
15769 ("expression of pragma % must be static", Expr);
15774 Set_Is_Ghost_Entity (Id);
15781 -- pragma Global (GLOBAL_SPECIFICATION);
15783 -- GLOBAL_SPECIFICATION ::=
15786 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15788 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15790 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15791 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15792 -- GLOBAL_ITEM ::= NAME
15794 -- Characteristics:
15796 -- * Analysis - The annotation undergoes initial checks to verify
15797 -- the legal placement and context. Secondary checks fully analyze
15798 -- the dependency clauses in:
15800 -- Analyze_Global_In_Decl_Part
15802 -- * Expansion - None.
15804 -- * Template - The annotation utilizes the generic template of the
15805 -- related subprogram [body] when it is:
15807 -- aspect on subprogram declaration
15808 -- aspect on stand alone subprogram body
15809 -- pragma on stand alone subprogram body
15811 -- The annotation must prepare its own template when it is:
15813 -- pragma on subprogram declaration
15815 -- * Globals - Capture of global references must occur after full
15818 -- * Instance - The annotation is instantiated automatically when
15819 -- the related generic subprogram [body] is instantiated except for
15820 -- the "pragma on subprogram declaration" case. In that scenario
15821 -- the annotation must instantiate itself.
15823 when Pragma_Global => Global : declare
15825 Spec_Id : Entity_Id;
15826 Subp_Decl : Node_Id;
15829 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15833 -- Chain the pragma on the contract for further processing by
15834 -- Analyze_Global_In_Decl_Part.
15836 Add_Contract_Item (N, Spec_Id);
15838 -- Fully analyze the pragma when it appears inside an entry
15839 -- or subprogram body because it cannot benefit from forward
15842 if Nkind_In (Subp_Decl, N_Entry_Body,
15844 N_Subprogram_Body_Stub)
15846 -- The legality checks of pragmas Depends and Global are
15847 -- affected by the SPARK mode in effect and the volatility
15848 -- of the context. In addition these two pragmas are subject
15849 -- to an inherent order:
15854 -- Analyze all these pragmas in the order outlined above
15856 Analyze_If_Present (Pragma_SPARK_Mode);
15857 Analyze_If_Present (Pragma_Volatile_Function);
15858 Analyze_Global_In_Decl_Part (N);
15859 Analyze_If_Present (Pragma_Depends);
15868 -- pragma Ident (static_string_EXPRESSION)
15870 -- Note: pragma Comment shares this processing. Pragma Ident is
15871 -- identical in effect to pragma Commment.
15873 when Pragma_Comment
15881 Check_Arg_Count (1);
15882 Check_No_Identifiers;
15883 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15886 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15893 GP := Parent (Parent (N));
15895 if Nkind_In (GP, N_Package_Declaration,
15896 N_Generic_Package_Declaration)
15901 -- If we have a compilation unit, then record the ident value,
15902 -- checking for improper duplication.
15904 if Nkind (GP) = N_Compilation_Unit then
15905 CS := Ident_String (Current_Sem_Unit);
15907 if Present (CS) then
15909 -- If we have multiple instances, concatenate them, but
15910 -- not in ASIS, where we want the original tree.
15912 if not ASIS_Mode then
15913 Start_String (Strval (CS));
15914 Store_String_Char (' ');
15915 Store_String_Chars (Strval (Str));
15916 Set_Strval (CS, End_String);
15920 Set_Ident_String (Current_Sem_Unit, Str);
15923 -- For subunits, we just ignore the Ident, since in GNAT these
15924 -- are not separate object files, and hence not separate units
15925 -- in the unit table.
15927 elsif Nkind (GP) = N_Subunit then
15933 -------------------
15934 -- Ignore_Pragma --
15935 -------------------
15937 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15939 -- Entirely handled in the parser, nothing to do here
15941 when Pragma_Ignore_Pragma =>
15944 ----------------------------
15945 -- Implementation_Defined --
15946 ----------------------------
15948 -- pragma Implementation_Defined (LOCAL_NAME);
15950 -- Marks previously declared entity as implementation defined. For
15951 -- an overloaded entity, applies to the most recent homonym.
15953 -- pragma Implementation_Defined;
15955 -- The form with no arguments appears anywhere within a scope, most
15956 -- typically a package spec, and indicates that all entities that are
15957 -- defined within the package spec are Implementation_Defined.
15959 when Pragma_Implementation_Defined => Implementation_Defined : declare
15964 Check_No_Identifiers;
15966 -- Form with no arguments
15968 if Arg_Count = 0 then
15969 Set_Is_Implementation_Defined (Current_Scope);
15971 -- Form with one argument
15974 Check_Arg_Count (1);
15975 Check_Arg_Is_Local_Name (Arg1);
15976 Ent := Entity (Get_Pragma_Arg (Arg1));
15977 Set_Is_Implementation_Defined (Ent);
15979 end Implementation_Defined;
15985 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15987 -- IMPLEMENTATION_KIND ::=
15988 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15990 -- "By_Any" and "Optional" are treated as synonyms in order to
15991 -- support Ada 2012 aspect Synchronization.
15993 when Pragma_Implemented => Implemented : declare
15994 Proc_Id : Entity_Id;
15999 Check_Arg_Count (2);
16000 Check_No_Identifiers;
16001 Check_Arg_Is_Identifier (Arg1);
16002 Check_Arg_Is_Local_Name (Arg1);
16003 Check_Arg_Is_One_Of (Arg2,
16006 Name_By_Protected_Procedure,
16009 -- Extract the name of the local procedure
16011 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
16013 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16014 -- primitive procedure of a synchronized tagged type.
16016 if Ekind (Proc_Id) = E_Procedure
16017 and then Is_Primitive (Proc_Id)
16018 and then Present (First_Formal (Proc_Id))
16020 Typ := Etype (First_Formal (Proc_Id));
16022 if Is_Tagged_Type (Typ)
16025 -- Check for a protected, a synchronized or a task interface
16027 ((Is_Interface (Typ)
16028 and then Is_Synchronized_Interface (Typ))
16030 -- Check for a protected type or a task type that implements
16034 (Is_Concurrent_Record_Type (Typ)
16035 and then Present (Interfaces (Typ)))
16037 -- In analysis-only mode, examine original protected type
16040 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
16041 and then Present (Interface_List (Parent (Typ))))
16043 -- Check for a private record extension with keyword
16047 (Ekind_In (Typ, E_Record_Type_With_Private,
16048 E_Record_Subtype_With_Private)
16049 and then Synchronized_Present (Parent (Typ))))
16054 ("controlling formal must be of synchronized tagged type",
16059 -- Procedures declared inside a protected type must be accepted
16061 elsif Ekind (Proc_Id) = E_Procedure
16062 and then Is_Protected_Type (Scope (Proc_Id))
16066 -- The first argument is not a primitive procedure
16070 ("pragma % must be applied to a primitive procedure", Arg1);
16074 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16075 -- By_Protected_Procedure to the primitive procedure of a task
16078 if Chars (Arg2) = Name_By_Protected_Procedure
16079 and then Is_Interface (Typ)
16080 and then Is_Task_Interface (Typ)
16083 ("implementation kind By_Protected_Procedure cannot be "
16084 & "applied to a task interface primitive", Arg2);
16088 Record_Rep_Item (Proc_Id, N);
16091 ----------------------
16092 -- Implicit_Packing --
16093 ----------------------
16095 -- pragma Implicit_Packing;
16097 when Pragma_Implicit_Packing =>
16099 Check_Arg_Count (0);
16100 Implicit_Packing := True;
16107 -- [Convention =>] convention_IDENTIFIER,
16108 -- [Entity =>] LOCAL_NAME
16109 -- [, [External_Name =>] static_string_EXPRESSION ]
16110 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16112 when Pragma_Import =>
16113 Check_Ada_83_Warning;
16117 Name_External_Name,
16120 Check_At_Least_N_Arguments (2);
16121 Check_At_Most_N_Arguments (4);
16122 Process_Import_Or_Interface;
16124 ---------------------
16125 -- Import_Function --
16126 ---------------------
16128 -- pragma Import_Function (
16129 -- [Internal =>] LOCAL_NAME,
16130 -- [, [External =>] EXTERNAL_SYMBOL]
16131 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16132 -- [, [Result_Type =>] SUBTYPE_MARK]
16133 -- [, [Mechanism =>] MECHANISM]
16134 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16136 -- EXTERNAL_SYMBOL ::=
16138 -- | static_string_EXPRESSION
16140 -- PARAMETER_TYPES ::=
16142 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16144 -- TYPE_DESIGNATOR ::=
16146 -- | subtype_Name ' Access
16150 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16152 -- MECHANISM_ASSOCIATION ::=
16153 -- [formal_parameter_NAME =>] MECHANISM_NAME
16155 -- MECHANISM_NAME ::=
16159 when Pragma_Import_Function => Import_Function : declare
16160 Args : Args_List (1 .. 6);
16161 Names : constant Name_List (1 .. 6) := (
16164 Name_Parameter_Types,
16167 Name_Result_Mechanism);
16169 Internal : Node_Id renames Args (1);
16170 External : Node_Id renames Args (2);
16171 Parameter_Types : Node_Id renames Args (3);
16172 Result_Type : Node_Id renames Args (4);
16173 Mechanism : Node_Id renames Args (5);
16174 Result_Mechanism : Node_Id renames Args (6);
16178 Gather_Associations (Names, Args);
16179 Process_Extended_Import_Export_Subprogram_Pragma (
16180 Arg_Internal => Internal,
16181 Arg_External => External,
16182 Arg_Parameter_Types => Parameter_Types,
16183 Arg_Result_Type => Result_Type,
16184 Arg_Mechanism => Mechanism,
16185 Arg_Result_Mechanism => Result_Mechanism);
16186 end Import_Function;
16188 -------------------
16189 -- Import_Object --
16190 -------------------
16192 -- pragma Import_Object (
16193 -- [Internal =>] LOCAL_NAME
16194 -- [, [External =>] EXTERNAL_SYMBOL]
16195 -- [, [Size =>] EXTERNAL_SYMBOL]);
16197 -- EXTERNAL_SYMBOL ::=
16199 -- | static_string_EXPRESSION
16201 when Pragma_Import_Object => Import_Object : declare
16202 Args : Args_List (1 .. 3);
16203 Names : constant Name_List (1 .. 3) := (
16208 Internal : Node_Id renames Args (1);
16209 External : Node_Id renames Args (2);
16210 Size : Node_Id renames Args (3);
16214 Gather_Associations (Names, Args);
16215 Process_Extended_Import_Export_Object_Pragma (
16216 Arg_Internal => Internal,
16217 Arg_External => External,
16221 ----------------------
16222 -- Import_Procedure --
16223 ----------------------
16225 -- pragma Import_Procedure (
16226 -- [Internal =>] LOCAL_NAME
16227 -- [, [External =>] EXTERNAL_SYMBOL]
16228 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16229 -- [, [Mechanism =>] MECHANISM]);
16231 -- EXTERNAL_SYMBOL ::=
16233 -- | static_string_EXPRESSION
16235 -- PARAMETER_TYPES ::=
16237 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16239 -- TYPE_DESIGNATOR ::=
16241 -- | subtype_Name ' Access
16245 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16247 -- MECHANISM_ASSOCIATION ::=
16248 -- [formal_parameter_NAME =>] MECHANISM_NAME
16250 -- MECHANISM_NAME ::=
16254 when Pragma_Import_Procedure => Import_Procedure : declare
16255 Args : Args_List (1 .. 4);
16256 Names : constant Name_List (1 .. 4) := (
16259 Name_Parameter_Types,
16262 Internal : Node_Id renames Args (1);
16263 External : Node_Id renames Args (2);
16264 Parameter_Types : Node_Id renames Args (3);
16265 Mechanism : Node_Id renames Args (4);
16269 Gather_Associations (Names, Args);
16270 Process_Extended_Import_Export_Subprogram_Pragma (
16271 Arg_Internal => Internal,
16272 Arg_External => External,
16273 Arg_Parameter_Types => Parameter_Types,
16274 Arg_Mechanism => Mechanism);
16275 end Import_Procedure;
16277 -----------------------------
16278 -- Import_Valued_Procedure --
16279 -----------------------------
16281 -- pragma Import_Valued_Procedure (
16282 -- [Internal =>] LOCAL_NAME
16283 -- [, [External =>] EXTERNAL_SYMBOL]
16284 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16285 -- [, [Mechanism =>] MECHANISM]);
16287 -- EXTERNAL_SYMBOL ::=
16289 -- | static_string_EXPRESSION
16291 -- PARAMETER_TYPES ::=
16293 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16295 -- TYPE_DESIGNATOR ::=
16297 -- | subtype_Name ' Access
16301 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16303 -- MECHANISM_ASSOCIATION ::=
16304 -- [formal_parameter_NAME =>] MECHANISM_NAME
16306 -- MECHANISM_NAME ::=
16310 when Pragma_Import_Valued_Procedure =>
16311 Import_Valued_Procedure : declare
16312 Args : Args_List (1 .. 4);
16313 Names : constant Name_List (1 .. 4) := (
16316 Name_Parameter_Types,
16319 Internal : Node_Id renames Args (1);
16320 External : Node_Id renames Args (2);
16321 Parameter_Types : Node_Id renames Args (3);
16322 Mechanism : Node_Id renames Args (4);
16326 Gather_Associations (Names, Args);
16327 Process_Extended_Import_Export_Subprogram_Pragma (
16328 Arg_Internal => Internal,
16329 Arg_External => External,
16330 Arg_Parameter_Types => Parameter_Types,
16331 Arg_Mechanism => Mechanism);
16332 end Import_Valued_Procedure;
16338 -- pragma Independent (LOCAL_NAME);
16340 when Pragma_Independent =>
16341 Process_Atomic_Independent_Shared_Volatile;
16343 ----------------------------
16344 -- Independent_Components --
16345 ----------------------------
16347 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16349 when Pragma_Independent_Components => Independent_Components : declare
16357 Check_Ada_83_Warning;
16359 Check_No_Identifiers;
16360 Check_Arg_Count (1);
16361 Check_Arg_Is_Local_Name (Arg1);
16362 E_Id := Get_Pragma_Arg (Arg1);
16364 if Etype (E_Id) = Any_Type then
16368 E := Entity (E_Id);
16370 -- A pragma that applies to a Ghost entity becomes Ghost for the
16371 -- purposes of legality checks and removal of ignored Ghost code.
16373 Mark_Ghost_Pragma (N, E);
16375 -- Check duplicate before we chain ourselves
16377 Check_Duplicate_Pragma (E);
16379 -- Check appropriate entity
16381 if Rep_Item_Too_Early (E, N)
16383 Rep_Item_Too_Late (E, N)
16388 D := Declaration_Node (E);
16391 -- The flag is set on the base type, or on the object
16393 if K = N_Full_Type_Declaration
16394 and then (Is_Array_Type (E) or else Is_Record_Type (E))
16396 Set_Has_Independent_Components (Base_Type (E));
16397 Record_Independence_Check (N, Base_Type (E));
16399 -- For record type, set all components independent
16401 if Is_Record_Type (E) then
16402 C := First_Component (E);
16403 while Present (C) loop
16404 Set_Is_Independent (C);
16405 Next_Component (C);
16409 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16410 and then Nkind (D) = N_Object_Declaration
16411 and then Nkind (Object_Definition (D)) =
16412 N_Constrained_Array_Definition
16414 Set_Has_Independent_Components (E);
16415 Record_Independence_Check (N, E);
16418 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16420 end Independent_Components;
16422 -----------------------
16423 -- Initial_Condition --
16424 -----------------------
16426 -- pragma Initial_Condition (boolean_EXPRESSION);
16428 -- Characteristics:
16430 -- * Analysis - The annotation undergoes initial checks to verify
16431 -- the legal placement and context. Secondary checks preanalyze the
16434 -- Analyze_Initial_Condition_In_Decl_Part
16436 -- * Expansion - The annotation is expanded during the expansion of
16437 -- the package body whose declaration is subject to the annotation
16440 -- Expand_Pragma_Initial_Condition
16442 -- * Template - The annotation utilizes the generic template of the
16443 -- related package declaration.
16445 -- * Globals - Capture of global references must occur after full
16448 -- * Instance - The annotation is instantiated automatically when
16449 -- the related generic package is instantiated.
16451 when Pragma_Initial_Condition => Initial_Condition : declare
16452 Pack_Decl : Node_Id;
16453 Pack_Id : Entity_Id;
16457 Check_No_Identifiers;
16458 Check_Arg_Count (1);
16460 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16462 -- Ensure the proper placement of the pragma. Initial_Condition
16463 -- must be associated with a package declaration.
16465 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16466 N_Package_Declaration)
16470 -- Otherwise the pragma is associated with an illegal context
16477 Pack_Id := Defining_Entity (Pack_Decl);
16479 -- A pragma that applies to a Ghost entity becomes Ghost for the
16480 -- purposes of legality checks and removal of ignored Ghost code.
16482 Mark_Ghost_Pragma (N, Pack_Id);
16484 -- Chain the pragma on the contract for further processing by
16485 -- Analyze_Initial_Condition_In_Decl_Part.
16487 Add_Contract_Item (N, Pack_Id);
16489 -- The legality checks of pragmas Abstract_State, Initializes, and
16490 -- Initial_Condition are affected by the SPARK mode in effect. In
16491 -- addition, these three pragmas are subject to an inherent order:
16493 -- 1) Abstract_State
16495 -- 3) Initial_Condition
16497 -- Analyze all these pragmas in the order outlined above
16499 Analyze_If_Present (Pragma_SPARK_Mode);
16500 Analyze_If_Present (Pragma_Abstract_State);
16501 Analyze_If_Present (Pragma_Initializes);
16502 end Initial_Condition;
16504 ------------------------
16505 -- Initialize_Scalars --
16506 ------------------------
16508 -- pragma Initialize_Scalars;
16510 when Pragma_Initialize_Scalars =>
16512 Check_Arg_Count (0);
16513 Check_Valid_Configuration_Pragma;
16514 Check_Restriction (No_Initialize_Scalars, N);
16516 -- Initialize_Scalars creates false positives in CodePeer, and
16517 -- incorrect negative results in GNATprove mode, so ignore this
16518 -- pragma in these modes.
16520 if not Restriction_Active (No_Initialize_Scalars)
16521 and then not (CodePeer_Mode or GNATprove_Mode)
16523 Init_Or_Norm_Scalars := True;
16524 Initialize_Scalars := True;
16531 -- pragma Initializes (INITIALIZATION_LIST);
16533 -- INITIALIZATION_LIST ::=
16535 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16537 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16542 -- | (INPUT {, INPUT})
16546 -- Characteristics:
16548 -- * Analysis - The annotation undergoes initial checks to verify
16549 -- the legal placement and context. Secondary checks preanalyze the
16552 -- Analyze_Initializes_In_Decl_Part
16554 -- * Expansion - None.
16556 -- * Template - The annotation utilizes the generic template of the
16557 -- related package declaration.
16559 -- * Globals - Capture of global references must occur after full
16562 -- * Instance - The annotation is instantiated automatically when
16563 -- the related generic package is instantiated.
16565 when Pragma_Initializes => Initializes : declare
16566 Pack_Decl : Node_Id;
16567 Pack_Id : Entity_Id;
16571 Check_No_Identifiers;
16572 Check_Arg_Count (1);
16574 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16576 -- Ensure the proper placement of the pragma. Initializes must be
16577 -- associated with a package declaration.
16579 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16580 N_Package_Declaration)
16584 -- Otherwise the pragma is associated with an illegal construc
16591 Pack_Id := Defining_Entity (Pack_Decl);
16593 -- A pragma that applies to a Ghost entity becomes Ghost for the
16594 -- purposes of legality checks and removal of ignored Ghost code.
16596 Mark_Ghost_Pragma (N, Pack_Id);
16597 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16599 -- Chain the pragma on the contract for further processing by
16600 -- Analyze_Initializes_In_Decl_Part.
16602 Add_Contract_Item (N, Pack_Id);
16604 -- The legality checks of pragmas Abstract_State, Initializes, and
16605 -- Initial_Condition are affected by the SPARK mode in effect. In
16606 -- addition, these three pragmas are subject to an inherent order:
16608 -- 1) Abstract_State
16610 -- 3) Initial_Condition
16612 -- Analyze all these pragmas in the order outlined above
16614 Analyze_If_Present (Pragma_SPARK_Mode);
16615 Analyze_If_Present (Pragma_Abstract_State);
16616 Analyze_If_Present (Pragma_Initial_Condition);
16623 -- pragma Inline ( NAME {, NAME} );
16625 when Pragma_Inline =>
16627 -- Pragma always active unless in GNATprove mode. It is disabled
16628 -- in GNATprove mode because frontend inlining is applied
16629 -- independently of pragmas Inline and Inline_Always for
16630 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16633 if not GNATprove_Mode then
16635 -- Inline status is Enabled if option -gnatn is specified.
16636 -- However this status determines only the value of the
16637 -- Is_Inlined flag on the subprogram and does not prevent
16638 -- the pragma itself from being recorded for later use,
16639 -- in particular for a later modification of Is_Inlined
16640 -- independently of the -gnatn option.
16642 -- In other words, if -gnatn is specified for a unit, then
16643 -- all Inline pragmas processed for the compilation of this
16644 -- unit, including those in the spec of other units, are
16645 -- activated, so subprograms will be inlined across units.
16647 -- If -gnatn is not specified, no Inline pragma is activated
16648 -- here, which means that subprograms will not be inlined
16649 -- across units. The Is_Inlined flag will nevertheless be
16650 -- set later when bodies are analyzed, so subprograms will
16651 -- be inlined within the unit.
16653 if Inline_Active then
16654 Process_Inline (Enabled);
16656 Process_Inline (Disabled);
16660 -------------------
16661 -- Inline_Always --
16662 -------------------
16664 -- pragma Inline_Always ( NAME {, NAME} );
16666 when Pragma_Inline_Always =>
16669 -- Pragma always active unless in CodePeer mode or GNATprove
16670 -- mode. It is disabled in CodePeer mode because inlining is
16671 -- not helpful, and enabling it caused walk order issues. It
16672 -- is disabled in GNATprove mode because frontend inlining is
16673 -- applied independently of pragmas Inline and Inline_Always for
16674 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16677 if not CodePeer_Mode and not GNATprove_Mode then
16678 Process_Inline (Enabled);
16681 --------------------
16682 -- Inline_Generic --
16683 --------------------
16685 -- pragma Inline_Generic (NAME {, NAME});
16687 when Pragma_Inline_Generic =>
16689 Process_Generic_List;
16691 ----------------------
16692 -- Inspection_Point --
16693 ----------------------
16695 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16697 when Pragma_Inspection_Point => Inspection_Point : declare
16704 if Arg_Count > 0 then
16707 Exp := Get_Pragma_Arg (Arg);
16710 if not Is_Entity_Name (Exp)
16711 or else not Is_Object (Entity (Exp))
16713 Error_Pragma_Arg ("object name required", Arg);
16717 exit when No (Arg);
16720 end Inspection_Point;
16726 -- pragma Interface (
16727 -- [ Convention =>] convention_IDENTIFIER,
16728 -- [ Entity =>] LOCAL_NAME
16729 -- [, [External_Name =>] static_string_EXPRESSION ]
16730 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16732 when Pragma_Interface =>
16737 Name_External_Name,
16739 Check_At_Least_N_Arguments (2);
16740 Check_At_Most_N_Arguments (4);
16741 Process_Import_Or_Interface;
16743 -- In Ada 2005, the permission to use Interface (a reserved word)
16744 -- as a pragma name is considered an obsolescent feature, and this
16745 -- pragma was already obsolescent in Ada 95.
16747 if Ada_Version >= Ada_95 then
16749 (No_Obsolescent_Features, Pragma_Identifier (N));
16751 if Warn_On_Obsolescent_Feature then
16753 ("pragma Interface is an obsolescent feature?j?", N);
16755 ("|use pragma Import instead?j?", N);
16759 --------------------
16760 -- Interface_Name --
16761 --------------------
16763 -- pragma Interface_Name (
16764 -- [ Entity =>] LOCAL_NAME
16765 -- [,[External_Name =>] static_string_EXPRESSION ]
16766 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16768 when Pragma_Interface_Name => Interface_Name : declare
16770 Def_Id : Entity_Id;
16771 Hom_Id : Entity_Id;
16777 ((Name_Entity, Name_External_Name, Name_Link_Name));
16778 Check_At_Least_N_Arguments (2);
16779 Check_At_Most_N_Arguments (3);
16780 Id := Get_Pragma_Arg (Arg1);
16783 -- This is obsolete from Ada 95 on, but it is an implementation
16784 -- defined pragma, so we do not consider that it violates the
16785 -- restriction (No_Obsolescent_Features).
16787 if Ada_Version >= Ada_95 then
16788 if Warn_On_Obsolescent_Feature then
16790 ("pragma Interface_Name is an obsolescent feature?j?", N);
16792 ("|use pragma Import instead?j?", N);
16796 if not Is_Entity_Name (Id) then
16798 ("first argument for pragma% must be entity name", Arg1);
16799 elsif Etype (Id) = Any_Type then
16802 Def_Id := Entity (Id);
16805 -- Special DEC-compatible processing for the object case, forces
16806 -- object to be imported.
16808 if Ekind (Def_Id) = E_Variable then
16809 Kill_Size_Check_Code (Def_Id);
16810 Note_Possible_Modification (Id, Sure => False);
16812 -- Initialization is not allowed for imported variable
16814 if Present (Expression (Parent (Def_Id)))
16815 and then Comes_From_Source (Expression (Parent (Def_Id)))
16817 Error_Msg_Sloc := Sloc (Def_Id);
16819 ("no initialization allowed for declaration of& #",
16823 -- For compatibility, support VADS usage of providing both
16824 -- pragmas Interface and Interface_Name to obtain the effect
16825 -- of a single Import pragma.
16827 if Is_Imported (Def_Id)
16828 and then Present (First_Rep_Item (Def_Id))
16829 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16830 and then Pragma_Name (First_Rep_Item (Def_Id)) =
16835 Set_Imported (Def_Id);
16838 Set_Is_Public (Def_Id);
16839 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16842 -- Otherwise must be subprogram
16844 elsif not Is_Subprogram (Def_Id) then
16846 ("argument of pragma% is not subprogram", Arg1);
16849 Check_At_Most_N_Arguments (3);
16853 -- Loop through homonyms
16856 Def_Id := Get_Base_Subprogram (Hom_Id);
16858 if Is_Imported (Def_Id) then
16859 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16863 exit when From_Aspect_Specification (N);
16864 Hom_Id := Homonym (Hom_Id);
16866 exit when No (Hom_Id)
16867 or else Scope (Hom_Id) /= Current_Scope;
16872 ("argument of pragma% is not imported subprogram",
16876 end Interface_Name;
16878 -----------------------
16879 -- Interrupt_Handler --
16880 -----------------------
16882 -- pragma Interrupt_Handler (handler_NAME);
16884 when Pragma_Interrupt_Handler =>
16885 Check_Ada_83_Warning;
16886 Check_Arg_Count (1);
16887 Check_No_Identifiers;
16889 if No_Run_Time_Mode then
16890 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16892 Check_Interrupt_Or_Attach_Handler;
16893 Process_Interrupt_Or_Attach_Handler;
16896 ------------------------
16897 -- Interrupt_Priority --
16898 ------------------------
16900 -- pragma Interrupt_Priority [(EXPRESSION)];
16902 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16903 P : constant Node_Id := Parent (N);
16908 Check_Ada_83_Warning;
16910 if Arg_Count /= 0 then
16911 Arg := Get_Pragma_Arg (Arg1);
16912 Check_Arg_Count (1);
16913 Check_No_Identifiers;
16915 -- The expression must be analyzed in the special manner
16916 -- described in "Handling of Default and Per-Object
16917 -- Expressions" in sem.ads.
16919 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16922 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16927 Ent := Defining_Identifier (Parent (P));
16929 -- Check duplicate pragma before we chain the pragma in the Rep
16930 -- Item chain of Ent.
16932 Check_Duplicate_Pragma (Ent);
16933 Record_Rep_Item (Ent, N);
16935 -- Check the No_Task_At_Interrupt_Priority restriction
16937 if Nkind (P) = N_Task_Definition then
16938 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16941 end Interrupt_Priority;
16943 ---------------------
16944 -- Interrupt_State --
16945 ---------------------
16947 -- pragma Interrupt_State (
16948 -- [Name =>] INTERRUPT_ID,
16949 -- [State =>] INTERRUPT_STATE);
16951 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16952 -- INTERRUPT_STATE => System | Runtime | User
16954 -- Note: if the interrupt id is given as an identifier, then it must
16955 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16956 -- given as a static integer expression which must be in the range of
16957 -- Ada.Interrupts.Interrupt_ID.
16959 when Pragma_Interrupt_State => Interrupt_State : declare
16960 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16961 -- This is the entity Ada.Interrupts.Interrupt_ID;
16963 State_Type : Character;
16964 -- Set to 's'/'r'/'u' for System/Runtime/User
16967 -- Index to entry in Interrupt_States table
16970 -- Value of interrupt
16972 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16973 -- The first argument to the pragma
16975 Int_Ent : Entity_Id;
16976 -- Interrupt entity in Ada.Interrupts.Names
16980 Check_Arg_Order ((Name_Name, Name_State));
16981 Check_Arg_Count (2);
16983 Check_Optional_Identifier (Arg1, Name_Name);
16984 Check_Optional_Identifier (Arg2, Name_State);
16985 Check_Arg_Is_Identifier (Arg2);
16987 -- First argument is identifier
16989 if Nkind (Arg1X) = N_Identifier then
16991 -- Search list of names in Ada.Interrupts.Names
16993 Int_Ent := First_Entity (RTE (RE_Names));
16995 if No (Int_Ent) then
16996 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16998 elsif Chars (Int_Ent) = Chars (Arg1X) then
16999 Int_Val := Expr_Value (Constant_Value (Int_Ent));
17003 Next_Entity (Int_Ent);
17006 -- First argument is not an identifier, so it must be a static
17007 -- expression of type Ada.Interrupts.Interrupt_ID.
17010 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
17011 Int_Val := Expr_Value (Arg1X);
17013 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
17015 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
17018 ("value not in range of type "
17019 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
17025 case Chars (Get_Pragma_Arg (Arg2)) is
17026 when Name_Runtime => State_Type := 'r';
17027 when Name_System => State_Type := 's';
17028 when Name_User => State_Type := 'u';
17031 Error_Pragma_Arg ("invalid interrupt state", Arg2);
17034 -- Check if entry is already stored
17036 IST_Num := Interrupt_States.First;
17038 -- If entry not found, add it
17040 if IST_Num > Interrupt_States.Last then
17041 Interrupt_States.Append
17042 ((Interrupt_Number => UI_To_Int (Int_Val),
17043 Interrupt_State => State_Type,
17044 Pragma_Loc => Loc));
17047 -- Case of entry for the same entry
17049 elsif Int_Val = Interrupt_States.Table (IST_Num).
17052 -- If state matches, done, no need to make redundant entry
17055 State_Type = Interrupt_States.Table (IST_Num).
17058 -- Otherwise if state does not match, error
17061 Interrupt_States.Table (IST_Num).Pragma_Loc;
17063 ("state conflicts with that given #", Arg2);
17067 IST_Num := IST_Num + 1;
17069 end Interrupt_State;
17075 -- pragma Invariant
17076 -- ([Entity =>] type_LOCAL_NAME,
17077 -- [Check =>] EXPRESSION
17078 -- [,[Message =>] String_Expression]);
17080 when Pragma_Invariant => Invariant : declare
17087 Check_At_Least_N_Arguments (2);
17088 Check_At_Most_N_Arguments (3);
17089 Check_Optional_Identifier (Arg1, Name_Entity);
17090 Check_Optional_Identifier (Arg2, Name_Check);
17092 if Arg_Count = 3 then
17093 Check_Optional_Identifier (Arg3, Name_Message);
17094 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
17097 Check_Arg_Is_Local_Name (Arg1);
17099 Typ_Arg := Get_Pragma_Arg (Arg1);
17100 Find_Type (Typ_Arg);
17101 Typ := Entity (Typ_Arg);
17103 -- Nothing to do of the related type is erroneous in some way
17105 if Typ = Any_Type then
17108 -- AI12-0041: Invariants are allowed in interface types
17110 elsif Is_Interface (Typ) then
17113 -- An invariant must apply to a private type, or appear in the
17114 -- private part of a package spec and apply to a completion.
17115 -- a class-wide invariant can only appear on a private declaration
17116 -- or private extension, not a completion.
17118 -- A [class-wide] invariant may be associated a [limited] private
17119 -- type or a private extension.
17121 elsif Ekind_In (Typ, E_Limited_Private_Type,
17123 E_Record_Type_With_Private)
17127 -- A non-class-wide invariant may be associated with the full view
17128 -- of a [limited] private type or a private extension.
17130 elsif Has_Private_Declaration (Typ)
17131 and then not Class_Present (N)
17135 -- A class-wide invariant may appear on the partial view only
17137 elsif Class_Present (N) then
17139 ("pragma % only allowed for private type", Arg1);
17142 -- A regular invariant may appear on both views
17146 ("pragma % only allowed for private type or corresponding "
17147 & "full view", Arg1);
17151 -- An invariant associated with an abstract type (this includes
17152 -- interfaces) must be class-wide.
17154 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
17156 ("pragma % not allowed for abstract type", Arg1);
17160 -- A pragma that applies to a Ghost entity becomes Ghost for the
17161 -- purposes of legality checks and removal of ignored Ghost code.
17163 Mark_Ghost_Pragma (N, Typ);
17165 -- The pragma defines a type-specific invariant, the type is said
17166 -- to have invariants of its "own".
17168 Set_Has_Own_Invariants (Typ);
17170 -- If the invariant is class-wide, then it can be inherited by
17171 -- derived or interface implementing types. The type is said to
17172 -- have "inheritable" invariants.
17174 if Class_Present (N) then
17175 Set_Has_Inheritable_Invariants (Typ);
17178 -- Chain the pragma on to the rep item chain, for processing when
17179 -- the type is frozen.
17181 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
17183 -- Create the declaration of the invariant procedure that will
17184 -- verify the invariant at run time. Interfaces are treated as the
17185 -- partial view of a private type in order to achieve uniformity
17186 -- with the general case. As a result, an interface receives only
17187 -- a "partial" invariant procedure, which is never called.
17189 Build_Invariant_Procedure_Declaration
17191 Partial_Invariant => Is_Interface (Typ));
17198 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17200 when Pragma_Keep_Names => Keep_Names : declare
17205 Check_Arg_Count (1);
17206 Check_Optional_Identifier (Arg1, Name_On);
17207 Check_Arg_Is_Local_Name (Arg1);
17209 Arg := Get_Pragma_Arg (Arg1);
17212 if Etype (Arg) = Any_Type then
17216 if not Is_Entity_Name (Arg)
17217 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
17220 ("pragma% requires a local enumeration type", Arg1);
17223 Set_Discard_Names (Entity (Arg), False);
17230 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17232 when Pragma_License =>
17235 -- Do not analyze pragma any further in CodePeer mode, to avoid
17236 -- extraneous errors in this implementation-dependent pragma,
17237 -- which has a different profile on other compilers.
17239 if CodePeer_Mode then
17243 Check_Arg_Count (1);
17244 Check_No_Identifiers;
17245 Check_Valid_Configuration_Pragma;
17246 Check_Arg_Is_Identifier (Arg1);
17249 Sind : constant Source_File_Index :=
17250 Source_Index (Current_Sem_Unit);
17253 case Chars (Get_Pragma_Arg (Arg1)) is
17255 Set_License (Sind, GPL);
17257 when Name_Modified_GPL =>
17258 Set_License (Sind, Modified_GPL);
17260 when Name_Restricted =>
17261 Set_License (Sind, Restricted);
17263 when Name_Unrestricted =>
17264 Set_License (Sind, Unrestricted);
17267 Error_Pragma_Arg ("invalid license name", Arg1);
17275 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17277 when Pragma_Link_With => Link_With : declare
17283 if Operating_Mode = Generate_Code
17284 and then In_Extended_Main_Source_Unit (N)
17286 Check_At_Least_N_Arguments (1);
17287 Check_No_Identifiers;
17288 Check_Is_In_Decl_Part_Or_Package_Spec;
17289 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17293 while Present (Arg) loop
17294 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17296 -- Store argument, converting sequences of spaces to a
17297 -- single null character (this is one of the differences
17298 -- in processing between Link_With and Linker_Options).
17300 Arg_Store : declare
17301 C : constant Char_Code := Get_Char_Code (' ');
17302 S : constant String_Id :=
17303 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17304 L : constant Nat := String_Length (S);
17307 procedure Skip_Spaces;
17308 -- Advance F past any spaces
17314 procedure Skip_Spaces is
17316 while F <= L and then Get_String_Char (S, F) = C loop
17321 -- Start of processing for Arg_Store
17324 Skip_Spaces; -- skip leading spaces
17326 -- Loop through characters, changing any embedded
17327 -- sequence of spaces to a single null character (this
17328 -- is how Link_With/Linker_Options differ)
17331 if Get_String_Char (S, F) = C then
17334 Store_String_Char (ASCII.NUL);
17337 Store_String_Char (Get_String_Char (S, F));
17345 if Present (Arg) then
17346 Store_String_Char (ASCII.NUL);
17350 Store_Linker_Option_String (End_String);
17358 -- pragma Linker_Alias (
17359 -- [Entity =>] LOCAL_NAME
17360 -- [Target =>] static_string_EXPRESSION);
17362 when Pragma_Linker_Alias =>
17364 Check_Arg_Order ((Name_Entity, Name_Target));
17365 Check_Arg_Count (2);
17366 Check_Optional_Identifier (Arg1, Name_Entity);
17367 Check_Optional_Identifier (Arg2, Name_Target);
17368 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17369 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17371 -- The only processing required is to link this item on to the
17372 -- list of rep items for the given entity. This is accomplished
17373 -- by the call to Rep_Item_Too_Late (when no error is detected
17374 -- and False is returned).
17376 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17379 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17382 ------------------------
17383 -- Linker_Constructor --
17384 ------------------------
17386 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17388 -- Code is shared with Linker_Destructor
17390 -----------------------
17391 -- Linker_Destructor --
17392 -----------------------
17394 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17396 when Pragma_Linker_Constructor
17397 | Pragma_Linker_Destructor
17399 Linker_Constructor : declare
17405 Check_Arg_Count (1);
17406 Check_No_Identifiers;
17407 Check_Arg_Is_Local_Name (Arg1);
17408 Arg1_X := Get_Pragma_Arg (Arg1);
17410 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17412 if not Is_Library_Level_Entity (Proc) then
17414 ("argument for pragma% must be library level entity", Arg1);
17417 -- The only processing required is to link this item on to the
17418 -- list of rep items for the given entity. This is accomplished
17419 -- by the call to Rep_Item_Too_Late (when no error is detected
17420 -- and False is returned).
17422 if Rep_Item_Too_Late (Proc, N) then
17425 Set_Has_Gigi_Rep_Item (Proc);
17427 end Linker_Constructor;
17429 --------------------
17430 -- Linker_Options --
17431 --------------------
17433 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17435 when Pragma_Linker_Options => Linker_Options : declare
17439 Check_Ada_83_Warning;
17440 Check_No_Identifiers;
17441 Check_Arg_Count (1);
17442 Check_Is_In_Decl_Part_Or_Package_Spec;
17443 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17444 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17447 while Present (Arg) loop
17448 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17449 Store_String_Char (ASCII.NUL);
17451 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17455 if Operating_Mode = Generate_Code
17456 and then In_Extended_Main_Source_Unit (N)
17458 Store_Linker_Option_String (End_String);
17460 end Linker_Options;
17462 --------------------
17463 -- Linker_Section --
17464 --------------------
17466 -- pragma Linker_Section (
17467 -- [Entity =>] LOCAL_NAME
17468 -- [Section =>] static_string_EXPRESSION);
17470 when Pragma_Linker_Section => Linker_Section : declare
17475 Ghost_Error_Posted : Boolean := False;
17476 -- Flag set when an error concerning the illegal mix of Ghost and
17477 -- non-Ghost subprograms is emitted.
17479 Ghost_Id : Entity_Id := Empty;
17480 -- The entity of the first Ghost subprogram encountered while
17481 -- processing the arguments of the pragma.
17485 Check_Arg_Order ((Name_Entity, Name_Section));
17486 Check_Arg_Count (2);
17487 Check_Optional_Identifier (Arg1, Name_Entity);
17488 Check_Optional_Identifier (Arg2, Name_Section);
17489 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17490 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17492 -- Check kind of entity
17494 Arg := Get_Pragma_Arg (Arg1);
17495 Ent := Entity (Arg);
17497 case Ekind (Ent) is
17499 -- Objects (constants and variables) and types. For these cases
17500 -- all we need to do is to set the Linker_Section_pragma field,
17501 -- checking that we do not have a duplicate.
17507 LPE := Linker_Section_Pragma (Ent);
17509 if Present (LPE) then
17510 Error_Msg_Sloc := Sloc (LPE);
17512 ("Linker_Section already specified for &#", Arg1, Ent);
17515 Set_Linker_Section_Pragma (Ent, N);
17517 -- A pragma that applies to a Ghost entity becomes Ghost for
17518 -- the purposes of legality checks and removal of ignored
17521 Mark_Ghost_Pragma (N, Ent);
17525 when Subprogram_Kind =>
17527 -- Aspect case, entity already set
17529 if From_Aspect_Specification (N) then
17530 Set_Linker_Section_Pragma
17531 (Entity (Corresponding_Aspect (N)), N);
17533 -- Pragma case, we must climb the homonym chain, but skip
17534 -- any for which the linker section is already set.
17538 if No (Linker_Section_Pragma (Ent)) then
17539 Set_Linker_Section_Pragma (Ent, N);
17541 -- A pragma that applies to a Ghost entity becomes
17542 -- Ghost for the purposes of legality checks and
17543 -- removal of ignored Ghost code.
17545 Mark_Ghost_Pragma (N, Ent);
17547 -- Capture the entity of the first Ghost subprogram
17548 -- being processed for error detection purposes.
17550 if Is_Ghost_Entity (Ent) then
17551 if No (Ghost_Id) then
17555 -- Otherwise the subprogram is non-Ghost. It is
17556 -- illegal to mix references to Ghost and non-Ghost
17557 -- entities (SPARK RM 6.9).
17559 elsif Present (Ghost_Id)
17560 and then not Ghost_Error_Posted
17562 Ghost_Error_Posted := True;
17564 Error_Msg_Name_1 := Pname;
17566 ("pragma % cannot mention ghost and "
17567 & "non-ghost subprograms", N);
17569 Error_Msg_Sloc := Sloc (Ghost_Id);
17571 ("\& # declared as ghost", N, Ghost_Id);
17573 Error_Msg_Sloc := Sloc (Ent);
17575 ("\& # declared as non-ghost", N, Ent);
17579 Ent := Homonym (Ent);
17581 or else Scope (Ent) /= Current_Scope;
17585 -- All other cases are illegal
17589 ("pragma% applies only to objects, subprograms, and types",
17592 end Linker_Section;
17598 -- pragma List (On | Off)
17600 -- There is nothing to do here, since we did all the processing for
17601 -- this pragma in Par.Prag (so that it works properly even in syntax
17604 when Pragma_List =>
17611 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17613 when Pragma_Lock_Free => Lock_Free : declare
17614 P : constant Node_Id := Parent (N);
17620 Check_No_Identifiers;
17621 Check_At_Most_N_Arguments (1);
17623 -- Protected definition case
17625 if Nkind (P) = N_Protected_Definition then
17626 Ent := Defining_Identifier (Parent (P));
17630 if Arg_Count = 1 then
17631 Arg := Get_Pragma_Arg (Arg1);
17632 Val := Is_True (Static_Boolean (Arg));
17634 -- No arguments (expression is considered to be True)
17640 -- Check duplicate pragma before we chain the pragma in the Rep
17641 -- Item chain of Ent.
17643 Check_Duplicate_Pragma (Ent);
17644 Record_Rep_Item (Ent, N);
17645 Set_Uses_Lock_Free (Ent, Val);
17647 -- Anything else is incorrect placement
17654 --------------------
17655 -- Locking_Policy --
17656 --------------------
17658 -- pragma Locking_Policy (policy_IDENTIFIER);
17660 when Pragma_Locking_Policy => declare
17661 subtype LP_Range is Name_Id
17662 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17667 Check_Ada_83_Warning;
17668 Check_Arg_Count (1);
17669 Check_No_Identifiers;
17670 Check_Arg_Is_Locking_Policy (Arg1);
17671 Check_Valid_Configuration_Pragma;
17672 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17675 when Name_Ceiling_Locking => LP := 'C';
17676 when Name_Concurrent_Readers_Locking => LP := 'R';
17677 when Name_Inheritance_Locking => LP := 'I';
17680 if Locking_Policy /= ' '
17681 and then Locking_Policy /= LP
17683 Error_Msg_Sloc := Locking_Policy_Sloc;
17684 Error_Pragma ("locking policy incompatible with policy#");
17686 -- Set new policy, but always preserve System_Location since we
17687 -- like the error message with the run time name.
17690 Locking_Policy := LP;
17692 if Locking_Policy_Sloc /= System_Location then
17693 Locking_Policy_Sloc := Loc;
17698 -------------------
17699 -- Loop_Optimize --
17700 -------------------
17702 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17704 -- OPTIMIZATION_HINT ::=
17705 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17707 when Pragma_Loop_Optimize => Loop_Optimize : declare
17712 Check_At_Least_N_Arguments (1);
17713 Check_No_Identifiers;
17715 Hint := First (Pragma_Argument_Associations (N));
17716 while Present (Hint) loop
17717 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17725 Check_Loop_Pragma_Placement;
17732 -- pragma Loop_Variant
17733 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17735 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17737 -- CHANGE_DIRECTION ::= Increases | Decreases
17739 when Pragma_Loop_Variant => Loop_Variant : declare
17744 Check_At_Least_N_Arguments (1);
17745 Check_Loop_Pragma_Placement;
17747 -- Process all increasing / decreasing expressions
17749 Variant := First (Pragma_Argument_Associations (N));
17750 while Present (Variant) loop
17751 if not Nam_In (Chars (Variant), Name_Decreases,
17754 Error_Pragma_Arg ("wrong change modifier", Variant);
17757 Preanalyze_Assert_Expression
17758 (Expression (Variant), Any_Discrete);
17764 -----------------------
17765 -- Machine_Attribute --
17766 -----------------------
17768 -- pragma Machine_Attribute (
17769 -- [Entity =>] LOCAL_NAME,
17770 -- [Attribute_Name =>] static_string_EXPRESSION
17771 -- [, [Info =>] static_EXPRESSION] );
17773 when Pragma_Machine_Attribute => Machine_Attribute : declare
17774 Def_Id : Entity_Id;
17778 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17780 if Arg_Count = 3 then
17781 Check_Optional_Identifier (Arg3, Name_Info);
17782 Check_Arg_Is_OK_Static_Expression (Arg3);
17784 Check_Arg_Count (2);
17787 Check_Optional_Identifier (Arg1, Name_Entity);
17788 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17789 Check_Arg_Is_Local_Name (Arg1);
17790 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17791 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17793 if Is_Access_Type (Def_Id) then
17794 Def_Id := Designated_Type (Def_Id);
17797 if Rep_Item_Too_Early (Def_Id, N) then
17801 Def_Id := Underlying_Type (Def_Id);
17803 -- The only processing required is to link this item on to the
17804 -- list of rep items for the given entity. This is accomplished
17805 -- by the call to Rep_Item_Too_Late (when no error is detected
17806 -- and False is returned).
17808 if Rep_Item_Too_Late (Def_Id, N) then
17811 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17813 end Machine_Attribute;
17820 -- (MAIN_OPTION [, MAIN_OPTION]);
17823 -- [STACK_SIZE =>] static_integer_EXPRESSION
17824 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17825 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17827 when Pragma_Main => Main : declare
17828 Args : Args_List (1 .. 3);
17829 Names : constant Name_List (1 .. 3) := (
17831 Name_Task_Stack_Size_Default,
17832 Name_Time_Slicing_Enabled);
17838 Gather_Associations (Names, Args);
17840 for J in 1 .. 2 loop
17841 if Present (Args (J)) then
17842 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17846 if Present (Args (3)) then
17847 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17851 while Present (Nod) loop
17852 if Nkind (Nod) = N_Pragma
17853 and then Pragma_Name (Nod) = Name_Main
17855 Error_Msg_Name_1 := Pname;
17856 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17867 -- pragma Main_Storage
17868 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17870 -- MAIN_STORAGE_OPTION ::=
17871 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17872 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17874 when Pragma_Main_Storage => Main_Storage : declare
17875 Args : Args_List (1 .. 2);
17876 Names : constant Name_List (1 .. 2) := (
17877 Name_Working_Storage,
17884 Gather_Associations (Names, Args);
17886 for J in 1 .. 2 loop
17887 if Present (Args (J)) then
17888 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17892 Check_In_Main_Program;
17895 while Present (Nod) loop
17896 if Nkind (Nod) = N_Pragma
17897 and then Pragma_Name (Nod) = Name_Main_Storage
17899 Error_Msg_Name_1 := Pname;
17900 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17907 ----------------------
17908 -- Max_Queue_Length --
17909 ----------------------
17911 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17913 when Pragma_Max_Queue_Length => Max_Queue_Length : declare
17915 Entry_Decl : Node_Id;
17916 Entry_Id : Entity_Id;
17921 Check_Arg_Count (1);
17924 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
17926 -- Entry declaration
17928 if Nkind (Entry_Decl) = N_Entry_Declaration then
17930 -- Entry illegally within a task
17932 if Nkind (Parent (N)) = N_Task_Definition then
17933 Error_Pragma ("pragma % cannot apply to task entries");
17937 Entry_Id := Unique_Defining_Entity (Entry_Decl);
17939 -- Otherwise the pragma is associated with an illegal construct
17942 Error_Pragma ("pragma % must apply to a protected entry");
17946 -- Mark the pragma as Ghost if the related subprogram is also
17947 -- Ghost. This also ensures that any expansion performed further
17948 -- below will produce Ghost nodes.
17950 Mark_Ghost_Pragma (N, Entry_Id);
17952 -- Analyze the Integer expression
17954 Arg := Get_Pragma_Arg (Arg1);
17955 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
17957 Val := Expr_Value (Arg);
17961 ("argument for pragma% must be positive", Arg1);
17963 elsif not UI_Is_In_Int_Range (Val) then
17965 ("argument for pragma% out of range of Integer", Arg1);
17969 -- Manually substitute the expression value of the pragma argument
17970 -- if it's not an integer literal because this is not taken care
17971 -- of automatically elsewhere.
17973 if Nkind (Arg) /= N_Integer_Literal then
17974 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
17977 Record_Rep_Item (Entry_Id, N);
17978 end Max_Queue_Length;
17984 -- pragma Memory_Size (NUMERIC_LITERAL)
17986 when Pragma_Memory_Size =>
17989 -- Memory size is simply ignored
17991 Check_No_Identifiers;
17992 Check_Arg_Count (1);
17993 Check_Arg_Is_Integer_Literal (Arg1);
18001 -- The only correct use of this pragma is on its own in a file, in
18002 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18003 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18004 -- check for a file containing nothing but a No_Body pragma). If we
18005 -- attempt to process it during normal semantics processing, it means
18006 -- it was misplaced.
18008 when Pragma_No_Body =>
18012 -----------------------------
18013 -- No_Elaboration_Code_All --
18014 -----------------------------
18016 -- pragma No_Elaboration_Code_All;
18018 when Pragma_No_Elaboration_Code_All =>
18020 Check_Valid_Library_Unit_Pragma;
18022 if Nkind (N) = N_Null_Statement then
18026 -- Must appear for a spec or generic spec
18028 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
18029 N_Generic_Package_Declaration,
18030 N_Generic_Subprogram_Declaration,
18031 N_Package_Declaration,
18032 N_Subprogram_Declaration)
18036 ("pragma% can only occur for package "
18037 & "or subprogram spec"));
18040 -- Set flag in unit table
18042 Set_No_Elab_Code_All (Current_Sem_Unit);
18044 -- Set restriction No_Elaboration_Code if this is the main unit
18046 if Current_Sem_Unit = Main_Unit then
18047 Set_Restriction (No_Elaboration_Code, N);
18050 -- If we are in the main unit or in an extended main source unit,
18051 -- then we also add it to the configuration restrictions so that
18052 -- it will apply to all units in the extended main source.
18054 if Current_Sem_Unit = Main_Unit
18055 or else In_Extended_Main_Source_Unit (N)
18057 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
18060 -- If in main extended unit, activate transitive with test
18062 if In_Extended_Main_Source_Unit (N) then
18063 Opt.No_Elab_Code_All_Pragma := N;
18066 -----------------------------
18067 -- No_Component_Reordering --
18068 -----------------------------
18070 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18072 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
18078 Check_At_Most_N_Arguments (1);
18080 if Arg_Count = 0 then
18081 Check_Valid_Configuration_Pragma;
18082 Opt.No_Component_Reordering := True;
18085 Check_Optional_Identifier (Arg2, Name_Entity);
18086 Check_Arg_Is_Local_Name (Arg1);
18087 E_Id := Get_Pragma_Arg (Arg1);
18089 if Etype (E_Id) = Any_Type then
18093 E := Entity (E_Id);
18095 if not Is_Record_Type (E) then
18096 Error_Pragma_Arg ("pragma% requires record type", Arg1);
18099 Set_No_Reordering (Base_Type (E));
18101 end No_Comp_Reordering;
18103 --------------------------
18104 -- No_Heap_Finalization --
18105 --------------------------
18107 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18109 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
18110 Context : constant Node_Id := Parent (N);
18111 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
18117 Check_No_Identifiers;
18119 -- The pragma appears in a configuration file
18121 if No (Context) then
18122 Check_Arg_Count (0);
18123 Check_Valid_Configuration_Pragma;
18125 -- Detect a duplicate pragma
18127 if Present (No_Heap_Finalization_Pragma) then
18130 Prev => No_Heap_Finalization_Pragma);
18134 No_Heap_Finalization_Pragma := N;
18136 -- Otherwise the pragma should be associated with a library-level
18137 -- named access-to-object type.
18140 Check_Arg_Count (1);
18141 Check_Arg_Is_Local_Name (Arg1);
18143 Find_Type (Typ_Arg);
18144 Typ := Entity (Typ_Arg);
18146 -- The type being subjected to the pragma is erroneous
18148 if Typ = Any_Type then
18149 Error_Pragma ("cannot find type referenced by pragma %");
18151 -- The pragma is applied to an incomplete or generic formal
18152 -- type way too early.
18154 elsif Rep_Item_Too_Early (Typ, N) then
18158 Typ := Underlying_Type (Typ);
18161 -- The pragma must apply to an access-to-object type
18163 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
18166 -- Give a detailed error message on all other access type kinds
18168 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
18170 ("pragma % cannot apply to access protected subprogram "
18173 elsif Ekind (Typ) = E_Access_Subprogram_Type then
18175 ("pragma % cannot apply to access subprogram type");
18177 elsif Is_Anonymous_Access_Type (Typ) then
18179 ("pragma % cannot apply to anonymous access type");
18181 -- Give a general error message in case the pragma applies to a
18182 -- non-access type.
18186 ("pragma % must apply to library level access type");
18189 -- At this point the argument denotes an access-to-object type.
18190 -- Ensure that the type is declared at the library level.
18192 if Is_Library_Level_Entity (Typ) then
18195 -- Quietly ignore an access-to-object type originally declared
18196 -- at the library level within a generic, but instantiated at
18197 -- a non-library level. As a result the access-to-object type
18198 -- "loses" its No_Heap_Finalization property.
18200 elsif In_Instance then
18205 ("pragma % must apply to library level access type");
18208 -- Detect a duplicate pragma
18210 if Present (No_Heap_Finalization_Pragma) then
18213 Prev => No_Heap_Finalization_Pragma);
18217 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
18219 if Present (Prev) then
18227 Record_Rep_Item (Typ, N);
18229 end No_Heap_Finalization;
18235 -- pragma No_Inline ( NAME {, NAME} );
18237 when Pragma_No_Inline =>
18239 Process_Inline (Suppressed);
18245 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18247 when Pragma_No_Return => No_Return : declare
18253 Ghost_Error_Posted : Boolean := False;
18254 -- Flag set when an error concerning the illegal mix of Ghost and
18255 -- non-Ghost subprograms is emitted.
18257 Ghost_Id : Entity_Id := Empty;
18258 -- The entity of the first Ghost procedure encountered while
18259 -- processing the arguments of the pragma.
18263 Check_At_Least_N_Arguments (1);
18265 -- Loop through arguments of pragma
18268 while Present (Arg) loop
18269 Check_Arg_Is_Local_Name (Arg);
18270 Id := Get_Pragma_Arg (Arg);
18273 if not Is_Entity_Name (Id) then
18274 Error_Pragma_Arg ("entity name required", Arg);
18277 if Etype (Id) = Any_Type then
18281 -- Loop to find matching procedures
18287 and then Scope (E) = Current_Scope
18289 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
18291 -- Check that the pragma is not applied to a body.
18292 -- First check the specless body case, to give a
18293 -- different error message. These checks do not apply
18294 -- if Relaxed_RM_Semantics, to accommodate other Ada
18295 -- compilers. Disable these checks under -gnatd.J.
18297 if not Debug_Flag_Dot_JJ then
18298 if Nkind (Parent (Declaration_Node (E))) =
18300 and then not Relaxed_RM_Semantics
18303 ("pragma% requires separate spec and must come "
18307 -- Now the "specful" body case
18309 if Rep_Item_Too_Late (E, N) then
18316 -- A pragma that applies to a Ghost entity becomes Ghost
18317 -- for the purposes of legality checks and removal of
18318 -- ignored Ghost code.
18320 Mark_Ghost_Pragma (N, E);
18322 -- Capture the entity of the first Ghost procedure being
18323 -- processed for error detection purposes.
18325 if Is_Ghost_Entity (E) then
18326 if No (Ghost_Id) then
18330 -- Otherwise the subprogram is non-Ghost. It is illegal
18331 -- to mix references to Ghost and non-Ghost entities
18334 elsif Present (Ghost_Id)
18335 and then not Ghost_Error_Posted
18337 Ghost_Error_Posted := True;
18339 Error_Msg_Name_1 := Pname;
18341 ("pragma % cannot mention ghost and non-ghost "
18342 & "procedures", N);
18344 Error_Msg_Sloc := Sloc (Ghost_Id);
18345 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
18347 Error_Msg_Sloc := Sloc (E);
18348 Error_Msg_NE ("\& # declared as non-ghost", N, E);
18351 -- Set flag on any alias as well
18353 if Is_Overloadable (E) and then Present (Alias (E)) then
18354 Set_No_Return (Alias (E));
18360 exit when From_Aspect_Specification (N);
18364 -- If entity in not in current scope it may be the enclosing
18365 -- suprogram body to which the aspect applies.
18368 if Entity (Id) = Current_Scope
18369 and then From_Aspect_Specification (N)
18371 Set_No_Return (Entity (Id));
18373 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
18385 -- pragma No_Run_Time;
18387 -- Note: this pragma is retained for backwards compatibility. See
18388 -- body of Rtsfind for full details on its handling.
18390 when Pragma_No_Run_Time =>
18392 Check_Valid_Configuration_Pragma;
18393 Check_Arg_Count (0);
18395 -- Remove backward compatibility if Build_Type is FSF or GPL and
18396 -- generate a warning.
18399 Ignore : constant Boolean := Build_Type in FSF .. GPL;
18402 Error_Pragma ("pragma% is ignored, has no effect??");
18404 No_Run_Time_Mode := True;
18405 Configurable_Run_Time_Mode := True;
18407 -- Set Duration to 32 bits if word size is 32
18409 if Ttypes.System_Word_Size = 32 then
18410 Duration_32_Bits_On_Target := True;
18413 -- Set appropriate restrictions
18415 Set_Restriction (No_Finalization, N);
18416 Set_Restriction (No_Exception_Handlers, N);
18417 Set_Restriction (Max_Tasks, N, 0);
18418 Set_Restriction (No_Tasking, N);
18422 -----------------------
18423 -- No_Tagged_Streams --
18424 -----------------------
18426 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18428 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
18434 Check_At_Most_N_Arguments (1);
18436 -- One argument case
18438 if Arg_Count = 1 then
18439 Check_Optional_Identifier (Arg1, Name_Entity);
18440 Check_Arg_Is_Local_Name (Arg1);
18441 E_Id := Get_Pragma_Arg (Arg1);
18443 if Etype (E_Id) = Any_Type then
18447 E := Entity (E_Id);
18449 Check_Duplicate_Pragma (E);
18451 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
18453 ("argument for pragma% must be root tagged type", Arg1);
18456 if Rep_Item_Too_Early (E, N)
18458 Rep_Item_Too_Late (E, N)
18462 Set_No_Tagged_Streams_Pragma (E, N);
18465 -- Zero argument case
18468 Check_Is_In_Decl_Part_Or_Package_Spec;
18469 No_Tagged_Streams := N;
18471 end No_Tagged_Strms;
18473 ------------------------
18474 -- No_Strict_Aliasing --
18475 ------------------------
18477 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18479 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
18485 Check_At_Most_N_Arguments (1);
18487 if Arg_Count = 0 then
18488 Check_Valid_Configuration_Pragma;
18489 Opt.No_Strict_Aliasing := True;
18492 Check_Optional_Identifier (Arg2, Name_Entity);
18493 Check_Arg_Is_Local_Name (Arg1);
18494 E_Id := Get_Pragma_Arg (Arg1);
18496 if Etype (E_Id) = Any_Type then
18500 E := Entity (E_Id);
18502 if not Is_Access_Type (E) then
18503 Error_Pragma_Arg ("pragma% requires access type", Arg1);
18506 Set_No_Strict_Aliasing (Base_Type (E));
18508 end No_Strict_Aliasing;
18510 -----------------------
18511 -- Normalize_Scalars --
18512 -----------------------
18514 -- pragma Normalize_Scalars;
18516 when Pragma_Normalize_Scalars =>
18517 Check_Ada_83_Warning;
18518 Check_Arg_Count (0);
18519 Check_Valid_Configuration_Pragma;
18521 -- Normalize_Scalars creates false positives in CodePeer, and
18522 -- incorrect negative results in GNATprove mode, so ignore this
18523 -- pragma in these modes.
18525 if not (CodePeer_Mode or GNATprove_Mode) then
18526 Normalize_Scalars := True;
18527 Init_Or_Norm_Scalars := True;
18534 -- pragma Obsolescent;
18536 -- pragma Obsolescent (
18537 -- [Message =>] static_string_EXPRESSION
18538 -- [,[Version =>] Ada_05]]);
18540 -- pragma Obsolescent (
18541 -- [Entity =>] NAME
18542 -- [,[Message =>] static_string_EXPRESSION
18543 -- [,[Version =>] Ada_05]] );
18545 when Pragma_Obsolescent => Obsolescent : declare
18549 procedure Set_Obsolescent (E : Entity_Id);
18550 -- Given an entity Ent, mark it as obsolescent if appropriate
18552 ---------------------
18553 -- Set_Obsolescent --
18554 ---------------------
18556 procedure Set_Obsolescent (E : Entity_Id) is
18565 -- A pragma that applies to a Ghost entity becomes Ghost for
18566 -- the purposes of legality checks and removal of ignored Ghost
18569 Mark_Ghost_Pragma (N, E);
18571 -- Entity name was given
18573 if Present (Ename) then
18575 -- If entity name matches, we are fine. Save entity in
18576 -- pragma argument, for ASIS use.
18578 if Chars (Ename) = Chars (Ent) then
18579 Set_Entity (Ename, Ent);
18580 Generate_Reference (Ent, Ename);
18582 -- If entity name does not match, only possibility is an
18583 -- enumeration literal from an enumeration type declaration.
18585 elsif Ekind (Ent) /= E_Enumeration_Type then
18587 ("pragma % entity name does not match declaration");
18590 Ent := First_Literal (E);
18594 ("pragma % entity name does not match any "
18595 & "enumeration literal");
18597 elsif Chars (Ent) = Chars (Ename) then
18598 Set_Entity (Ename, Ent);
18599 Generate_Reference (Ent, Ename);
18603 Ent := Next_Literal (Ent);
18609 -- Ent points to entity to be marked
18611 if Arg_Count >= 1 then
18613 -- Deal with static string argument
18615 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18616 S := Strval (Get_Pragma_Arg (Arg1));
18618 for J in 1 .. String_Length (S) loop
18619 if not In_Character_Range (Get_String_Char (S, J)) then
18621 ("pragma% argument does not allow wide characters",
18626 Obsolescent_Warnings.Append
18627 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18629 -- Check for Ada_05 parameter
18631 if Arg_Count /= 1 then
18632 Check_Arg_Count (2);
18635 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18638 Check_Arg_Is_Identifier (Argx);
18640 if Chars (Argx) /= Name_Ada_05 then
18641 Error_Msg_Name_2 := Name_Ada_05;
18643 ("only allowed argument for pragma% is %", Argx);
18646 if Ada_Version_Explicit < Ada_2005
18647 or else not Warn_On_Ada_2005_Compatibility
18655 -- Set flag if pragma active
18658 Set_Is_Obsolescent (Ent);
18662 end Set_Obsolescent;
18664 -- Start of processing for pragma Obsolescent
18669 Check_At_Most_N_Arguments (3);
18671 -- See if first argument specifies an entity name
18675 (Chars (Arg1) = Name_Entity
18677 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18679 N_Operator_Symbol))
18681 Ename := Get_Pragma_Arg (Arg1);
18683 -- Eliminate first argument, so we can share processing
18687 Arg_Count := Arg_Count - 1;
18689 -- No Entity name argument given
18695 if Arg_Count >= 1 then
18696 Check_Optional_Identifier (Arg1, Name_Message);
18698 if Arg_Count = 2 then
18699 Check_Optional_Identifier (Arg2, Name_Version);
18703 -- Get immediately preceding declaration
18706 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18710 -- Cases where we do not follow anything other than another pragma
18714 -- First case: library level compilation unit declaration with
18715 -- the pragma immediately following the declaration.
18717 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18719 (Defining_Entity (Unit (Parent (Parent (N)))));
18722 -- Case 2: library unit placement for package
18726 Ent : constant Entity_Id := Find_Lib_Unit_Name;
18728 if Is_Package_Or_Generic_Package (Ent) then
18729 Set_Obsolescent (Ent);
18735 -- Cases where we must follow a declaration, including an
18736 -- abstract subprogram declaration, which is not in the
18737 -- other node subtypes.
18740 if Nkind (Decl) not in N_Declaration
18741 and then Nkind (Decl) not in N_Later_Decl_Item
18742 and then Nkind (Decl) not in N_Generic_Declaration
18743 and then Nkind (Decl) not in N_Renaming_Declaration
18744 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18747 ("pragma% misplaced, "
18748 & "must immediately follow a declaration");
18751 Set_Obsolescent (Defining_Entity (Decl));
18761 -- pragma Optimize (Time | Space | Off);
18763 -- The actual check for optimize is done in Gigi. Note that this
18764 -- pragma does not actually change the optimization setting, it
18765 -- simply checks that it is consistent with the pragma.
18767 when Pragma_Optimize =>
18768 Check_No_Identifiers;
18769 Check_Arg_Count (1);
18770 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18772 ------------------------
18773 -- Optimize_Alignment --
18774 ------------------------
18776 -- pragma Optimize_Alignment (Time | Space | Off);
18778 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18780 Check_No_Identifiers;
18781 Check_Arg_Count (1);
18782 Check_Valid_Configuration_Pragma;
18785 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18788 when Name_Off => Opt.Optimize_Alignment := 'O';
18789 when Name_Space => Opt.Optimize_Alignment := 'S';
18790 when Name_Time => Opt.Optimize_Alignment := 'T';
18793 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18797 -- Set indication that mode is set locally. If we are in fact in a
18798 -- configuration pragma file, this setting is harmless since the
18799 -- switch will get reset anyway at the start of each unit.
18801 Optimize_Alignment_Local := True;
18802 end Optimize_Alignment;
18808 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18810 when Pragma_Ordered => Ordered : declare
18811 Assoc : constant Node_Id := Arg1;
18817 Check_No_Identifiers;
18818 Check_Arg_Count (1);
18819 Check_Arg_Is_Local_Name (Arg1);
18821 Type_Id := Get_Pragma_Arg (Assoc);
18822 Find_Type (Type_Id);
18823 Typ := Entity (Type_Id);
18825 if Typ = Any_Type then
18828 Typ := Underlying_Type (Typ);
18831 if not Is_Enumeration_Type (Typ) then
18832 Error_Pragma ("pragma% must specify enumeration type");
18835 Check_First_Subtype (Arg1);
18836 Set_Has_Pragma_Ordered (Base_Type (Typ));
18839 -------------------
18840 -- Overflow_Mode --
18841 -------------------
18843 -- pragma Overflow_Mode
18844 -- ([General => ] MODE [, [Assertions => ] MODE]);
18846 -- MODE := STRICT | MINIMIZED | ELIMINATED
18848 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18849 -- since System.Bignums makes this assumption. This is true of nearly
18850 -- all (all?) targets.
18852 when Pragma_Overflow_Mode => Overflow_Mode : declare
18853 function Get_Overflow_Mode
18855 Arg : Node_Id) return Overflow_Mode_Type;
18856 -- Function to process one pragma argument, Arg. If an identifier
18857 -- is present, it must be Name. Mode type is returned if a valid
18858 -- argument exists, otherwise an error is signalled.
18860 -----------------------
18861 -- Get_Overflow_Mode --
18862 -----------------------
18864 function Get_Overflow_Mode
18866 Arg : Node_Id) return Overflow_Mode_Type
18868 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18871 Check_Optional_Identifier (Arg, Name);
18872 Check_Arg_Is_Identifier (Argx);
18874 if Chars (Argx) = Name_Strict then
18877 elsif Chars (Argx) = Name_Minimized then
18880 elsif Chars (Argx) = Name_Eliminated then
18881 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18883 ("Eliminated not implemented on this target", Argx);
18889 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18891 end Get_Overflow_Mode;
18893 -- Start of processing for Overflow_Mode
18897 Check_At_Least_N_Arguments (1);
18898 Check_At_Most_N_Arguments (2);
18900 -- Process first argument
18902 Scope_Suppress.Overflow_Mode_General :=
18903 Get_Overflow_Mode (Name_General, Arg1);
18905 -- Case of only one argument
18907 if Arg_Count = 1 then
18908 Scope_Suppress.Overflow_Mode_Assertions :=
18909 Scope_Suppress.Overflow_Mode_General;
18911 -- Case of two arguments present
18914 Scope_Suppress.Overflow_Mode_Assertions :=
18915 Get_Overflow_Mode (Name_Assertions, Arg2);
18919 --------------------------
18920 -- Overriding Renamings --
18921 --------------------------
18923 -- pragma Overriding_Renamings;
18925 when Pragma_Overriding_Renamings =>
18927 Check_Arg_Count (0);
18928 Check_Valid_Configuration_Pragma;
18929 Overriding_Renamings := True;
18935 -- pragma Pack (first_subtype_LOCAL_NAME);
18937 when Pragma_Pack => Pack : declare
18938 Assoc : constant Node_Id := Arg1;
18940 Ignore : Boolean := False;
18945 Check_No_Identifiers;
18946 Check_Arg_Count (1);
18947 Check_Arg_Is_Local_Name (Arg1);
18948 Type_Id := Get_Pragma_Arg (Assoc);
18950 if not Is_Entity_Name (Type_Id)
18951 or else not Is_Type (Entity (Type_Id))
18954 ("argument for pragma% must be type or subtype", Arg1);
18957 Find_Type (Type_Id);
18958 Typ := Entity (Type_Id);
18961 or else Rep_Item_Too_Early (Typ, N)
18965 Typ := Underlying_Type (Typ);
18968 -- A pragma that applies to a Ghost entity becomes Ghost for the
18969 -- purposes of legality checks and removal of ignored Ghost code.
18971 Mark_Ghost_Pragma (N, Typ);
18973 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18974 Error_Pragma ("pragma% must specify array or record type");
18977 Check_First_Subtype (Arg1);
18978 Check_Duplicate_Pragma (Typ);
18982 if Is_Array_Type (Typ) then
18983 Ctyp := Component_Type (Typ);
18985 -- Ignore pack that does nothing
18987 if Known_Static_Esize (Ctyp)
18988 and then Known_Static_RM_Size (Ctyp)
18989 and then Esize (Ctyp) = RM_Size (Ctyp)
18990 and then Addressable (Esize (Ctyp))
18995 -- Process OK pragma Pack. Note that if there is a separate
18996 -- component clause present, the Pack will be cancelled. This
18997 -- processing is in Freeze.
18999 if not Rep_Item_Too_Late (Typ, N) then
19001 -- In CodePeer mode, we do not need complex front-end
19002 -- expansions related to pragma Pack, so disable handling
19005 if CodePeer_Mode then
19008 -- Normal case where we do the pack action
19012 Set_Is_Packed (Base_Type (Typ));
19013 Set_Has_Non_Standard_Rep (Base_Type (Typ));
19016 Set_Has_Pragma_Pack (Base_Type (Typ));
19020 -- For record types, the pack is always effective
19022 else pragma Assert (Is_Record_Type (Typ));
19023 if not Rep_Item_Too_Late (Typ, N) then
19024 Set_Is_Packed (Base_Type (Typ));
19025 Set_Has_Pragma_Pack (Base_Type (Typ));
19026 Set_Has_Non_Standard_Rep (Base_Type (Typ));
19037 -- There is nothing to do here, since we did all the processing for
19038 -- this pragma in Par.Prag (so that it works properly even in syntax
19041 when Pragma_Page =>
19048 -- pragma Part_Of (ABSTRACT_STATE);
19050 -- ABSTRACT_STATE ::= NAME
19052 when Pragma_Part_Of => Part_Of : declare
19053 procedure Propagate_Part_Of
19054 (Pack_Id : Entity_Id;
19055 State_Id : Entity_Id;
19056 Instance : Node_Id);
19057 -- Propagate the Part_Of indicator to all abstract states and
19058 -- objects declared in the visible state space of a package
19059 -- denoted by Pack_Id. State_Id is the encapsulating state.
19060 -- Instance is the package instantiation node.
19062 -----------------------
19063 -- Propagate_Part_Of --
19064 -----------------------
19066 procedure Propagate_Part_Of
19067 (Pack_Id : Entity_Id;
19068 State_Id : Entity_Id;
19069 Instance : Node_Id)
19071 Has_Item : Boolean := False;
19072 -- Flag set when the visible state space contains at least one
19073 -- abstract state or variable.
19075 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
19076 -- Propagate the Part_Of indicator to all abstract states and
19077 -- objects declared in the visible state space of a package
19078 -- denoted by Pack_Id.
19080 -----------------------
19081 -- Propagate_Part_Of --
19082 -----------------------
19084 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
19085 Constits : Elist_Id;
19086 Item_Id : Entity_Id;
19089 -- Traverse the entity chain of the package and set relevant
19090 -- attributes of abstract states and objects declared in the
19091 -- visible state space of the package.
19093 Item_Id := First_Entity (Pack_Id);
19094 while Present (Item_Id)
19095 and then not In_Private_Part (Item_Id)
19097 -- Do not consider internally generated items
19099 if not Comes_From_Source (Item_Id) then
19102 -- The Part_Of indicator turns an abstract state or an
19103 -- object into a constituent of the encapsulating state.
19105 elsif Ekind_In (Item_Id, E_Abstract_State,
19110 Constits := Part_Of_Constituents (State_Id);
19112 if No (Constits) then
19113 Constits := New_Elmt_List;
19114 Set_Part_Of_Constituents (State_Id, Constits);
19117 Append_Elmt (Item_Id, Constits);
19118 Set_Encapsulating_State (Item_Id, State_Id);
19120 -- Recursively handle nested packages and instantiations
19122 elsif Ekind (Item_Id) = E_Package then
19123 Propagate_Part_Of (Item_Id);
19126 Next_Entity (Item_Id);
19128 end Propagate_Part_Of;
19130 -- Start of processing for Propagate_Part_Of
19133 Propagate_Part_Of (Pack_Id);
19135 -- Detect a package instantiation that is subject to a Part_Of
19136 -- indicator, but has no visible state.
19138 if not Has_Item then
19140 ("package instantiation & has Part_Of indicator but "
19141 & "lacks visible state", Instance, Pack_Id);
19143 end Propagate_Part_Of;
19147 Constits : Elist_Id;
19149 Encap_Id : Entity_Id;
19150 Item_Id : Entity_Id;
19154 -- Start of processing for Part_Of
19158 Check_No_Identifiers;
19159 Check_Arg_Count (1);
19161 Stmt := Find_Related_Context (N, Do_Checks => True);
19163 -- Object declaration
19165 if Nkind (Stmt) = N_Object_Declaration then
19168 -- Package instantiation
19170 elsif Nkind (Stmt) = N_Package_Instantiation then
19173 -- Single concurrent type declaration
19175 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
19178 -- Otherwise the pragma is associated with an illegal construct
19185 -- Extract the entity of the related object declaration or package
19186 -- instantiation. In the case of the instantiation, use the entity
19187 -- of the instance spec.
19189 if Nkind (Stmt) = N_Package_Instantiation then
19190 Stmt := Instance_Spec (Stmt);
19193 Item_Id := Defining_Entity (Stmt);
19195 -- A pragma that applies to a Ghost entity becomes Ghost for the
19196 -- purposes of legality checks and removal of ignored Ghost code.
19198 Mark_Ghost_Pragma (N, Item_Id);
19200 -- Chain the pragma on the contract for further processing by
19201 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19203 Add_Contract_Item (N, Item_Id);
19205 -- A variable may act as constituent of a single concurrent type
19206 -- which in turn could be declared after the variable. Due to this
19207 -- discrepancy, the full analysis of indicator Part_Of is delayed
19208 -- until the end of the enclosing declarative region (see routine
19209 -- Analyze_Part_Of_In_Decl_Part).
19211 if Ekind (Item_Id) = E_Variable then
19214 -- Otherwise indicator Part_Of applies to a constant or a package
19218 Encap := Get_Pragma_Arg (Arg1);
19220 -- Detect any discrepancies between the placement of the
19221 -- constant or package instantiation with respect to state
19222 -- space and the encapsulating state.
19226 Item_Id => Item_Id,
19228 Encap_Id => Encap_Id,
19232 pragma Assert (Present (Encap_Id));
19234 if Ekind (Item_Id) = E_Constant then
19235 Constits := Part_Of_Constituents (Encap_Id);
19237 if No (Constits) then
19238 Constits := New_Elmt_List;
19239 Set_Part_Of_Constituents (Encap_Id, Constits);
19242 Append_Elmt (Item_Id, Constits);
19243 Set_Encapsulating_State (Item_Id, Encap_Id);
19245 -- Propagate the Part_Of indicator to the visible state
19246 -- space of the package instantiation.
19250 (Pack_Id => Item_Id,
19251 State_Id => Encap_Id,
19258 ----------------------------------
19259 -- Partition_Elaboration_Policy --
19260 ----------------------------------
19262 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19264 when Pragma_Partition_Elaboration_Policy => PEP : declare
19265 subtype PEP_Range is Name_Id
19266 range First_Partition_Elaboration_Policy_Name
19267 .. Last_Partition_Elaboration_Policy_Name;
19268 PEP_Val : PEP_Range;
19273 Check_Arg_Count (1);
19274 Check_No_Identifiers;
19275 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
19276 Check_Valid_Configuration_Pragma;
19277 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
19280 when Name_Concurrent => PEP := 'C';
19281 when Name_Sequential => PEP := 'S';
19284 if Partition_Elaboration_Policy /= ' '
19285 and then Partition_Elaboration_Policy /= PEP
19287 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
19289 ("partition elaboration policy incompatible with policy#");
19291 -- Set new policy, but always preserve System_Location since we
19292 -- like the error message with the run time name.
19295 Partition_Elaboration_Policy := PEP;
19297 if Partition_Elaboration_Policy_Sloc /= System_Location then
19298 Partition_Elaboration_Policy_Sloc := Loc;
19307 -- pragma Passive [(PASSIVE_FORM)];
19309 -- PASSIVE_FORM ::= Semaphore | No
19311 when Pragma_Passive =>
19314 if Nkind (Parent (N)) /= N_Task_Definition then
19315 Error_Pragma ("pragma% must be within task definition");
19318 if Arg_Count /= 0 then
19319 Check_Arg_Count (1);
19320 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
19323 ----------------------------------
19324 -- Preelaborable_Initialization --
19325 ----------------------------------
19327 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19329 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
19334 Check_Arg_Count (1);
19335 Check_No_Identifiers;
19336 Check_Arg_Is_Identifier (Arg1);
19337 Check_Arg_Is_Local_Name (Arg1);
19338 Check_First_Subtype (Arg1);
19339 Ent := Entity (Get_Pragma_Arg (Arg1));
19341 -- A pragma that applies to a Ghost entity becomes Ghost for the
19342 -- purposes of legality checks and removal of ignored Ghost code.
19344 Mark_Ghost_Pragma (N, Ent);
19346 -- The pragma may come from an aspect on a private declaration,
19347 -- even if the freeze point at which this is analyzed in the
19348 -- private part after the full view.
19350 if Has_Private_Declaration (Ent)
19351 and then From_Aspect_Specification (N)
19355 -- Check appropriate type argument
19357 elsif Is_Private_Type (Ent)
19358 or else Is_Protected_Type (Ent)
19359 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
19361 -- AI05-0028: The pragma applies to all composite types. Note
19362 -- that we apply this binding interpretation to earlier versions
19363 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19364 -- choice since there are other compilers that do the same.
19366 or else Is_Composite_Type (Ent)
19372 ("pragma % can only be applied to private, formal derived, "
19373 & "protected, or composite type", Arg1);
19376 -- Give an error if the pragma is applied to a protected type that
19377 -- does not qualify (due to having entries, or due to components
19378 -- that do not qualify).
19380 if Is_Protected_Type (Ent)
19381 and then not Has_Preelaborable_Initialization (Ent)
19384 ("protected type & does not have preelaborable "
19385 & "initialization", Ent);
19387 -- Otherwise mark the type as definitely having preelaborable
19391 Set_Known_To_Have_Preelab_Init (Ent);
19394 if Has_Pragma_Preelab_Init (Ent)
19395 and then Warn_On_Redundant_Constructs
19397 Error_Pragma ("?r?duplicate pragma%!");
19399 Set_Has_Pragma_Preelab_Init (Ent);
19403 --------------------
19404 -- Persistent_BSS --
19405 --------------------
19407 -- pragma Persistent_BSS [(object_NAME)];
19409 when Pragma_Persistent_BSS => Persistent_BSS : declare
19416 Check_At_Most_N_Arguments (1);
19418 -- Case of application to specific object (one argument)
19420 if Arg_Count = 1 then
19421 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19423 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
19425 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
19428 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
19431 Ent := Entity (Get_Pragma_Arg (Arg1));
19433 -- A pragma that applies to a Ghost entity becomes Ghost for
19434 -- the purposes of legality checks and removal of ignored Ghost
19437 Mark_Ghost_Pragma (N, Ent);
19439 -- Check for duplication before inserting in list of
19440 -- representation items.
19442 Check_Duplicate_Pragma (Ent);
19444 if Rep_Item_Too_Late (Ent, N) then
19448 Decl := Parent (Ent);
19450 if Present (Expression (Decl)) then
19452 ("object for pragma% cannot have initialization", Arg1);
19455 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
19457 ("object type for pragma% is not potentially persistent",
19462 Make_Linker_Section_Pragma
19463 (Ent, Sloc (N), ".persistent.bss");
19464 Insert_After (N, Prag);
19467 -- Case of use as configuration pragma with no arguments
19470 Check_Valid_Configuration_Pragma;
19471 Persistent_BSS_Mode := True;
19473 end Persistent_BSS;
19475 --------------------
19476 -- Rename_Pragma --
19477 --------------------
19479 -- pragma Rename_Pragma (
19480 -- [New_Name =>] IDENTIFIER,
19481 -- [Renamed =>] pragma_IDENTIFIER);
19483 when Pragma_Rename_Pragma => Rename_Pragma : declare
19484 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
19485 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
19489 Check_Valid_Configuration_Pragma;
19490 Check_Arg_Count (2);
19491 Check_Optional_Identifier (Arg1, Name_New_Name);
19492 Check_Optional_Identifier (Arg2, Name_Renamed);
19494 if Nkind (New_Name) /= N_Identifier then
19495 Error_Pragma_Arg ("identifier expected", Arg1);
19498 if Nkind (Old_Name) /= N_Identifier then
19499 Error_Pragma_Arg ("identifier expected", Arg2);
19502 -- The New_Name arg should not be an existing pragma (but we allow
19503 -- it; it's just a warning). The Old_Name arg must be an existing
19506 if Is_Pragma_Name (Chars (New_Name)) then
19507 Error_Pragma_Arg ("??pragma is already defined", Arg1);
19510 if not Is_Pragma_Name (Chars (Old_Name)) then
19511 Error_Pragma_Arg ("existing pragma name expected", Arg1);
19514 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
19521 -- pragma Polling (ON | OFF);
19523 when Pragma_Polling =>
19525 Check_Arg_Count (1);
19526 Check_No_Identifiers;
19527 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19528 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
19530 -----------------------------------
19531 -- Post/Post_Class/Postcondition --
19532 -----------------------------------
19534 -- pragma Post (Boolean_EXPRESSION);
19535 -- pragma Post_Class (Boolean_EXPRESSION);
19536 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19537 -- [,[Message =>] String_EXPRESSION]);
19539 -- Characteristics:
19541 -- * Analysis - The annotation undergoes initial checks to verify
19542 -- the legal placement and context. Secondary checks preanalyze the
19545 -- Analyze_Pre_Post_Condition_In_Decl_Part
19547 -- * Expansion - The annotation is expanded during the expansion of
19548 -- the related subprogram [body] contract as performed in:
19550 -- Expand_Subprogram_Contract
19552 -- * Template - The annotation utilizes the generic template of the
19553 -- related subprogram [body] when it is:
19555 -- aspect on subprogram declaration
19556 -- aspect on stand alone subprogram body
19557 -- pragma on stand alone subprogram body
19559 -- The annotation must prepare its own template when it is:
19561 -- pragma on subprogram declaration
19563 -- * Globals - Capture of global references must occur after full
19566 -- * Instance - The annotation is instantiated automatically when
19567 -- the related generic subprogram [body] is instantiated except for
19568 -- the "pragma on subprogram declaration" case. In that scenario
19569 -- the annotation must instantiate itself.
19572 | Pragma_Post_Class
19573 | Pragma_Postcondition
19575 Analyze_Pre_Post_Condition;
19577 --------------------------------
19578 -- Pre/Pre_Class/Precondition --
19579 --------------------------------
19581 -- pragma Pre (Boolean_EXPRESSION);
19582 -- pragma Pre_Class (Boolean_EXPRESSION);
19583 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19584 -- [,[Message =>] String_EXPRESSION]);
19586 -- Characteristics:
19588 -- * Analysis - The annotation undergoes initial checks to verify
19589 -- the legal placement and context. Secondary checks preanalyze the
19592 -- Analyze_Pre_Post_Condition_In_Decl_Part
19594 -- * Expansion - The annotation is expanded during the expansion of
19595 -- the related subprogram [body] contract as performed in:
19597 -- Expand_Subprogram_Contract
19599 -- * Template - The annotation utilizes the generic template of the
19600 -- related subprogram [body] when it is:
19602 -- aspect on subprogram declaration
19603 -- aspect on stand alone subprogram body
19604 -- pragma on stand alone subprogram body
19606 -- The annotation must prepare its own template when it is:
19608 -- pragma on subprogram declaration
19610 -- * Globals - Capture of global references must occur after full
19613 -- * Instance - The annotation is instantiated automatically when
19614 -- the related generic subprogram [body] is instantiated except for
19615 -- the "pragma on subprogram declaration" case. In that scenario
19616 -- the annotation must instantiate itself.
19620 | Pragma_Precondition
19622 Analyze_Pre_Post_Condition;
19628 -- pragma Predicate
19629 -- ([Entity =>] type_LOCAL_NAME,
19630 -- [Check =>] boolean_EXPRESSION);
19632 when Pragma_Predicate => Predicate : declare
19639 Check_Arg_Count (2);
19640 Check_Optional_Identifier (Arg1, Name_Entity);
19641 Check_Optional_Identifier (Arg2, Name_Check);
19643 Check_Arg_Is_Local_Name (Arg1);
19645 Type_Id := Get_Pragma_Arg (Arg1);
19646 Find_Type (Type_Id);
19647 Typ := Entity (Type_Id);
19649 if Typ = Any_Type then
19653 -- A pragma that applies to a Ghost entity becomes Ghost for the
19654 -- purposes of legality checks and removal of ignored Ghost code.
19656 Mark_Ghost_Pragma (N, Typ);
19658 -- The remaining processing is simply to link the pragma on to
19659 -- the rep item chain, for processing when the type is frozen.
19660 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19661 -- mark the type as having predicates.
19663 -- If the current policy for predicate checking is Ignore mark the
19664 -- subtype accordingly. In the case of predicates we consider them
19665 -- enabled unless Ignore is specified (either directly or with a
19666 -- general Assertion_Policy pragma) to preserve existing warnings.
19668 Set_Has_Predicates (Typ);
19669 Set_Predicates_Ignored (Typ,
19670 Present (Check_Policy_List)
19672 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
19673 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19676 -----------------------
19677 -- Predicate_Failure --
19678 -----------------------
19680 -- pragma Predicate_Failure
19681 -- ([Entity =>] type_LOCAL_NAME,
19682 -- [Message =>] string_EXPRESSION);
19684 when Pragma_Predicate_Failure => Predicate_Failure : declare
19691 Check_Arg_Count (2);
19692 Check_Optional_Identifier (Arg1, Name_Entity);
19693 Check_Optional_Identifier (Arg2, Name_Message);
19695 Check_Arg_Is_Local_Name (Arg1);
19697 Type_Id := Get_Pragma_Arg (Arg1);
19698 Find_Type (Type_Id);
19699 Typ := Entity (Type_Id);
19701 if Typ = Any_Type then
19705 -- A pragma that applies to a Ghost entity becomes Ghost for the
19706 -- purposes of legality checks and removal of ignored Ghost code.
19708 Mark_Ghost_Pragma (N, Typ);
19710 -- The remaining processing is simply to link the pragma on to
19711 -- the rep item chain, for processing when the type is frozen.
19712 -- This is accomplished by a call to Rep_Item_Too_Late.
19714 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19715 end Predicate_Failure;
19721 -- pragma Preelaborate [(library_unit_NAME)];
19723 -- Set the flag Is_Preelaborated of program unit name entity
19725 when Pragma_Preelaborate => Preelaborate : declare
19726 Pa : constant Node_Id := Parent (N);
19727 Pk : constant Node_Kind := Nkind (Pa);
19731 Check_Ada_83_Warning;
19732 Check_Valid_Library_Unit_Pragma;
19734 if Nkind (N) = N_Null_Statement then
19738 Ent := Find_Lib_Unit_Name;
19740 -- A pragma that applies to a Ghost entity becomes Ghost for the
19741 -- purposes of legality checks and removal of ignored Ghost code.
19743 Mark_Ghost_Pragma (N, Ent);
19744 Check_Duplicate_Pragma (Ent);
19746 -- This filters out pragmas inside generic parents that show up
19747 -- inside instantiations. Pragmas that come from aspects in the
19748 -- unit are not ignored.
19750 if Present (Ent) then
19751 if Pk = N_Package_Specification
19752 and then Present (Generic_Parent (Pa))
19753 and then not From_Aspect_Specification (N)
19758 if not Debug_Flag_U then
19759 Set_Is_Preelaborated (Ent);
19760 Set_Suppress_Elaboration_Warnings (Ent);
19766 -------------------------------
19767 -- Prefix_Exception_Messages --
19768 -------------------------------
19770 -- pragma Prefix_Exception_Messages;
19772 when Pragma_Prefix_Exception_Messages =>
19774 Check_Valid_Configuration_Pragma;
19775 Check_Arg_Count (0);
19776 Prefix_Exception_Messages := True;
19782 -- pragma Priority (EXPRESSION);
19784 when Pragma_Priority => Priority : declare
19785 P : constant Node_Id := Parent (N);
19790 Check_No_Identifiers;
19791 Check_Arg_Count (1);
19795 if Nkind (P) = N_Subprogram_Body then
19796 Check_In_Main_Program;
19798 Ent := Defining_Unit_Name (Specification (P));
19800 if Nkind (Ent) = N_Defining_Program_Unit_Name then
19801 Ent := Defining_Identifier (Ent);
19804 Arg := Get_Pragma_Arg (Arg1);
19805 Analyze_And_Resolve (Arg, Standard_Integer);
19809 if not Is_OK_Static_Expression (Arg) then
19810 Flag_Non_Static_Expr
19811 ("main subprogram priority is not static!", Arg);
19814 -- If constraint error, then we already signalled an error
19816 elsif Raises_Constraint_Error (Arg) then
19819 -- Otherwise check in range except if Relaxed_RM_Semantics
19820 -- where we ignore the value if out of range.
19823 if not Relaxed_RM_Semantics
19824 and then not Is_In_Range (Arg, RTE (RE_Priority))
19827 ("main subprogram priority is out of range", Arg1);
19830 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19834 -- Load an arbitrary entity from System.Tasking.Stages or
19835 -- System.Tasking.Restricted.Stages (depending on the
19836 -- supported profile) to make sure that one of these packages
19837 -- is implicitly with'ed, since we need to have the tasking
19838 -- run time active for the pragma Priority to have any effect.
19839 -- Previously we with'ed the package System.Tasking, but this
19840 -- package does not trigger the required initialization of the
19841 -- run-time library.
19844 Discard : Entity_Id;
19845 pragma Warnings (Off, Discard);
19847 if Restricted_Profile then
19848 Discard := RTE (RE_Activate_Restricted_Tasks);
19850 Discard := RTE (RE_Activate_Tasks);
19854 -- Task or Protected, must be of type Integer
19856 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19857 Arg := Get_Pragma_Arg (Arg1);
19858 Ent := Defining_Identifier (Parent (P));
19860 -- The expression must be analyzed in the special manner
19861 -- described in "Handling of Default and Per-Object
19862 -- Expressions" in sem.ads.
19864 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19866 if not Is_OK_Static_Expression (Arg) then
19867 Check_Restriction (Static_Priorities, Arg);
19870 -- Anything else is incorrect
19876 -- Check duplicate pragma before we chain the pragma in the Rep
19877 -- Item chain of Ent.
19879 Check_Duplicate_Pragma (Ent);
19880 Record_Rep_Item (Ent, N);
19883 -----------------------------------
19884 -- Priority_Specific_Dispatching --
19885 -----------------------------------
19887 -- pragma Priority_Specific_Dispatching (
19888 -- policy_IDENTIFIER,
19889 -- first_priority_EXPRESSION,
19890 -- last_priority_EXPRESSION);
19892 when Pragma_Priority_Specific_Dispatching =>
19893 Priority_Specific_Dispatching : declare
19894 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19895 -- This is the entity System.Any_Priority;
19898 Lower_Bound : Node_Id;
19899 Upper_Bound : Node_Id;
19905 Check_Arg_Count (3);
19906 Check_No_Identifiers;
19907 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19908 Check_Valid_Configuration_Pragma;
19909 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19910 DP := Fold_Upper (Name_Buffer (1));
19912 Lower_Bound := Get_Pragma_Arg (Arg2);
19913 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19914 Lower_Val := Expr_Value (Lower_Bound);
19916 Upper_Bound := Get_Pragma_Arg (Arg3);
19917 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19918 Upper_Val := Expr_Value (Upper_Bound);
19920 -- It is not allowed to use Task_Dispatching_Policy and
19921 -- Priority_Specific_Dispatching in the same partition.
19923 if Task_Dispatching_Policy /= ' ' then
19924 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19926 ("pragma% incompatible with Task_Dispatching_Policy#");
19928 -- Check lower bound in range
19930 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19932 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19935 ("first_priority is out of range", Arg2);
19937 -- Check upper bound in range
19939 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19941 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19944 ("last_priority is out of range", Arg3);
19946 -- Check that the priority range is valid
19948 elsif Lower_Val > Upper_Val then
19950 ("last_priority_expression must be greater than or equal to "
19951 & "first_priority_expression");
19953 -- Store the new policy, but always preserve System_Location since
19954 -- we like the error message with the run-time name.
19957 -- Check overlapping in the priority ranges specified in other
19958 -- Priority_Specific_Dispatching pragmas within the same
19959 -- partition. We can only check those we know about.
19962 Specific_Dispatching.First .. Specific_Dispatching.Last
19964 if Specific_Dispatching.Table (J).First_Priority in
19965 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19966 or else Specific_Dispatching.Table (J).Last_Priority in
19967 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19970 Specific_Dispatching.Table (J).Pragma_Loc;
19972 ("priority range overlaps with "
19973 & "Priority_Specific_Dispatching#");
19977 -- The use of Priority_Specific_Dispatching is incompatible
19978 -- with Task_Dispatching_Policy.
19980 if Task_Dispatching_Policy /= ' ' then
19981 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19983 ("Priority_Specific_Dispatching incompatible "
19984 & "with Task_Dispatching_Policy#");
19987 -- The use of Priority_Specific_Dispatching forces ceiling
19990 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19991 Error_Msg_Sloc := Locking_Policy_Sloc;
19993 ("Priority_Specific_Dispatching incompatible "
19994 & "with Locking_Policy#");
19996 -- Set the Ceiling_Locking policy, but preserve System_Location
19997 -- since we like the error message with the run time name.
20000 Locking_Policy := 'C';
20002 if Locking_Policy_Sloc /= System_Location then
20003 Locking_Policy_Sloc := Loc;
20007 -- Add entry in the table
20009 Specific_Dispatching.Append
20010 ((Dispatching_Policy => DP,
20011 First_Priority => UI_To_Int (Lower_Val),
20012 Last_Priority => UI_To_Int (Upper_Val),
20013 Pragma_Loc => Loc));
20015 end Priority_Specific_Dispatching;
20021 -- pragma Profile (profile_IDENTIFIER);
20023 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20025 when Pragma_Profile =>
20027 Check_Arg_Count (1);
20028 Check_Valid_Configuration_Pragma;
20029 Check_No_Identifiers;
20032 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20035 if Chars (Argx) = Name_Ravenscar then
20036 Set_Ravenscar_Profile (Ravenscar, N);
20038 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
20039 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
20041 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
20042 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
20044 elsif Chars (Argx) = Name_Restricted then
20045 Set_Profile_Restrictions
20047 N, Warn => Treat_Restrictions_As_Warnings);
20049 elsif Chars (Argx) = Name_Rational then
20050 Set_Rational_Profile;
20052 elsif Chars (Argx) = Name_No_Implementation_Extensions then
20053 Set_Profile_Restrictions
20054 (No_Implementation_Extensions,
20055 N, Warn => Treat_Restrictions_As_Warnings);
20058 Error_Pragma_Arg ("& is not a valid profile", Argx);
20062 ----------------------
20063 -- Profile_Warnings --
20064 ----------------------
20066 -- pragma Profile_Warnings (profile_IDENTIFIER);
20068 -- profile_IDENTIFIER => Restricted | Ravenscar
20070 when Pragma_Profile_Warnings =>
20072 Check_Arg_Count (1);
20073 Check_Valid_Configuration_Pragma;
20074 Check_No_Identifiers;
20077 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20080 if Chars (Argx) = Name_Ravenscar then
20081 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
20083 elsif Chars (Argx) = Name_Restricted then
20084 Set_Profile_Restrictions (Restricted, N, Warn => True);
20086 elsif Chars (Argx) = Name_No_Implementation_Extensions then
20087 Set_Profile_Restrictions
20088 (No_Implementation_Extensions, N, Warn => True);
20091 Error_Pragma_Arg ("& is not a valid profile", Argx);
20095 --------------------------
20096 -- Propagate_Exceptions --
20097 --------------------------
20099 -- pragma Propagate_Exceptions;
20101 -- Note: this pragma is obsolete and has no effect
20103 when Pragma_Propagate_Exceptions =>
20105 Check_Arg_Count (0);
20107 if Warn_On_Obsolescent_Feature then
20109 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20110 "and has no effect?j?", N);
20113 -----------------------------
20114 -- Provide_Shift_Operators --
20115 -----------------------------
20117 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20119 when Pragma_Provide_Shift_Operators =>
20120 Provide_Shift_Operators : declare
20123 procedure Declare_Shift_Operator (Nam : Name_Id);
20124 -- Insert declaration and pragma Instrinsic for named shift op
20126 ----------------------------
20127 -- Declare_Shift_Operator --
20128 ----------------------------
20130 procedure Declare_Shift_Operator (Nam : Name_Id) is
20136 Make_Subprogram_Declaration (Loc,
20137 Make_Function_Specification (Loc,
20138 Defining_Unit_Name =>
20139 Make_Defining_Identifier (Loc, Chars => Nam),
20141 Result_Definition =>
20142 Make_Identifier (Loc, Chars => Chars (Ent)),
20144 Parameter_Specifications => New_List (
20145 Make_Parameter_Specification (Loc,
20146 Defining_Identifier =>
20147 Make_Defining_Identifier (Loc, Name_Value),
20149 Make_Identifier (Loc, Chars => Chars (Ent))),
20151 Make_Parameter_Specification (Loc,
20152 Defining_Identifier =>
20153 Make_Defining_Identifier (Loc, Name_Amount),
20155 New_Occurrence_Of (Standard_Natural, Loc)))));
20159 Chars => Name_Import,
20160 Pragma_Argument_Associations => New_List (
20161 Make_Pragma_Argument_Association (Loc,
20162 Expression => Make_Identifier (Loc, Name_Intrinsic)),
20163 Make_Pragma_Argument_Association (Loc,
20164 Expression => Make_Identifier (Loc, Nam))));
20166 Insert_After (N, Import);
20167 Insert_After (N, Func);
20168 end Declare_Shift_Operator;
20170 -- Start of processing for Provide_Shift_Operators
20174 Check_Arg_Count (1);
20175 Check_Arg_Is_Local_Name (Arg1);
20177 Arg1 := Get_Pragma_Arg (Arg1);
20179 -- We must have an entity name
20181 if not Is_Entity_Name (Arg1) then
20183 ("pragma % must apply to integer first subtype", Arg1);
20186 -- If no Entity, means there was a prior error so ignore
20188 if Present (Entity (Arg1)) then
20189 Ent := Entity (Arg1);
20191 -- Apply error checks
20193 if not Is_First_Subtype (Ent) then
20195 ("cannot apply pragma %",
20196 "\& is not a first subtype",
20199 elsif not Is_Integer_Type (Ent) then
20201 ("cannot apply pragma %",
20202 "\& is not an integer type",
20205 elsif Has_Shift_Operator (Ent) then
20207 ("cannot apply pragma %",
20208 "\& already has declared shift operators",
20211 elsif Is_Frozen (Ent) then
20213 ("pragma % appears too late",
20214 "\& is already frozen",
20218 -- Now declare the operators. We do this during analysis rather
20219 -- than expansion, since we want the operators available if we
20220 -- are operating in -gnatc or ASIS mode.
20222 Declare_Shift_Operator (Name_Rotate_Left);
20223 Declare_Shift_Operator (Name_Rotate_Right);
20224 Declare_Shift_Operator (Name_Shift_Left);
20225 Declare_Shift_Operator (Name_Shift_Right);
20226 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
20228 end Provide_Shift_Operators;
20234 -- pragma Psect_Object (
20235 -- [Internal =>] LOCAL_NAME,
20236 -- [, [External =>] EXTERNAL_SYMBOL]
20237 -- [, [Size =>] EXTERNAL_SYMBOL]);
20239 when Pragma_Common_Object
20240 | Pragma_Psect_Object
20242 Psect_Object : declare
20243 Args : Args_List (1 .. 3);
20244 Names : constant Name_List (1 .. 3) := (
20249 Internal : Node_Id renames Args (1);
20250 External : Node_Id renames Args (2);
20251 Size : Node_Id renames Args (3);
20253 Def_Id : Entity_Id;
20255 procedure Check_Arg (Arg : Node_Id);
20256 -- Checks that argument is either a string literal or an
20257 -- identifier, and posts error message if not.
20263 procedure Check_Arg (Arg : Node_Id) is
20265 if not Nkind_In (Original_Node (Arg),
20270 ("inappropriate argument for pragma %", Arg);
20274 -- Start of processing for Common_Object/Psect_Object
20278 Gather_Associations (Names, Args);
20279 Process_Extended_Import_Export_Internal_Arg (Internal);
20281 Def_Id := Entity (Internal);
20283 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
20285 ("pragma% must designate an object", Internal);
20288 Check_Arg (Internal);
20290 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
20292 ("cannot use pragma% for imported/exported object",
20296 if Is_Concurrent_Type (Etype (Internal)) then
20298 ("cannot specify pragma % for task/protected object",
20302 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
20304 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
20306 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
20309 if Ekind (Def_Id) = E_Constant then
20311 ("cannot specify pragma % for a constant", Internal);
20314 if Is_Record_Type (Etype (Internal)) then
20320 Ent := First_Entity (Etype (Internal));
20321 while Present (Ent) loop
20322 Decl := Declaration_Node (Ent);
20324 if Ekind (Ent) = E_Component
20325 and then Nkind (Decl) = N_Component_Declaration
20326 and then Present (Expression (Decl))
20327 and then Warn_On_Export_Import
20330 ("?x?object for pragma % has defaults", Internal);
20340 if Present (Size) then
20344 if Present (External) then
20345 Check_Arg_Is_External_Name (External);
20348 -- If all error tests pass, link pragma on to the rep item chain
20350 Record_Rep_Item (Def_Id, N);
20357 -- pragma Pure [(library_unit_NAME)];
20359 when Pragma_Pure => Pure : declare
20363 Check_Ada_83_Warning;
20365 -- If the pragma comes from a subprogram instantiation, nothing to
20366 -- check, this can happen at any level of nesting.
20368 if Is_Wrapper_Package (Current_Scope) then
20371 Check_Valid_Library_Unit_Pragma;
20374 if Nkind (N) = N_Null_Statement then
20378 Ent := Find_Lib_Unit_Name;
20380 -- A pragma that applies to a Ghost entity becomes Ghost for the
20381 -- purposes of legality checks and removal of ignored Ghost code.
20383 Mark_Ghost_Pragma (N, Ent);
20385 if not Debug_Flag_U then
20387 Set_Has_Pragma_Pure (Ent);
20388 Set_Suppress_Elaboration_Warnings (Ent);
20392 -------------------
20393 -- Pure_Function --
20394 -------------------
20396 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20398 when Pragma_Pure_Function => Pure_Function : declare
20399 Def_Id : Entity_Id;
20402 Effective : Boolean := False;
20406 Check_Arg_Count (1);
20407 Check_Optional_Identifier (Arg1, Name_Entity);
20408 Check_Arg_Is_Local_Name (Arg1);
20409 E_Id := Get_Pragma_Arg (Arg1);
20411 if Etype (E_Id) = Any_Type then
20415 -- Loop through homonyms (overloadings) of referenced entity
20417 E := Entity (E_Id);
20419 -- A pragma that applies to a Ghost entity becomes Ghost for the
20420 -- purposes of legality checks and removal of ignored Ghost code.
20422 Mark_Ghost_Pragma (N, E);
20424 if Present (E) then
20426 Def_Id := Get_Base_Subprogram (E);
20428 if not Ekind_In (Def_Id, E_Function,
20429 E_Generic_Function,
20433 ("pragma% requires a function name", Arg1);
20436 Set_Is_Pure (Def_Id);
20438 if not Has_Pragma_Pure_Function (Def_Id) then
20439 Set_Has_Pragma_Pure_Function (Def_Id);
20443 exit when From_Aspect_Specification (N);
20445 exit when No (E) or else Scope (E) /= Current_Scope;
20449 and then Warn_On_Redundant_Constructs
20452 ("pragma Pure_Function on& is redundant?r?",
20458 --------------------
20459 -- Queuing_Policy --
20460 --------------------
20462 -- pragma Queuing_Policy (policy_IDENTIFIER);
20464 when Pragma_Queuing_Policy => declare
20468 Check_Ada_83_Warning;
20469 Check_Arg_Count (1);
20470 Check_No_Identifiers;
20471 Check_Arg_Is_Queuing_Policy (Arg1);
20472 Check_Valid_Configuration_Pragma;
20473 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20474 QP := Fold_Upper (Name_Buffer (1));
20476 if Queuing_Policy /= ' '
20477 and then Queuing_Policy /= QP
20479 Error_Msg_Sloc := Queuing_Policy_Sloc;
20480 Error_Pragma ("queuing policy incompatible with policy#");
20482 -- Set new policy, but always preserve System_Location since we
20483 -- like the error message with the run time name.
20486 Queuing_Policy := QP;
20488 if Queuing_Policy_Sloc /= System_Location then
20489 Queuing_Policy_Sloc := Loc;
20498 -- pragma Rational, for compatibility with foreign compiler
20500 when Pragma_Rational =>
20501 Set_Rational_Profile;
20503 ---------------------
20504 -- Refined_Depends --
20505 ---------------------
20507 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20509 -- DEPENDENCY_RELATION ::=
20511 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20513 -- DEPENDENCY_CLAUSE ::=
20514 -- OUTPUT_LIST =>[+] INPUT_LIST
20515 -- | NULL_DEPENDENCY_CLAUSE
20517 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20519 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20521 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20523 -- OUTPUT ::= NAME | FUNCTION_RESULT
20526 -- where FUNCTION_RESULT is a function Result attribute_reference
20528 -- Characteristics:
20530 -- * Analysis - The annotation undergoes initial checks to verify
20531 -- the legal placement and context. Secondary checks fully analyze
20532 -- the dependency clauses/global list in:
20534 -- Analyze_Refined_Depends_In_Decl_Part
20536 -- * Expansion - None.
20538 -- * Template - The annotation utilizes the generic template of the
20539 -- related subprogram body.
20541 -- * Globals - Capture of global references must occur after full
20544 -- * Instance - The annotation is instantiated automatically when
20545 -- the related generic subprogram body is instantiated.
20547 when Pragma_Refined_Depends => Refined_Depends : declare
20548 Body_Id : Entity_Id;
20550 Spec_Id : Entity_Id;
20553 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20557 -- Chain the pragma on the contract for further processing by
20558 -- Analyze_Refined_Depends_In_Decl_Part.
20560 Add_Contract_Item (N, Body_Id);
20562 -- The legality checks of pragmas Refined_Depends and
20563 -- Refined_Global are affected by the SPARK mode in effect and
20564 -- the volatility of the context. In addition these two pragmas
20565 -- are subject to an inherent order:
20567 -- 1) Refined_Global
20568 -- 2) Refined_Depends
20570 -- Analyze all these pragmas in the order outlined above
20572 Analyze_If_Present (Pragma_SPARK_Mode);
20573 Analyze_If_Present (Pragma_Volatile_Function);
20574 Analyze_If_Present (Pragma_Refined_Global);
20575 Analyze_Refined_Depends_In_Decl_Part (N);
20577 end Refined_Depends;
20579 --------------------
20580 -- Refined_Global --
20581 --------------------
20583 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20585 -- GLOBAL_SPECIFICATION ::=
20588 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20590 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20592 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20593 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20594 -- GLOBAL_ITEM ::= NAME
20596 -- Characteristics:
20598 -- * Analysis - The annotation undergoes initial checks to verify
20599 -- the legal placement and context. Secondary checks fully analyze
20600 -- the dependency clauses/global list in:
20602 -- Analyze_Refined_Global_In_Decl_Part
20604 -- * Expansion - None.
20606 -- * Template - The annotation utilizes the generic template of the
20607 -- related subprogram body.
20609 -- * Globals - Capture of global references must occur after full
20612 -- * Instance - The annotation is instantiated automatically when
20613 -- the related generic subprogram body is instantiated.
20615 when Pragma_Refined_Global => Refined_Global : declare
20616 Body_Id : Entity_Id;
20618 Spec_Id : Entity_Id;
20621 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20625 -- Chain the pragma on the contract for further processing by
20626 -- Analyze_Refined_Global_In_Decl_Part.
20628 Add_Contract_Item (N, Body_Id);
20630 -- The legality checks of pragmas Refined_Depends and
20631 -- Refined_Global are affected by the SPARK mode in effect and
20632 -- the volatility of the context. In addition these two pragmas
20633 -- are subject to an inherent order:
20635 -- 1) Refined_Global
20636 -- 2) Refined_Depends
20638 -- Analyze all these pragmas in the order outlined above
20640 Analyze_If_Present (Pragma_SPARK_Mode);
20641 Analyze_If_Present (Pragma_Volatile_Function);
20642 Analyze_Refined_Global_In_Decl_Part (N);
20643 Analyze_If_Present (Pragma_Refined_Depends);
20645 end Refined_Global;
20651 -- pragma Refined_Post (boolean_EXPRESSION);
20653 -- Characteristics:
20655 -- * Analysis - The annotation is fully analyzed immediately upon
20656 -- elaboration as it cannot forward reference entities.
20658 -- * Expansion - The annotation is expanded during the expansion of
20659 -- the related subprogram body contract as performed in:
20661 -- Expand_Subprogram_Contract
20663 -- * Template - The annotation utilizes the generic template of the
20664 -- related subprogram body.
20666 -- * Globals - Capture of global references must occur after full
20669 -- * Instance - The annotation is instantiated automatically when
20670 -- the related generic subprogram body is instantiated.
20672 when Pragma_Refined_Post => Refined_Post : declare
20673 Body_Id : Entity_Id;
20675 Spec_Id : Entity_Id;
20678 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20680 -- Fully analyze the pragma when it appears inside a subprogram
20681 -- body because it cannot benefit from forward references.
20685 -- Chain the pragma on the contract for completeness
20687 Add_Contract_Item (N, Body_Id);
20689 -- The legality checks of pragma Refined_Post are affected by
20690 -- the SPARK mode in effect and the volatility of the context.
20691 -- Analyze all pragmas in a specific order.
20693 Analyze_If_Present (Pragma_SPARK_Mode);
20694 Analyze_If_Present (Pragma_Volatile_Function);
20695 Analyze_Pre_Post_Condition_In_Decl_Part (N);
20697 -- Currently it is not possible to inline pre/postconditions on
20698 -- a subprogram subject to pragma Inline_Always.
20700 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20704 -------------------
20705 -- Refined_State --
20706 -------------------
20708 -- pragma Refined_State (REFINEMENT_LIST);
20710 -- REFINEMENT_LIST ::=
20711 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20713 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20715 -- CONSTITUENT_LIST ::=
20718 -- | (CONSTITUENT {, CONSTITUENT})
20720 -- CONSTITUENT ::= object_NAME | state_NAME
20722 -- Characteristics:
20724 -- * Analysis - The annotation undergoes initial checks to verify
20725 -- the legal placement and context. Secondary checks preanalyze the
20726 -- refinement clauses in:
20728 -- Analyze_Refined_State_In_Decl_Part
20730 -- * Expansion - None.
20732 -- * Template - The annotation utilizes the template of the related
20735 -- * Globals - Capture of global references must occur after full
20738 -- * Instance - The annotation is instantiated automatically when
20739 -- the related generic package body is instantiated.
20741 when Pragma_Refined_State => Refined_State : declare
20742 Pack_Decl : Node_Id;
20743 Spec_Id : Entity_Id;
20747 Check_No_Identifiers;
20748 Check_Arg_Count (1);
20750 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20752 -- Ensure the proper placement of the pragma. Refined states must
20753 -- be associated with a package body.
20755 if Nkind (Pack_Decl) = N_Package_Body then
20758 -- Otherwise the pragma is associated with an illegal construct
20765 Spec_Id := Corresponding_Spec (Pack_Decl);
20767 -- A pragma that applies to a Ghost entity becomes Ghost for the
20768 -- purposes of legality checks and removal of ignored Ghost code.
20770 Mark_Ghost_Pragma (N, Spec_Id);
20772 -- Chain the pragma on the contract for further processing by
20773 -- Analyze_Refined_State_In_Decl_Part.
20775 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20777 -- The legality checks of pragma Refined_State are affected by the
20778 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20780 Analyze_If_Present (Pragma_SPARK_Mode);
20782 -- State refinement is allowed only when the corresponding package
20783 -- declaration has non-null pragma Abstract_State. Refinement not
20784 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20786 if SPARK_Mode /= Off
20788 (No (Abstract_States (Spec_Id))
20789 or else Has_Null_Abstract_State (Spec_Id))
20792 ("useless refinement, package & does not define abstract "
20793 & "states", N, Spec_Id);
20798 -----------------------
20799 -- Relative_Deadline --
20800 -----------------------
20802 -- pragma Relative_Deadline (time_span_EXPRESSION);
20804 when Pragma_Relative_Deadline => Relative_Deadline : declare
20805 P : constant Node_Id := Parent (N);
20810 Check_No_Identifiers;
20811 Check_Arg_Count (1);
20813 Arg := Get_Pragma_Arg (Arg1);
20815 -- The expression must be analyzed in the special manner described
20816 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20818 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20822 if Nkind (P) = N_Subprogram_Body then
20823 Check_In_Main_Program;
20825 -- Only Task and subprogram cases allowed
20827 elsif Nkind (P) /= N_Task_Definition then
20831 -- Check duplicate pragma before we set the corresponding flag
20833 if Has_Relative_Deadline_Pragma (P) then
20834 Error_Pragma ("duplicate pragma% not allowed");
20837 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20838 -- Relative_Deadline pragma node cannot be inserted in the Rep
20839 -- Item chain of Ent since it is rewritten by the expander as a
20840 -- procedure call statement that will break the chain.
20842 Set_Has_Relative_Deadline_Pragma (P);
20843 end Relative_Deadline;
20845 ------------------------
20846 -- Remote_Access_Type --
20847 ------------------------
20849 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20851 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20856 Check_Arg_Count (1);
20857 Check_Optional_Identifier (Arg1, Name_Entity);
20858 Check_Arg_Is_Local_Name (Arg1);
20860 E := Entity (Get_Pragma_Arg (Arg1));
20862 -- A pragma that applies to a Ghost entity becomes Ghost for the
20863 -- purposes of legality checks and removal of ignored Ghost code.
20865 Mark_Ghost_Pragma (N, E);
20867 if Nkind (Parent (E)) = N_Formal_Type_Declaration
20868 and then Ekind (E) = E_General_Access_Type
20869 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20870 and then Scope (Root_Type (Directly_Designated_Type (E)))
20872 and then Is_Valid_Remote_Object_Type
20873 (Root_Type (Directly_Designated_Type (E)))
20875 Set_Is_Remote_Types (E);
20879 ("pragma% applies only to formal access-to-class-wide types",
20882 end Remote_Access_Type;
20884 ---------------------------
20885 -- Remote_Call_Interface --
20886 ---------------------------
20888 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20890 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20891 Cunit_Node : Node_Id;
20892 Cunit_Ent : Entity_Id;
20896 Check_Ada_83_Warning;
20897 Check_Valid_Library_Unit_Pragma;
20899 if Nkind (N) = N_Null_Statement then
20903 Cunit_Node := Cunit (Current_Sem_Unit);
20904 K := Nkind (Unit (Cunit_Node));
20905 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20907 -- A pragma that applies to a Ghost entity becomes Ghost for the
20908 -- purposes of legality checks and removal of ignored Ghost code.
20910 Mark_Ghost_Pragma (N, Cunit_Ent);
20912 if K = N_Package_Declaration
20913 or else K = N_Generic_Package_Declaration
20914 or else K = N_Subprogram_Declaration
20915 or else K = N_Generic_Subprogram_Declaration
20916 or else (K = N_Subprogram_Body
20917 and then Acts_As_Spec (Unit (Cunit_Node)))
20922 "pragma% must apply to package or subprogram declaration");
20925 Set_Is_Remote_Call_Interface (Cunit_Ent);
20926 end Remote_Call_Interface;
20932 -- pragma Remote_Types [(library_unit_NAME)];
20934 when Pragma_Remote_Types => Remote_Types : declare
20935 Cunit_Node : Node_Id;
20936 Cunit_Ent : Entity_Id;
20939 Check_Ada_83_Warning;
20940 Check_Valid_Library_Unit_Pragma;
20942 if Nkind (N) = N_Null_Statement then
20946 Cunit_Node := Cunit (Current_Sem_Unit);
20947 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20949 -- A pragma that applies to a Ghost entity becomes Ghost for the
20950 -- purposes of legality checks and removal of ignored Ghost code.
20952 Mark_Ghost_Pragma (N, Cunit_Ent);
20954 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20955 N_Generic_Package_Declaration)
20958 ("pragma% can only apply to a package declaration");
20961 Set_Is_Remote_Types (Cunit_Ent);
20968 -- pragma Ravenscar;
20970 when Pragma_Ravenscar =>
20972 Check_Arg_Count (0);
20973 Check_Valid_Configuration_Pragma;
20974 Set_Ravenscar_Profile (Ravenscar, N);
20976 if Warn_On_Obsolescent_Feature then
20978 ("pragma Ravenscar is an obsolescent feature?j?", N);
20980 ("|use pragma Profile (Ravenscar) instead?j?", N);
20983 -------------------------
20984 -- Restricted_Run_Time --
20985 -------------------------
20987 -- pragma Restricted_Run_Time;
20989 when Pragma_Restricted_Run_Time =>
20991 Check_Arg_Count (0);
20992 Check_Valid_Configuration_Pragma;
20993 Set_Profile_Restrictions
20994 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20996 if Warn_On_Obsolescent_Feature then
20998 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21001 ("|use pragma Profile (Restricted) instead?j?", N);
21008 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21011 -- restriction_IDENTIFIER
21012 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21014 when Pragma_Restrictions =>
21015 Process_Restrictions_Or_Restriction_Warnings
21016 (Warn => Treat_Restrictions_As_Warnings);
21018 --------------------------
21019 -- Restriction_Warnings --
21020 --------------------------
21022 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21025 -- restriction_IDENTIFIER
21026 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21028 when Pragma_Restriction_Warnings =>
21030 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
21036 -- pragma Reviewable;
21038 when Pragma_Reviewable =>
21039 Check_Ada_83_Warning;
21040 Check_Arg_Count (0);
21042 -- Call dummy debugging function rv. This is done to assist front
21043 -- end debugging. By placing a Reviewable pragma in the source
21044 -- program, a breakpoint on rv catches this place in the source,
21045 -- allowing convenient stepping to the point of interest.
21049 --------------------------
21050 -- Secondary_Stack_Size --
21051 --------------------------
21053 -- pragma Secondary_Stack_Size (EXPRESSION);
21055 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
21056 P : constant Node_Id := Parent (N);
21062 Check_No_Identifiers;
21063 Check_Arg_Count (1);
21065 if Nkind (P) = N_Task_Definition then
21066 Arg := Get_Pragma_Arg (Arg1);
21067 Ent := Defining_Identifier (Parent (P));
21069 -- The expression must be analyzed in the special manner
21070 -- described in "Handling of Default Expressions" in sem.ads.
21072 Preanalyze_Spec_Expression (Arg, Any_Integer);
21074 -- The pragma cannot appear if the No_Secondary_Stack
21075 -- restriction is in effect.
21077 Check_Restriction (No_Secondary_Stack, Arg);
21079 -- Anything else is incorrect
21085 -- Check duplicate pragma before we chain the pragma in the Rep
21086 -- Item chain of Ent.
21088 Check_Duplicate_Pragma (Ent);
21089 Record_Rep_Item (Ent, N);
21090 end Secondary_Stack_Size;
21092 --------------------------
21093 -- Short_Circuit_And_Or --
21094 --------------------------
21096 -- pragma Short_Circuit_And_Or;
21098 when Pragma_Short_Circuit_And_Or =>
21100 Check_Arg_Count (0);
21101 Check_Valid_Configuration_Pragma;
21102 Short_Circuit_And_Or := True;
21104 -------------------
21105 -- Share_Generic --
21106 -------------------
21108 -- pragma Share_Generic (GNAME {, GNAME});
21110 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21112 when Pragma_Share_Generic =>
21114 Process_Generic_List;
21120 -- pragma Shared (LOCAL_NAME);
21122 when Pragma_Shared =>
21124 Process_Atomic_Independent_Shared_Volatile;
21126 --------------------
21127 -- Shared_Passive --
21128 --------------------
21130 -- pragma Shared_Passive [(library_unit_NAME)];
21132 -- Set the flag Is_Shared_Passive of program unit name entity
21134 when Pragma_Shared_Passive => Shared_Passive : declare
21135 Cunit_Node : Node_Id;
21136 Cunit_Ent : Entity_Id;
21139 Check_Ada_83_Warning;
21140 Check_Valid_Library_Unit_Pragma;
21142 if Nkind (N) = N_Null_Statement then
21146 Cunit_Node := Cunit (Current_Sem_Unit);
21147 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
21149 -- A pragma that applies to a Ghost entity becomes Ghost for the
21150 -- purposes of legality checks and removal of ignored Ghost code.
21152 Mark_Ghost_Pragma (N, Cunit_Ent);
21154 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
21155 N_Generic_Package_Declaration)
21158 ("pragma% can only apply to a package declaration");
21161 Set_Is_Shared_Passive (Cunit_Ent);
21162 end Shared_Passive;
21164 -----------------------
21165 -- Short_Descriptors --
21166 -----------------------
21168 -- pragma Short_Descriptors;
21170 -- Recognize and validate, but otherwise ignore
21172 when Pragma_Short_Descriptors =>
21174 Check_Arg_Count (0);
21175 Check_Valid_Configuration_Pragma;
21177 ------------------------------
21178 -- Simple_Storage_Pool_Type --
21179 ------------------------------
21181 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21183 when Pragma_Simple_Storage_Pool_Type =>
21184 Simple_Storage_Pool_Type : declare
21190 Check_Arg_Count (1);
21191 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21193 Type_Id := Get_Pragma_Arg (Arg1);
21194 Find_Type (Type_Id);
21195 Typ := Entity (Type_Id);
21197 if Typ = Any_Type then
21201 -- A pragma that applies to a Ghost entity becomes Ghost for the
21202 -- purposes of legality checks and removal of ignored Ghost code.
21204 Mark_Ghost_Pragma (N, Typ);
21206 -- We require the pragma to apply to a type declared in a package
21207 -- declaration, but not (immediately) within a package body.
21209 if Ekind (Current_Scope) /= E_Package
21210 or else In_Package_Body (Current_Scope)
21213 ("pragma% can only apply to type declared immediately "
21214 & "within a package declaration");
21217 -- A simple storage pool type must be an immutably limited record
21218 -- or private type. If the pragma is given for a private type,
21219 -- the full type is similarly restricted (which is checked later
21220 -- in Freeze_Entity).
21222 if Is_Record_Type (Typ)
21223 and then not Is_Limited_View (Typ)
21226 ("pragma% can only apply to explicitly limited record type");
21228 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
21230 ("pragma% can only apply to a private type that is limited");
21232 elsif not Is_Record_Type (Typ)
21233 and then not Is_Private_Type (Typ)
21236 ("pragma% can only apply to limited record or private type");
21239 Record_Rep_Item (Typ, N);
21240 end Simple_Storage_Pool_Type;
21242 ----------------------
21243 -- Source_File_Name --
21244 ----------------------
21246 -- There are five forms for this pragma:
21248 -- pragma Source_File_Name (
21249 -- [UNIT_NAME =>] unit_NAME,
21250 -- BODY_FILE_NAME => STRING_LITERAL
21251 -- [, [INDEX =>] INTEGER_LITERAL]);
21253 -- pragma Source_File_Name (
21254 -- [UNIT_NAME =>] unit_NAME,
21255 -- SPEC_FILE_NAME => STRING_LITERAL
21256 -- [, [INDEX =>] INTEGER_LITERAL]);
21258 -- pragma Source_File_Name (
21259 -- BODY_FILE_NAME => STRING_LITERAL
21260 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21261 -- [, CASING => CASING_SPEC]);
21263 -- pragma Source_File_Name (
21264 -- SPEC_FILE_NAME => STRING_LITERAL
21265 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21266 -- [, CASING => CASING_SPEC]);
21268 -- pragma Source_File_Name (
21269 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21270 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21271 -- [, CASING => CASING_SPEC]);
21273 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21275 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21276 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21277 -- only be used when no project file is used, while SFNP can only be
21278 -- used when a project file is used.
21280 -- No processing here. Processing was completed during parsing, since
21281 -- we need to have file names set as early as possible. Units are
21282 -- loaded well before semantic processing starts.
21284 -- The only processing we defer to this point is the check for
21285 -- correct placement.
21287 when Pragma_Source_File_Name =>
21289 Check_Valid_Configuration_Pragma;
21291 ------------------------------
21292 -- Source_File_Name_Project --
21293 ------------------------------
21295 -- See Source_File_Name for syntax
21297 -- No processing here. Processing was completed during parsing, since
21298 -- we need to have file names set as early as possible. Units are
21299 -- loaded well before semantic processing starts.
21301 -- The only processing we defer to this point is the check for
21302 -- correct placement.
21304 when Pragma_Source_File_Name_Project =>
21306 Check_Valid_Configuration_Pragma;
21308 -- Check that a pragma Source_File_Name_Project is used only in a
21309 -- configuration pragmas file.
21311 -- Pragmas Source_File_Name_Project should only be generated by
21312 -- the Project Manager in configuration pragmas files.
21314 -- This is really an ugly test. It seems to depend on some
21315 -- accidental and undocumented property. At the very least it
21316 -- needs to be documented, but it would be better to have a
21317 -- clean way of testing if we are in a configuration file???
21319 if Present (Parent (N)) then
21321 ("pragma% can only appear in a configuration pragmas file");
21324 ----------------------
21325 -- Source_Reference --
21326 ----------------------
21328 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21330 -- Nothing to do, all processing completed in Par.Prag, since we need
21331 -- the information for possible parser messages that are output.
21333 when Pragma_Source_Reference =>
21340 -- pragma SPARK_Mode [(On | Off)];
21342 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
21343 Mode_Id : SPARK_Mode_Type;
21345 procedure Check_Pragma_Conformance
21346 (Context_Pragma : Node_Id;
21347 Entity : Entity_Id;
21348 Entity_Pragma : Node_Id);
21349 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21350 -- conformance of pragma N depending the following scenarios:
21352 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21353 -- compatible with the pragma Context_Pragma that was inherited
21354 -- from the context:
21355 -- * If the mode of Context_Pragma is ON, then the new mode can
21357 -- * If the mode of Context_Pragma is OFF, then the only allowed
21358 -- new mode is also OFF. Emit error if this is not the case.
21360 -- If Entity is not Empty, verify that pragma N is compatible with
21361 -- pragma Entity_Pragma that belongs to Entity.
21362 -- * If Entity_Pragma is Empty, always issue an error as this
21363 -- corresponds to the case where a previous section of Entity
21364 -- has no SPARK_Mode set.
21365 -- * If the mode of Entity_Pragma is ON, then the new mode can
21367 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21368 -- new mode is also OFF. Emit error if this is not the case.
21370 procedure Check_Library_Level_Entity (E : Entity_Id);
21371 -- Subsidiary to routines Process_xxx. Verify that the related
21372 -- entity E subject to pragma SPARK_Mode is library-level.
21374 procedure Process_Body (Decl : Node_Id);
21375 -- Verify the legality of pragma SPARK_Mode when it appears as the
21376 -- top of the body declarations of entry, package, protected unit,
21377 -- subprogram or task unit body denoted by Decl.
21379 procedure Process_Overloadable (Decl : Node_Id);
21380 -- Verify the legality of pragma SPARK_Mode when it applies to an
21381 -- entry or [generic] subprogram declaration denoted by Decl.
21383 procedure Process_Private_Part (Decl : Node_Id);
21384 -- Verify the legality of pragma SPARK_Mode when it appears at the
21385 -- top of the private declarations of a package spec, protected or
21386 -- task unit declaration denoted by Decl.
21388 procedure Process_Statement_Part (Decl : Node_Id);
21389 -- Verify the legality of pragma SPARK_Mode when it appears at the
21390 -- top of the statement sequence of a package body denoted by node
21393 procedure Process_Visible_Part (Decl : Node_Id);
21394 -- Verify the legality of pragma SPARK_Mode when it appears at the
21395 -- top of the visible declarations of a package spec, protected or
21396 -- task unit declaration denoted by Decl. The routine is also used
21397 -- on protected or task units declared without a definition.
21399 procedure Set_SPARK_Context;
21400 -- Subsidiary to routines Process_xxx. Set the global variables
21401 -- which represent the mode of the context from pragma N. Ensure
21402 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21404 ------------------------------
21405 -- Check_Pragma_Conformance --
21406 ------------------------------
21408 procedure Check_Pragma_Conformance
21409 (Context_Pragma : Node_Id;
21410 Entity : Entity_Id;
21411 Entity_Pragma : Node_Id)
21413 Err_Id : Entity_Id;
21417 -- The current pragma may appear without an argument. If this
21418 -- is the case, associate all error messages with the pragma
21421 if Present (Arg1) then
21427 -- The mode of the current pragma is compared against that of
21428 -- an enclosing context.
21430 if Present (Context_Pragma) then
21431 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
21433 -- Issue an error if the new mode is less restrictive than
21434 -- that of the context.
21436 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
21437 and then Get_SPARK_Mode_From_Annotation (N) = On
21440 ("cannot change SPARK_Mode from Off to On", Err_N);
21441 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21442 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
21447 -- The mode of the current pragma is compared against that of
21448 -- an initial package, protected type, subprogram or task type
21451 if Present (Entity) then
21453 -- A simple protected or task type is transformed into an
21454 -- anonymous type whose name cannot be used to issue error
21455 -- messages. Recover the original entity of the type.
21457 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
21460 (Original_Node (Unit_Declaration_Node (Entity)));
21465 -- Both the initial declaration and the completion carry
21466 -- SPARK_Mode pragmas.
21468 if Present (Entity_Pragma) then
21469 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
21471 -- Issue an error if the new mode is less restrictive
21472 -- than that of the initial declaration.
21474 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
21475 and then Get_SPARK_Mode_From_Annotation (N) = On
21477 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21478 Error_Msg_Sloc := Sloc (Entity_Pragma);
21480 ("\value Off was set for SPARK_Mode on&#",
21485 -- Otherwise the initial declaration lacks a SPARK_Mode
21486 -- pragma in which case the current pragma is illegal as
21487 -- it cannot "complete".
21490 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21491 Error_Msg_Sloc := Sloc (Err_Id);
21493 ("\no value was set for SPARK_Mode on&#",
21498 end Check_Pragma_Conformance;
21500 --------------------------------
21501 -- Check_Library_Level_Entity --
21502 --------------------------------
21504 procedure Check_Library_Level_Entity (E : Entity_Id) is
21505 procedure Add_Entity_To_Name_Buffer;
21506 -- Add the E_Kind of entity E to the name buffer
21508 -------------------------------
21509 -- Add_Entity_To_Name_Buffer --
21510 -------------------------------
21512 procedure Add_Entity_To_Name_Buffer is
21514 if Ekind_In (E, E_Entry, E_Entry_Family) then
21515 Add_Str_To_Name_Buffer ("entry");
21517 elsif Ekind_In (E, E_Generic_Package,
21521 Add_Str_To_Name_Buffer ("package");
21523 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
21524 Add_Str_To_Name_Buffer ("protected type");
21526 elsif Ekind_In (E, E_Function,
21527 E_Generic_Function,
21528 E_Generic_Procedure,
21532 Add_Str_To_Name_Buffer ("subprogram");
21535 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
21536 Add_Str_To_Name_Buffer ("task type");
21538 end Add_Entity_To_Name_Buffer;
21542 Msg_1 : constant String := "incorrect placement of pragma%";
21545 -- Start of processing for Check_Library_Level_Entity
21548 if not Is_Library_Level_Entity (E) then
21549 Error_Msg_Name_1 := Pname;
21550 Error_Msg_N (Fix_Error (Msg_1), N);
21553 Add_Str_To_Name_Buffer ("\& is not a library-level ");
21554 Add_Entity_To_Name_Buffer;
21556 Msg_2 := Name_Find;
21557 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
21561 end Check_Library_Level_Entity;
21567 procedure Process_Body (Decl : Node_Id) is
21568 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21569 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
21572 -- Ignore pragma when applied to the special body created for
21573 -- inlining, recognized by its internal name _Parent.
21575 if Chars (Body_Id) = Name_uParent then
21579 Check_Library_Level_Entity (Body_Id);
21581 -- For entry bodies, verify the legality against:
21582 -- * The mode of the context
21583 -- * The mode of the spec (if any)
21585 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
21587 -- A stand alone subprogram body
21589 if Body_Id = Spec_Id then
21590 Check_Pragma_Conformance
21591 (Context_Pragma => SPARK_Pragma (Body_Id),
21593 Entity_Pragma => Empty);
21595 -- An entry or subprogram body that completes a previous
21599 Check_Pragma_Conformance
21600 (Context_Pragma => SPARK_Pragma (Body_Id),
21602 Entity_Pragma => SPARK_Pragma (Spec_Id));
21606 Set_SPARK_Pragma (Body_Id, N);
21607 Set_SPARK_Pragma_Inherited (Body_Id, False);
21609 -- For package bodies, verify the legality against:
21610 -- * The mode of the context
21611 -- * The mode of the private part
21613 -- This case is separated from protected and task bodies
21614 -- because the statement part of the package body inherits
21615 -- the mode of the body declarations.
21617 elsif Nkind (Decl) = N_Package_Body then
21618 Check_Pragma_Conformance
21619 (Context_Pragma => SPARK_Pragma (Body_Id),
21621 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21624 Set_SPARK_Pragma (Body_Id, N);
21625 Set_SPARK_Pragma_Inherited (Body_Id, False);
21626 Set_SPARK_Aux_Pragma (Body_Id, N);
21627 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21629 -- For protected and task bodies, verify the legality against:
21630 -- * The mode of the context
21631 -- * The mode of the private part
21635 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21637 Check_Pragma_Conformance
21638 (Context_Pragma => SPARK_Pragma (Body_Id),
21640 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21643 Set_SPARK_Pragma (Body_Id, N);
21644 Set_SPARK_Pragma_Inherited (Body_Id, False);
21648 --------------------------
21649 -- Process_Overloadable --
21650 --------------------------
21652 procedure Process_Overloadable (Decl : Node_Id) is
21653 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21654 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21657 Check_Library_Level_Entity (Spec_Id);
21659 -- Verify the legality against:
21660 -- * The mode of the context
21662 Check_Pragma_Conformance
21663 (Context_Pragma => SPARK_Pragma (Spec_Id),
21665 Entity_Pragma => Empty);
21667 Set_SPARK_Pragma (Spec_Id, N);
21668 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21670 -- When the pragma applies to the anonymous object created for
21671 -- a single task type, decorate the type as well. This scenario
21672 -- arises when the single task type lacks a task definition,
21673 -- therefore there is no issue with respect to a potential
21674 -- pragma SPARK_Mode in the private part.
21676 -- task type Anon_Task_Typ;
21677 -- Obj : Anon_Task_Typ;
21678 -- pragma SPARK_Mode ...;
21680 if Is_Single_Task_Object (Spec_Id) then
21681 Set_SPARK_Pragma (Spec_Typ, N);
21682 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
21683 Set_SPARK_Aux_Pragma (Spec_Typ, N);
21684 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21686 end Process_Overloadable;
21688 --------------------------
21689 -- Process_Private_Part --
21690 --------------------------
21692 procedure Process_Private_Part (Decl : Node_Id) is
21693 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21696 Check_Library_Level_Entity (Spec_Id);
21698 -- Verify the legality against:
21699 -- * The mode of the visible declarations
21701 Check_Pragma_Conformance
21702 (Context_Pragma => Empty,
21704 Entity_Pragma => SPARK_Pragma (Spec_Id));
21707 Set_SPARK_Aux_Pragma (Spec_Id, N);
21708 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21709 end Process_Private_Part;
21711 ----------------------------
21712 -- Process_Statement_Part --
21713 ----------------------------
21715 procedure Process_Statement_Part (Decl : Node_Id) is
21716 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21719 Check_Library_Level_Entity (Body_Id);
21721 -- Verify the legality against:
21722 -- * The mode of the body declarations
21724 Check_Pragma_Conformance
21725 (Context_Pragma => Empty,
21727 Entity_Pragma => SPARK_Pragma (Body_Id));
21730 Set_SPARK_Aux_Pragma (Body_Id, N);
21731 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21732 end Process_Statement_Part;
21734 --------------------------
21735 -- Process_Visible_Part --
21736 --------------------------
21738 procedure Process_Visible_Part (Decl : Node_Id) is
21739 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21740 Obj_Id : Entity_Id;
21743 Check_Library_Level_Entity (Spec_Id);
21745 -- Verify the legality against:
21746 -- * The mode of the context
21748 Check_Pragma_Conformance
21749 (Context_Pragma => SPARK_Pragma (Spec_Id),
21751 Entity_Pragma => Empty);
21753 -- A task unit declared without a definition does not set the
21754 -- SPARK_Mode of the context because the task does not have any
21755 -- entries that could inherit the mode.
21757 if not Nkind_In (Decl, N_Single_Task_Declaration,
21758 N_Task_Type_Declaration)
21763 Set_SPARK_Pragma (Spec_Id, N);
21764 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21765 Set_SPARK_Aux_Pragma (Spec_Id, N);
21766 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21768 -- When the pragma applies to a single protected or task type,
21769 -- decorate the corresponding anonymous object as well.
21771 -- protected Anon_Prot_Typ is
21772 -- pragma SPARK_Mode ...;
21774 -- end Anon_Prot_Typ;
21776 -- Obj : Anon_Prot_Typ;
21778 if Is_Single_Concurrent_Type (Spec_Id) then
21779 Obj_Id := Anonymous_Object (Spec_Id);
21781 Set_SPARK_Pragma (Obj_Id, N);
21782 Set_SPARK_Pragma_Inherited (Obj_Id, False);
21784 end Process_Visible_Part;
21786 -----------------------
21787 -- Set_SPARK_Context --
21788 -----------------------
21790 procedure Set_SPARK_Context is
21792 SPARK_Mode := Mode_Id;
21793 SPARK_Mode_Pragma := N;
21794 end Set_SPARK_Context;
21802 -- Start of processing for Do_SPARK_Mode
21805 -- When a SPARK_Mode pragma appears inside an instantiation whose
21806 -- enclosing context has SPARK_Mode set to "off", the pragma has
21807 -- no semantic effect.
21809 if Ignore_SPARK_Mode_Pragmas_In_Instance then
21810 Rewrite (N, Make_Null_Statement (Loc));
21816 Check_No_Identifiers;
21817 Check_At_Most_N_Arguments (1);
21819 -- Check the legality of the mode (no argument = ON)
21821 if Arg_Count = 1 then
21822 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21823 Mode := Chars (Get_Pragma_Arg (Arg1));
21828 Mode_Id := Get_SPARK_Mode_Type (Mode);
21829 Context := Parent (N);
21831 -- The pragma appears in a configuration file
21833 if No (Context) then
21834 Check_Valid_Configuration_Pragma;
21836 if Present (SPARK_Mode_Pragma) then
21839 Prev => SPARK_Mode_Pragma);
21845 -- The pragma acts as a configuration pragma in a compilation unit
21847 -- pragma SPARK_Mode ...;
21848 -- package Pack is ...;
21850 elsif Nkind (Context) = N_Compilation_Unit
21851 and then List_Containing (N) = Context_Items (Context)
21853 Check_Valid_Configuration_Pragma;
21856 -- Otherwise the placement of the pragma within the tree dictates
21857 -- its associated construct. Inspect the declarative list where
21858 -- the pragma resides to find a potential construct.
21862 while Present (Stmt) loop
21864 -- Skip prior pragmas, but check for duplicates. Note that
21865 -- this also takes care of pragmas generated for aspects.
21867 if Nkind (Stmt) = N_Pragma then
21868 if Pragma_Name (Stmt) = Pname then
21875 -- The pragma applies to an expression function that has
21876 -- already been rewritten into a subprogram declaration.
21878 -- function Expr_Func return ... is (...);
21879 -- pragma SPARK_Mode ...;
21881 elsif Nkind (Stmt) = N_Subprogram_Declaration
21882 and then Nkind (Original_Node (Stmt)) =
21883 N_Expression_Function
21885 Process_Overloadable (Stmt);
21888 -- The pragma applies to the anonymous object created for a
21889 -- single concurrent type.
21891 -- protected type Anon_Prot_Typ ...;
21892 -- Obj : Anon_Prot_Typ;
21893 -- pragma SPARK_Mode ...;
21895 elsif Nkind (Stmt) = N_Object_Declaration
21896 and then Is_Single_Concurrent_Object
21897 (Defining_Entity (Stmt))
21899 Process_Overloadable (Stmt);
21902 -- Skip internally generated code
21904 elsif not Comes_From_Source (Stmt) then
21907 -- The pragma applies to an entry or [generic] subprogram
21911 -- pragma SPARK_Mode ...;
21914 -- procedure Proc ...;
21915 -- pragma SPARK_Mode ...;
21917 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21918 N_Subprogram_Declaration)
21919 or else (Nkind (Stmt) = N_Entry_Declaration
21920 and then Is_Protected_Type
21921 (Scope (Defining_Entity (Stmt))))
21923 Process_Overloadable (Stmt);
21926 -- Otherwise the pragma does not apply to a legal construct
21927 -- or it does not appear at the top of a declarative or a
21928 -- statement list. Issue an error and stop the analysis.
21938 -- The pragma applies to a package or a subprogram that acts as
21939 -- a compilation unit.
21941 -- procedure Proc ...;
21942 -- pragma SPARK_Mode ...;
21944 if Nkind (Context) = N_Compilation_Unit_Aux then
21945 Context := Unit (Parent (Context));
21948 -- The pragma appears at the top of entry, package, protected
21949 -- unit, subprogram or task unit body declarations.
21951 -- entry Ent when ... is
21952 -- pragma SPARK_Mode ...;
21954 -- package body Pack is
21955 -- pragma SPARK_Mode ...;
21957 -- procedure Proc ... is
21958 -- pragma SPARK_Mode;
21960 -- protected body Prot is
21961 -- pragma SPARK_Mode ...;
21963 if Nkind_In (Context, N_Entry_Body,
21969 Process_Body (Context);
21971 -- The pragma appears at the top of the visible or private
21972 -- declaration of a package spec, protected or task unit.
21975 -- pragma SPARK_Mode ...;
21977 -- pragma SPARK_Mode ...;
21979 -- protected [type] Prot is
21980 -- pragma SPARK_Mode ...;
21982 -- pragma SPARK_Mode ...;
21984 elsif Nkind_In (Context, N_Package_Specification,
21985 N_Protected_Definition,
21988 if List_Containing (N) = Visible_Declarations (Context) then
21989 Process_Visible_Part (Parent (Context));
21991 Process_Private_Part (Parent (Context));
21994 -- The pragma appears at the top of package body statements
21996 -- package body Pack is
21998 -- pragma SPARK_Mode;
22000 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
22001 and then Nkind (Parent (Context)) = N_Package_Body
22003 Process_Statement_Part (Parent (Context));
22005 -- The pragma appeared as an aspect of a [generic] subprogram
22006 -- declaration that acts as a compilation unit.
22009 -- procedure Proc ...;
22010 -- pragma SPARK_Mode ...;
22012 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
22013 N_Subprogram_Declaration)
22015 Process_Overloadable (Context);
22017 -- The pragma does not apply to a legal construct, issue error
22025 --------------------------------
22026 -- Static_Elaboration_Desired --
22027 --------------------------------
22029 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22031 when Pragma_Static_Elaboration_Desired =>
22033 Check_At_Most_N_Arguments (1);
22035 if Is_Compilation_Unit (Current_Scope)
22036 and then Ekind (Current_Scope) = E_Package
22038 Set_Static_Elaboration_Desired (Current_Scope, True);
22040 Error_Pragma ("pragma% must apply to a library-level package");
22047 -- pragma Storage_Size (EXPRESSION);
22049 when Pragma_Storage_Size => Storage_Size : declare
22050 P : constant Node_Id := Parent (N);
22054 Check_No_Identifiers;
22055 Check_Arg_Count (1);
22057 -- The expression must be analyzed in the special manner described
22058 -- in "Handling of Default Expressions" in sem.ads.
22060 Arg := Get_Pragma_Arg (Arg1);
22061 Preanalyze_Spec_Expression (Arg, Any_Integer);
22063 if not Is_OK_Static_Expression (Arg) then
22064 Check_Restriction (Static_Storage_Size, Arg);
22067 if Nkind (P) /= N_Task_Definition then
22072 if Has_Storage_Size_Pragma (P) then
22073 Error_Pragma ("duplicate pragma% not allowed");
22075 Set_Has_Storage_Size_Pragma (P, True);
22078 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
22086 -- pragma Storage_Unit (NUMERIC_LITERAL);
22088 -- Only permitted argument is System'Storage_Unit value
22090 when Pragma_Storage_Unit =>
22091 Check_No_Identifiers;
22092 Check_Arg_Count (1);
22093 Check_Arg_Is_Integer_Literal (Arg1);
22095 if Intval (Get_Pragma_Arg (Arg1)) /=
22096 UI_From_Int (Ttypes.System_Storage_Unit)
22098 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
22100 ("the only allowed argument for pragma% is ^", Arg1);
22103 --------------------
22104 -- Stream_Convert --
22105 --------------------
22107 -- pragma Stream_Convert (
22108 -- [Entity =>] type_LOCAL_NAME,
22109 -- [Read =>] function_NAME,
22110 -- [Write =>] function NAME);
22112 when Pragma_Stream_Convert => Stream_Convert : declare
22113 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
22114 -- Check that the given argument is the name of a local function
22115 -- of one argument that is not overloaded earlier in the current
22116 -- local scope. A check is also made that the argument is a
22117 -- function with one parameter.
22119 --------------------------------------
22120 -- Check_OK_Stream_Convert_Function --
22121 --------------------------------------
22123 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
22127 Check_Arg_Is_Local_Name (Arg);
22128 Ent := Entity (Get_Pragma_Arg (Arg));
22130 if Has_Homonym (Ent) then
22132 ("argument for pragma% may not be overloaded", Arg);
22135 if Ekind (Ent) /= E_Function
22136 or else No (First_Formal (Ent))
22137 or else Present (Next_Formal (First_Formal (Ent)))
22140 ("argument for pragma% must be function of one argument",
22143 end Check_OK_Stream_Convert_Function;
22145 -- Start of processing for Stream_Convert
22149 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
22150 Check_Arg_Count (3);
22151 Check_Optional_Identifier (Arg1, Name_Entity);
22152 Check_Optional_Identifier (Arg2, Name_Read);
22153 Check_Optional_Identifier (Arg3, Name_Write);
22154 Check_Arg_Is_Local_Name (Arg1);
22155 Check_OK_Stream_Convert_Function (Arg2);
22156 Check_OK_Stream_Convert_Function (Arg3);
22159 Typ : constant Entity_Id :=
22160 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
22161 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
22162 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
22165 Check_First_Subtype (Arg1);
22167 -- Check for too early or too late. Note that we don't enforce
22168 -- the rule about primitive operations in this case, since, as
22169 -- is the case for explicit stream attributes themselves, these
22170 -- restrictions are not appropriate. Note that the chaining of
22171 -- the pragma by Rep_Item_Too_Late is actually the critical
22172 -- processing done for this pragma.
22174 if Rep_Item_Too_Early (Typ, N)
22176 Rep_Item_Too_Late (Typ, N, FOnly => True)
22181 -- Return if previous error
22183 if Etype (Typ) = Any_Type
22185 Etype (Read) = Any_Type
22187 Etype (Write) = Any_Type
22194 if Underlying_Type (Etype (Read)) /= Typ then
22196 ("incorrect return type for function&", Arg2);
22199 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
22201 ("incorrect parameter type for function&", Arg3);
22204 if Underlying_Type (Etype (First_Formal (Read))) /=
22205 Underlying_Type (Etype (Write))
22208 ("result type of & does not match Read parameter type",
22212 end Stream_Convert;
22218 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22220 -- This is processed by the parser since some of the style checks
22221 -- take place during source scanning and parsing. This means that
22222 -- we don't need to issue error messages here.
22224 when Pragma_Style_Checks => Style_Checks : declare
22225 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22231 Check_No_Identifiers;
22233 -- Two argument form
22235 if Arg_Count = 2 then
22236 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22243 E_Id := Get_Pragma_Arg (Arg2);
22246 if not Is_Entity_Name (E_Id) then
22248 ("second argument of pragma% must be entity name",
22252 E := Entity (E_Id);
22254 if not Ignore_Style_Checks_Pragmas then
22259 Set_Suppress_Style_Checks
22260 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
22261 exit when No (Homonym (E));
22268 -- One argument form
22271 Check_Arg_Count (1);
22273 if Nkind (A) = N_String_Literal then
22277 Slen : constant Natural := Natural (String_Length (S));
22278 Options : String (1 .. Slen);
22284 C := Get_String_Char (S, Pos (J));
22285 exit when not In_Character_Range (C);
22286 Options (J) := Get_Character (C);
22288 -- If at end of string, set options. As per discussion
22289 -- above, no need to check for errors, since we issued
22290 -- them in the parser.
22293 if not Ignore_Style_Checks_Pragmas then
22294 Set_Style_Check_Options (Options);
22304 elsif Nkind (A) = N_Identifier then
22305 if Chars (A) = Name_All_Checks then
22306 if not Ignore_Style_Checks_Pragmas then
22308 Set_GNAT_Style_Check_Options;
22310 Set_Default_Style_Check_Options;
22314 elsif Chars (A) = Name_On then
22315 if not Ignore_Style_Checks_Pragmas then
22316 Style_Check := True;
22319 elsif Chars (A) = Name_Off then
22320 if not Ignore_Style_Checks_Pragmas then
22321 Style_Check := False;
22332 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22334 when Pragma_Subtitle =>
22336 Check_Arg_Count (1);
22337 Check_Optional_Identifier (Arg1, Name_Subtitle);
22338 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22345 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22347 when Pragma_Suppress =>
22348 Process_Suppress_Unsuppress (Suppress_Case => True);
22354 -- pragma Suppress_All;
22356 -- The only check made here is that the pragma has no arguments.
22357 -- There are no placement rules, and the processing required (setting
22358 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22359 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22360 -- then creates and inserts a pragma Suppress (All_Checks).
22362 when Pragma_Suppress_All =>
22364 Check_Arg_Count (0);
22366 -------------------------
22367 -- Suppress_Debug_Info --
22368 -------------------------
22370 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22372 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
22373 Nam_Id : Entity_Id;
22377 Check_Arg_Count (1);
22378 Check_Optional_Identifier (Arg1, Name_Entity);
22379 Check_Arg_Is_Local_Name (Arg1);
22381 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
22383 -- A pragma that applies to a Ghost entity becomes Ghost for the
22384 -- purposes of legality checks and removal of ignored Ghost code.
22386 Mark_Ghost_Pragma (N, Nam_Id);
22387 Set_Debug_Info_Off (Nam_Id);
22388 end Suppress_Debug_Info;
22390 ----------------------------------
22391 -- Suppress_Exception_Locations --
22392 ----------------------------------
22394 -- pragma Suppress_Exception_Locations;
22396 when Pragma_Suppress_Exception_Locations =>
22398 Check_Arg_Count (0);
22399 Check_Valid_Configuration_Pragma;
22400 Exception_Locations_Suppressed := True;
22402 -----------------------------
22403 -- Suppress_Initialization --
22404 -----------------------------
22406 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22408 when Pragma_Suppress_Initialization => Suppress_Init : declare
22414 Check_Arg_Count (1);
22415 Check_Optional_Identifier (Arg1, Name_Entity);
22416 Check_Arg_Is_Local_Name (Arg1);
22418 E_Id := Get_Pragma_Arg (Arg1);
22420 if Etype (E_Id) = Any_Type then
22424 E := Entity (E_Id);
22426 -- A pragma that applies to a Ghost entity becomes Ghost for the
22427 -- purposes of legality checks and removal of ignored Ghost code.
22429 Mark_Ghost_Pragma (N, E);
22431 if not Is_Type (E) and then Ekind (E) /= E_Variable then
22433 ("pragma% requires variable, type or subtype", Arg1);
22436 if Rep_Item_Too_Early (E, N)
22438 Rep_Item_Too_Late (E, N, FOnly => True)
22443 -- For incomplete/private type, set flag on full view
22445 if Is_Incomplete_Or_Private_Type (E) then
22446 if No (Full_View (Base_Type (E))) then
22448 ("argument of pragma% cannot be an incomplete type", Arg1);
22450 Set_Suppress_Initialization (Full_View (Base_Type (E)));
22453 -- For first subtype, set flag on base type
22455 elsif Is_First_Subtype (E) then
22456 Set_Suppress_Initialization (Base_Type (E));
22458 -- For other than first subtype, set flag on subtype or variable
22461 Set_Suppress_Initialization (E);
22469 -- pragma System_Name (DIRECT_NAME);
22471 -- Syntax check: one argument, which must be the identifier GNAT or
22472 -- the identifier GCC, no other identifiers are acceptable.
22474 when Pragma_System_Name =>
22476 Check_No_Identifiers;
22477 Check_Arg_Count (1);
22478 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
22480 -----------------------------
22481 -- Task_Dispatching_Policy --
22482 -----------------------------
22484 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22486 when Pragma_Task_Dispatching_Policy => declare
22490 Check_Ada_83_Warning;
22491 Check_Arg_Count (1);
22492 Check_No_Identifiers;
22493 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
22494 Check_Valid_Configuration_Pragma;
22495 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22496 DP := Fold_Upper (Name_Buffer (1));
22498 if Task_Dispatching_Policy /= ' '
22499 and then Task_Dispatching_Policy /= DP
22501 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
22503 ("task dispatching policy incompatible with policy#");
22505 -- Set new policy, but always preserve System_Location since we
22506 -- like the error message with the run time name.
22509 Task_Dispatching_Policy := DP;
22511 if Task_Dispatching_Policy_Sloc /= System_Location then
22512 Task_Dispatching_Policy_Sloc := Loc;
22521 -- pragma Task_Info (EXPRESSION);
22523 when Pragma_Task_Info => Task_Info : declare
22524 P : constant Node_Id := Parent (N);
22530 if Warn_On_Obsolescent_Feature then
22532 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22533 & "instead?j?", N);
22536 if Nkind (P) /= N_Task_Definition then
22537 Error_Pragma ("pragma% must appear in task definition");
22540 Check_No_Identifiers;
22541 Check_Arg_Count (1);
22543 Analyze_And_Resolve
22544 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
22546 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
22550 Ent := Defining_Identifier (Parent (P));
22552 -- Check duplicate pragma before we chain the pragma in the Rep
22553 -- Item chain of Ent.
22556 (Ent, Name_Task_Info, Check_Parents => False)
22558 Error_Pragma ("duplicate pragma% not allowed");
22561 Record_Rep_Item (Ent, N);
22568 -- pragma Task_Name (string_EXPRESSION);
22570 when Pragma_Task_Name => Task_Name : declare
22571 P : constant Node_Id := Parent (N);
22576 Check_No_Identifiers;
22577 Check_Arg_Count (1);
22579 Arg := Get_Pragma_Arg (Arg1);
22581 -- The expression is used in the call to Create_Task, and must be
22582 -- expanded there, not in the context of the current spec. It must
22583 -- however be analyzed to capture global references, in case it
22584 -- appears in a generic context.
22586 Preanalyze_And_Resolve (Arg, Standard_String);
22588 if Nkind (P) /= N_Task_Definition then
22592 Ent := Defining_Identifier (Parent (P));
22594 -- Check duplicate pragma before we chain the pragma in the Rep
22595 -- Item chain of Ent.
22598 (Ent, Name_Task_Name, Check_Parents => False)
22600 Error_Pragma ("duplicate pragma% not allowed");
22603 Record_Rep_Item (Ent, N);
22610 -- pragma Task_Storage (
22611 -- [Task_Type =>] LOCAL_NAME,
22612 -- [Top_Guard =>] static_integer_EXPRESSION);
22614 when Pragma_Task_Storage => Task_Storage : declare
22615 Args : Args_List (1 .. 2);
22616 Names : constant Name_List (1 .. 2) := (
22620 Task_Type : Node_Id renames Args (1);
22621 Top_Guard : Node_Id renames Args (2);
22627 Gather_Associations (Names, Args);
22629 if No (Task_Type) then
22631 ("missing task_type argument for pragma%");
22634 Check_Arg_Is_Local_Name (Task_Type);
22636 Ent := Entity (Task_Type);
22638 if not Is_Task_Type (Ent) then
22640 ("argument for pragma% must be task type", Task_Type);
22643 if No (Top_Guard) then
22645 ("pragma% takes two arguments", Task_Type);
22647 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22650 Check_First_Subtype (Task_Type);
22652 if Rep_Item_Too_Late (Ent, N) then
22661 -- pragma Test_Case
22662 -- ([Name =>] Static_String_EXPRESSION
22663 -- ,[Mode =>] MODE_TYPE
22664 -- [, Requires => Boolean_EXPRESSION]
22665 -- [, Ensures => Boolean_EXPRESSION]);
22667 -- MODE_TYPE ::= Nominal | Robustness
22669 -- Characteristics:
22671 -- * Analysis - The annotation undergoes initial checks to verify
22672 -- the legal placement and context. Secondary checks preanalyze the
22675 -- Analyze_Test_Case_In_Decl_Part
22677 -- * Expansion - None.
22679 -- * Template - The annotation utilizes the generic template of the
22680 -- related subprogram when it is:
22682 -- aspect on subprogram declaration
22684 -- The annotation must prepare its own template when it is:
22686 -- pragma on subprogram declaration
22688 -- * Globals - Capture of global references must occur after full
22691 -- * Instance - The annotation is instantiated automatically when
22692 -- the related generic subprogram is instantiated except for the
22693 -- "pragma on subprogram declaration" case. In that scenario the
22694 -- annotation must instantiate itself.
22696 when Pragma_Test_Case => Test_Case : declare
22697 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22698 -- Ensure that the contract of subprogram Subp_Id does not contain
22699 -- another Test_Case pragma with the same Name as the current one.
22701 -------------------------
22702 -- Check_Distinct_Name --
22703 -------------------------
22705 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22706 Items : constant Node_Id := Contract (Subp_Id);
22707 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
22711 -- Inspect all Test_Case pragma of the related subprogram
22712 -- looking for one with a duplicate "Name" argument.
22714 if Present (Items) then
22715 Prag := Contract_Test_Cases (Items);
22716 while Present (Prag) loop
22717 if Pragma_Name (Prag) = Name_Test_Case
22719 and then String_Equal
22720 (Name, Get_Name_From_CTC_Pragma (Prag))
22722 Error_Msg_Sloc := Sloc (Prag);
22723 Error_Pragma ("name for pragma % is already used #");
22726 Prag := Next_Pragma (Prag);
22729 end Check_Distinct_Name;
22733 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22736 Subp_Decl : Node_Id;
22737 Subp_Id : Entity_Id;
22739 -- Start of processing for Test_Case
22743 Check_At_Least_N_Arguments (2);
22744 Check_At_Most_N_Arguments (4);
22746 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22750 Check_Optional_Identifier (Arg1, Name_Name);
22751 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22755 Check_Optional_Identifier (Arg2, Name_Mode);
22756 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22758 -- Arguments "Requires" and "Ensures"
22760 if Present (Arg3) then
22761 if Present (Arg4) then
22762 Check_Identifier (Arg3, Name_Requires);
22763 Check_Identifier (Arg4, Name_Ensures);
22765 Check_Identifier_Is_One_Of
22766 (Arg3, Name_Requires, Name_Ensures);
22770 -- Pragma Test_Case must be associated with a subprogram declared
22771 -- in a library-level package. First determine whether the current
22772 -- compilation unit is a legal context.
22774 if Nkind_In (Pack_Decl, N_Package_Declaration,
22775 N_Generic_Package_Declaration)
22779 -- Otherwise the placement is illegal
22783 ("pragma % must be specified within a package declaration");
22787 Subp_Decl := Find_Related_Declaration_Or_Body (N);
22789 -- Find the enclosing context
22791 Context := Parent (Subp_Decl);
22793 if Present (Context) then
22794 Context := Parent (Context);
22797 -- Verify the placement of the pragma
22799 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22801 ("pragma % cannot be applied to abstract subprogram");
22804 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22805 Error_Pragma ("pragma % cannot be applied to entry");
22808 -- The context is a [generic] subprogram declared at the top level
22809 -- of the [generic] package unit.
22811 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22812 N_Subprogram_Declaration)
22813 and then Present (Context)
22814 and then Nkind_In (Context, N_Generic_Package_Declaration,
22815 N_Package_Declaration)
22819 -- Otherwise the placement is illegal
22823 ("pragma % must be applied to a library-level subprogram "
22828 Subp_Id := Defining_Entity (Subp_Decl);
22830 -- A pragma that applies to a Ghost entity becomes Ghost for the
22831 -- purposes of legality checks and removal of ignored Ghost code.
22833 Mark_Ghost_Pragma (N, Subp_Id);
22835 -- Chain the pragma on the contract for further processing by
22836 -- Analyze_Test_Case_In_Decl_Part.
22838 Add_Contract_Item (N, Subp_Id);
22840 -- Preanalyze the original aspect argument "Name" for ASIS or for
22841 -- a generic subprogram to properly capture global references.
22843 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22844 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22846 if Present (Asp_Arg) then
22848 -- The argument appears with an identifier in association
22851 if Nkind (Asp_Arg) = N_Component_Association then
22852 Asp_Arg := Expression (Asp_Arg);
22855 Check_Expr_Is_OK_Static_Expression
22856 (Asp_Arg, Standard_String);
22860 -- Ensure that the all Test_Case pragmas of the related subprogram
22861 -- have distinct names.
22863 Check_Distinct_Name (Subp_Id);
22865 -- Fully analyze the pragma when it appears inside an entry
22866 -- or subprogram body because it cannot benefit from forward
22869 if Nkind_In (Subp_Decl, N_Entry_Body,
22871 N_Subprogram_Body_Stub)
22873 -- The legality checks of pragma Test_Case are affected by the
22874 -- SPARK mode in effect and the volatility of the context.
22875 -- Analyze all pragmas in a specific order.
22877 Analyze_If_Present (Pragma_SPARK_Mode);
22878 Analyze_If_Present (Pragma_Volatile_Function);
22879 Analyze_Test_Case_In_Decl_Part (N);
22883 --------------------------
22884 -- Thread_Local_Storage --
22885 --------------------------
22887 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22889 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22895 Check_Arg_Count (1);
22896 Check_Optional_Identifier (Arg1, Name_Entity);
22897 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22899 Id := Get_Pragma_Arg (Arg1);
22902 if not Is_Entity_Name (Id)
22903 or else Ekind (Entity (Id)) /= E_Variable
22905 Error_Pragma_Arg ("local variable name required", Arg1);
22910 -- A pragma that applies to a Ghost entity becomes Ghost for the
22911 -- purposes of legality checks and removal of ignored Ghost code.
22913 Mark_Ghost_Pragma (N, E);
22915 if Rep_Item_Too_Early (E, N)
22917 Rep_Item_Too_Late (E, N)
22922 Set_Has_Pragma_Thread_Local_Storage (E);
22923 Set_Has_Gigi_Rep_Item (E);
22924 end Thread_Local_Storage;
22930 -- pragma Time_Slice (static_duration_EXPRESSION);
22932 when Pragma_Time_Slice => Time_Slice : declare
22938 Check_Arg_Count (1);
22939 Check_No_Identifiers;
22940 Check_In_Main_Program;
22941 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22943 if not Error_Posted (Arg1) then
22945 while Present (Nod) loop
22946 if Nkind (Nod) = N_Pragma
22947 and then Pragma_Name (Nod) = Name_Time_Slice
22949 Error_Msg_Name_1 := Pname;
22950 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22957 -- Process only if in main unit
22959 if Get_Source_Unit (Loc) = Main_Unit then
22960 Opt.Time_Slice_Set := True;
22961 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22963 if Val <= Ureal_0 then
22964 Opt.Time_Slice_Value := 0;
22966 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22967 Opt.Time_Slice_Value := 1_000_000_000;
22970 Opt.Time_Slice_Value :=
22971 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22980 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22982 -- TITLING_OPTION ::=
22983 -- [Title =>] STRING_LITERAL
22984 -- | [Subtitle =>] STRING_LITERAL
22986 when Pragma_Title => Title : declare
22987 Args : Args_List (1 .. 2);
22988 Names : constant Name_List (1 .. 2) := (
22994 Gather_Associations (Names, Args);
22997 for J in 1 .. 2 loop
22998 if Present (Args (J)) then
22999 Check_Arg_Is_OK_Static_Expression
23000 (Args (J), Standard_String);
23005 ----------------------------
23006 -- Type_Invariant[_Class] --
23007 ----------------------------
23009 -- pragma Type_Invariant[_Class]
23010 -- ([Entity =>] type_LOCAL_NAME,
23011 -- [Check =>] EXPRESSION);
23013 when Pragma_Type_Invariant
23014 | Pragma_Type_Invariant_Class
23016 Type_Invariant : declare
23017 I_Pragma : Node_Id;
23020 Check_Arg_Count (2);
23022 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23023 -- setting Class_Present for the Type_Invariant_Class case.
23025 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
23026 I_Pragma := New_Copy (N);
23027 Set_Pragma_Identifier
23028 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
23029 Rewrite (N, I_Pragma);
23030 Set_Analyzed (N, False);
23032 end Type_Invariant;
23034 ---------------------
23035 -- Unchecked_Union --
23036 ---------------------
23038 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23040 when Pragma_Unchecked_Union => Unchecked_Union : declare
23041 Assoc : constant Node_Id := Arg1;
23042 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
23052 Check_No_Identifiers;
23053 Check_Arg_Count (1);
23054 Check_Arg_Is_Local_Name (Arg1);
23056 Find_Type (Type_Id);
23058 Typ := Entity (Type_Id);
23060 -- A pragma that applies to a Ghost entity becomes Ghost for the
23061 -- purposes of legality checks and removal of ignored Ghost code.
23063 Mark_Ghost_Pragma (N, Typ);
23066 or else Rep_Item_Too_Early (Typ, N)
23070 Typ := Underlying_Type (Typ);
23073 if Rep_Item_Too_Late (Typ, N) then
23077 Check_First_Subtype (Arg1);
23079 -- Note remaining cases are references to a type in the current
23080 -- declarative part. If we find an error, we post the error on
23081 -- the relevant type declaration at an appropriate point.
23083 if not Is_Record_Type (Typ) then
23084 Error_Msg_N ("unchecked union must be record type", Typ);
23087 elsif Is_Tagged_Type (Typ) then
23088 Error_Msg_N ("unchecked union must not be tagged", Typ);
23091 elsif not Has_Discriminants (Typ) then
23093 ("unchecked union must have one discriminant", Typ);
23096 -- Note: in previous versions of GNAT we used to check for limited
23097 -- types and give an error, but in fact the standard does allow
23098 -- Unchecked_Union on limited types, so this check was removed.
23100 -- Similarly, GNAT used to require that all discriminants have
23101 -- default values, but this is not mandated by the RM.
23103 -- Proceed with basic error checks completed
23106 Tdef := Type_Definition (Declaration_Node (Typ));
23107 Clist := Component_List (Tdef);
23109 -- Check presence of component list and variant part
23111 if No (Clist) or else No (Variant_Part (Clist)) then
23113 ("unchecked union must have variant part", Tdef);
23117 -- Check components
23119 Comp := First (Component_Items (Clist));
23120 while Present (Comp) loop
23121 Check_Component (Comp, Typ);
23125 -- Check variant part
23127 Vpart := Variant_Part (Clist);
23129 Variant := First (Variants (Vpart));
23130 while Present (Variant) loop
23131 Check_Variant (Variant, Typ);
23136 Set_Is_Unchecked_Union (Typ);
23137 Set_Convention (Typ, Convention_C);
23138 Set_Has_Unchecked_Union (Base_Type (Typ));
23139 Set_Is_Unchecked_Union (Base_Type (Typ));
23140 end Unchecked_Union;
23142 ----------------------------
23143 -- Unevaluated_Use_Of_Old --
23144 ----------------------------
23146 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23148 when Pragma_Unevaluated_Use_Of_Old =>
23150 Check_Arg_Count (1);
23151 Check_No_Identifiers;
23152 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
23154 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23155 -- a declarative part or a package spec.
23157 if not Is_Configuration_Pragma then
23158 Check_Is_In_Decl_Part_Or_Package_Spec;
23161 -- Store proper setting of Uneval_Old
23163 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23164 Uneval_Old := Fold_Upper (Name_Buffer (1));
23166 ------------------------
23167 -- Unimplemented_Unit --
23168 ------------------------
23170 -- pragma Unimplemented_Unit;
23172 -- Note: this only gives an error if we are generating code, or if
23173 -- we are in a generic library unit (where the pragma appears in the
23174 -- body, not in the spec).
23176 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
23177 Cunitent : constant Entity_Id :=
23178 Cunit_Entity (Get_Source_Unit (Loc));
23179 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
23183 Check_Arg_Count (0);
23185 if Operating_Mode = Generate_Code
23186 or else Ent_Kind = E_Generic_Function
23187 or else Ent_Kind = E_Generic_Procedure
23188 or else Ent_Kind = E_Generic_Package
23190 Get_Name_String (Chars (Cunitent));
23191 Set_Casing (Mixed_Case);
23192 Write_Str (Name_Buffer (1 .. Name_Len));
23193 Write_Str (" is not supported in this configuration");
23195 raise Unrecoverable_Error;
23197 end Unimplemented_Unit;
23199 ------------------------
23200 -- Universal_Aliasing --
23201 ------------------------
23203 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23205 when Pragma_Universal_Aliasing => Universal_Alias : declare
23211 Check_Arg_Count (1);
23212 Check_Optional_Identifier (Arg2, Name_Entity);
23213 Check_Arg_Is_Local_Name (Arg1);
23214 E_Id := Get_Pragma_Arg (Arg1);
23216 if Etype (E_Id) = Any_Type then
23220 E := Entity (E_Id);
23222 if not Is_Type (E) then
23223 Error_Pragma_Arg ("pragma% requires type", Arg1);
23226 -- A pragma that applies to a Ghost entity becomes Ghost for the
23227 -- purposes of legality checks and removal of ignored Ghost code.
23229 Mark_Ghost_Pragma (N, E);
23230 Set_Universal_Aliasing (Base_Type (E));
23231 Record_Rep_Item (E, N);
23232 end Universal_Alias;
23234 --------------------
23235 -- Universal_Data --
23236 --------------------
23238 -- pragma Universal_Data [(library_unit_NAME)];
23240 when Pragma_Universal_Data =>
23242 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
23248 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23250 when Pragma_Unmodified =>
23251 Analyze_Unmodified_Or_Unused;
23257 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23259 -- or when used in a context clause:
23261 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23263 when Pragma_Unreferenced =>
23264 Analyze_Unreferenced_Or_Unused;
23266 --------------------------
23267 -- Unreferenced_Objects --
23268 --------------------------
23270 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23272 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
23274 Arg_Expr : Node_Id;
23275 Arg_Id : Entity_Id;
23277 Ghost_Error_Posted : Boolean := False;
23278 -- Flag set when an error concerning the illegal mix of Ghost and
23279 -- non-Ghost types is emitted.
23281 Ghost_Id : Entity_Id := Empty;
23282 -- The entity of the first Ghost type encountered while processing
23283 -- the arguments of the pragma.
23287 Check_At_Least_N_Arguments (1);
23290 while Present (Arg) loop
23291 Check_No_Identifier (Arg);
23292 Check_Arg_Is_Local_Name (Arg);
23293 Arg_Expr := Get_Pragma_Arg (Arg);
23295 if Is_Entity_Name (Arg_Expr) then
23296 Arg_Id := Entity (Arg_Expr);
23298 if Is_Type (Arg_Id) then
23299 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
23301 -- A pragma that applies to a Ghost entity becomes Ghost
23302 -- for the purposes of legality checks and removal of
23303 -- ignored Ghost code.
23305 Mark_Ghost_Pragma (N, Arg_Id);
23307 -- Capture the entity of the first Ghost type being
23308 -- processed for error detection purposes.
23310 if Is_Ghost_Entity (Arg_Id) then
23311 if No (Ghost_Id) then
23312 Ghost_Id := Arg_Id;
23315 -- Otherwise the type is non-Ghost. It is illegal to mix
23316 -- references to Ghost and non-Ghost entities
23319 elsif Present (Ghost_Id)
23320 and then not Ghost_Error_Posted
23322 Ghost_Error_Posted := True;
23324 Error_Msg_Name_1 := Pname;
23326 ("pragma % cannot mention ghost and non-ghost types",
23329 Error_Msg_Sloc := Sloc (Ghost_Id);
23330 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
23332 Error_Msg_Sloc := Sloc (Arg_Id);
23333 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
23337 ("argument for pragma% must be type or subtype", Arg);
23341 ("argument for pragma% must be type or subtype", Arg);
23346 end Unreferenced_Objects;
23348 ------------------------------
23349 -- Unreserve_All_Interrupts --
23350 ------------------------------
23352 -- pragma Unreserve_All_Interrupts;
23354 when Pragma_Unreserve_All_Interrupts =>
23356 Check_Arg_Count (0);
23358 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
23359 Unreserve_All_Interrupts := True;
23366 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23368 when Pragma_Unsuppress =>
23370 Process_Suppress_Unsuppress (Suppress_Case => False);
23376 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23378 when Pragma_Unused =>
23379 Analyze_Unmodified_Or_Unused (Is_Unused => True);
23380 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
23382 -------------------
23383 -- Use_VADS_Size --
23384 -------------------
23386 -- pragma Use_VADS_Size;
23388 when Pragma_Use_VADS_Size =>
23390 Check_Arg_Count (0);
23391 Check_Valid_Configuration_Pragma;
23392 Use_VADS_Size := True;
23394 ---------------------
23395 -- Validity_Checks --
23396 ---------------------
23398 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23400 when Pragma_Validity_Checks => Validity_Checks : declare
23401 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23407 Check_Arg_Count (1);
23408 Check_No_Identifiers;
23410 -- Pragma always active unless in CodePeer or GNATprove modes,
23411 -- which use a fixed configuration of validity checks.
23413 if not (CodePeer_Mode or GNATprove_Mode) then
23414 if Nkind (A) = N_String_Literal then
23418 Slen : constant Natural := Natural (String_Length (S));
23419 Options : String (1 .. Slen);
23423 -- Couldn't we use a for loop here over Options'Range???
23427 C := Get_String_Char (S, Pos (J));
23429 -- This is a weird test, it skips setting validity
23430 -- checks entirely if any element of S is out of
23431 -- range of Character, what is that about ???
23433 exit when not In_Character_Range (C);
23434 Options (J) := Get_Character (C);
23437 Set_Validity_Check_Options (Options);
23445 elsif Nkind (A) = N_Identifier then
23446 if Chars (A) = Name_All_Checks then
23447 Set_Validity_Check_Options ("a");
23448 elsif Chars (A) = Name_On then
23449 Validity_Checks_On := True;
23450 elsif Chars (A) = Name_Off then
23451 Validity_Checks_On := False;
23455 end Validity_Checks;
23461 -- pragma Volatile (LOCAL_NAME);
23463 when Pragma_Volatile =>
23464 Process_Atomic_Independent_Shared_Volatile;
23466 -------------------------
23467 -- Volatile_Components --
23468 -------------------------
23470 -- pragma Volatile_Components (array_LOCAL_NAME);
23472 -- Volatile is handled by the same circuit as Atomic_Components
23474 --------------------------
23475 -- Volatile_Full_Access --
23476 --------------------------
23478 -- pragma Volatile_Full_Access (LOCAL_NAME);
23480 when Pragma_Volatile_Full_Access =>
23482 Process_Atomic_Independent_Shared_Volatile;
23484 -----------------------
23485 -- Volatile_Function --
23486 -----------------------
23488 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23490 when Pragma_Volatile_Function => Volatile_Function : declare
23491 Over_Id : Entity_Id;
23492 Spec_Id : Entity_Id;
23493 Subp_Decl : Node_Id;
23497 Check_No_Identifiers;
23498 Check_At_Most_N_Arguments (1);
23501 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23503 -- Generic subprogram
23505 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23508 -- Body acts as spec
23510 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23511 and then No (Corresponding_Spec (Subp_Decl))
23515 -- Body stub acts as spec
23517 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23518 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23524 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23532 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23534 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
23539 -- A pragma that applies to a Ghost entity becomes Ghost for the
23540 -- purposes of legality checks and removal of ignored Ghost code.
23542 Mark_Ghost_Pragma (N, Spec_Id);
23544 -- Chain the pragma on the contract for completeness
23546 Add_Contract_Item (N, Spec_Id);
23548 -- The legality checks of pragma Volatile_Function are affected by
23549 -- the SPARK mode in effect. Analyze all pragmas in a specific
23552 Analyze_If_Present (Pragma_SPARK_Mode);
23554 -- A volatile function cannot override a non-volatile function
23555 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23556 -- in New_Overloaded_Entity, however at that point the pragma has
23557 -- not been processed yet.
23559 Over_Id := Overridden_Operation (Spec_Id);
23561 if Present (Over_Id)
23562 and then not Is_Volatile_Function (Over_Id)
23565 ("incompatible volatile function values in effect", Spec_Id);
23567 Error_Msg_Sloc := Sloc (Over_Id);
23569 ("\& declared # with Volatile_Function value False",
23572 Error_Msg_Sloc := Sloc (Spec_Id);
23574 ("\overridden # with Volatile_Function value True",
23578 -- Analyze the Boolean expression (if any)
23580 if Present (Arg1) then
23581 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
23583 end Volatile_Function;
23585 ----------------------
23586 -- Warning_As_Error --
23587 ----------------------
23589 -- pragma Warning_As_Error (static_string_EXPRESSION);
23591 when Pragma_Warning_As_Error =>
23593 Check_Arg_Count (1);
23594 Check_No_Identifiers;
23595 Check_Valid_Configuration_Pragma;
23597 if not Is_Static_String_Expression (Arg1) then
23599 ("argument of pragma% must be static string expression",
23602 -- OK static string expression
23605 Acquire_Warning_Match_String (Arg1);
23606 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23607 Warnings_As_Errors (Warnings_As_Errors_Count) :=
23608 new String'(Name_Buffer (1 .. Name_Len));
23615 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23617 -- DETAILS ::= On | Off
23618 -- DETAILS ::= On | Off, local_NAME
23619 -- DETAILS ::= static_string_EXPRESSION
23620 -- DETAILS ::= On | Off, static_string_EXPRESSION
23622 -- TOOL_NAME ::= GNAT | GNATProve
23624 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23626 -- Note: If the first argument matches an allowed tool name, it is
23627 -- always considered to be a tool name, even if there is a string
23628 -- variable of that name.
23630 -- Note if the second argument of DETAILS is a local_NAME then the
23631 -- second form is always understood. If the intention is to use
23632 -- the fourth form, then you can write NAME & "" to force the
23633 -- intepretation as a static_string_EXPRESSION.
23635 when Pragma_Warnings => Warnings : declare
23636 Reason : String_Id;
23640 Check_At_Least_N_Arguments (1);
23642 -- See if last argument is labeled Reason. If so, make sure we
23643 -- have a string literal or a concatenation of string literals,
23644 -- and acquire the REASON string. Then remove the REASON argument
23645 -- by decreasing Num_Args by one; Remaining processing looks only
23646 -- at first Num_Args arguments).
23649 Last_Arg : constant Node_Id :=
23650 Last (Pragma_Argument_Associations (N));
23653 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23654 and then Chars (Last_Arg) = Name_Reason
23657 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23658 Reason := End_String;
23659 Arg_Count := Arg_Count - 1;
23661 -- Not allowed in compiler units (bootstrap issues)
23663 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23665 -- No REASON string, set null string as reason
23668 Reason := Null_String_Id;
23672 -- Now proceed with REASON taken care of and eliminated
23674 Check_No_Identifiers;
23676 -- If debug flag -gnatd.i is set, pragma is ignored
23678 if Debug_Flag_Dot_I then
23682 -- Process various forms of the pragma
23685 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23686 Shifted_Args : List_Id;
23689 -- See if first argument is a tool name, currently either
23690 -- GNAT or GNATprove. If so, either ignore the pragma if the
23691 -- tool used does not match, or continue as if no tool name
23692 -- was given otherwise, by shifting the arguments.
23694 if Nkind (Argx) = N_Identifier
23695 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23697 if Chars (Argx) = Name_Gnat then
23698 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23699 Rewrite (N, Make_Null_Statement (Loc));
23704 elsif Chars (Argx) = Name_Gnatprove then
23705 if not GNATprove_Mode then
23706 Rewrite (N, Make_Null_Statement (Loc));
23712 raise Program_Error;
23715 -- At this point, the pragma Warnings applies to the tool,
23716 -- so continue with shifted arguments.
23718 Arg_Count := Arg_Count - 1;
23720 if Arg_Count = 1 then
23721 Shifted_Args := New_List (New_Copy (Arg2));
23722 elsif Arg_Count = 2 then
23723 Shifted_Args := New_List (New_Copy (Arg2),
23725 elsif Arg_Count = 3 then
23726 Shifted_Args := New_List (New_Copy (Arg2),
23730 raise Program_Error;
23735 Chars => Name_Warnings,
23736 Pragma_Argument_Associations => Shifted_Args));
23741 -- One argument case
23743 if Arg_Count = 1 then
23745 -- On/Off one argument case was processed by parser
23747 if Nkind (Argx) = N_Identifier
23748 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23752 -- One argument case must be ON/OFF or static string expr
23754 elsif not Is_Static_String_Expression (Arg1) then
23756 ("argument of pragma% must be On/Off or static string "
23757 & "expression", Arg1);
23759 -- One argument string expression case
23763 Lit : constant Node_Id := Expr_Value_S (Argx);
23764 Str : constant String_Id := Strval (Lit);
23765 Len : constant Nat := String_Length (Str);
23773 while J <= Len loop
23774 C := Get_String_Char (Str, J);
23775 OK := In_Character_Range (C);
23778 Chr := Get_Character (C);
23780 -- Dash case: only -Wxxx is accepted
23787 C := Get_String_Char (Str, J);
23788 Chr := Get_Character (C);
23789 exit when Chr = 'W';
23794 elsif J < Len and then Chr = '.' then
23796 C := Get_String_Char (Str, J);
23797 Chr := Get_Character (C);
23799 if not Set_Dot_Warning_Switch (Chr) then
23801 ("invalid warning switch character "
23802 & '.' & Chr, Arg1);
23808 OK := Set_Warning_Switch (Chr);
23814 ("invalid warning switch character " & Chr,
23823 -- Two or more arguments (must be two)
23826 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23827 Check_Arg_Count (2);
23835 E_Id := Get_Pragma_Arg (Arg2);
23838 -- In the expansion of an inlined body, a reference to
23839 -- the formal may be wrapped in a conversion if the
23840 -- actual is a conversion. Retrieve the real entity name.
23842 if (In_Instance_Body or In_Inlined_Body)
23843 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23845 E_Id := Expression (E_Id);
23848 -- Entity name case
23850 if Is_Entity_Name (E_Id) then
23851 E := Entity (E_Id);
23858 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23861 -- For OFF case, make entry in warnings off
23862 -- pragma table for later processing. But we do
23863 -- not do that within an instance, since these
23864 -- warnings are about what is needed in the
23865 -- template, not an instance of it.
23867 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23868 and then Warn_On_Warnings_Off
23869 and then not In_Instance
23871 Warnings_Off_Pragmas.Append ((N, E, Reason));
23874 if Is_Enumeration_Type (E) then
23878 Lit := First_Literal (E);
23879 while Present (Lit) loop
23880 Set_Warnings_Off (Lit);
23881 Next_Literal (Lit);
23886 exit when No (Homonym (E));
23891 -- Error if not entity or static string expression case
23893 elsif not Is_Static_String_Expression (Arg2) then
23895 ("second argument of pragma% must be entity name "
23896 & "or static string expression", Arg2);
23898 -- Static string expression case
23901 Acquire_Warning_Match_String (Arg2);
23903 -- Note on configuration pragma case: If this is a
23904 -- configuration pragma, then for an OFF pragma, we
23905 -- just set Config True in the call, which is all
23906 -- that needs to be done. For the case of ON, this
23907 -- is normally an error, unless it is canceling the
23908 -- effect of a previous OFF pragma in the same file.
23909 -- In any other case, an error will be signalled (ON
23910 -- with no matching OFF).
23912 -- Note: We set Used if we are inside a generic to
23913 -- disable the test that the non-config case actually
23914 -- cancels a warning. That's because we can't be sure
23915 -- there isn't an instantiation in some other unit
23916 -- where a warning is suppressed.
23918 -- We could do a little better here by checking if the
23919 -- generic unit we are inside is public, but for now
23920 -- we don't bother with that refinement.
23922 if Chars (Argx) = Name_Off then
23923 Set_Specific_Warning_Off
23924 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23925 Config => Is_Configuration_Pragma,
23926 Used => Inside_A_Generic or else In_Instance);
23928 elsif Chars (Argx) = Name_On then
23929 Set_Specific_Warning_On
23930 (Loc, Name_Buffer (1 .. Name_Len), Err);
23934 ("??pragma Warnings On with no matching "
23935 & "Warnings Off", Loc);
23944 -------------------
23945 -- Weak_External --
23946 -------------------
23948 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23950 when Pragma_Weak_External => Weak_External : declare
23955 Check_Arg_Count (1);
23956 Check_Optional_Identifier (Arg1, Name_Entity);
23957 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23958 Ent := Entity (Get_Pragma_Arg (Arg1));
23960 if Rep_Item_Too_Early (Ent, N) then
23963 Ent := Underlying_Type (Ent);
23966 -- The only processing required is to link this item on to the
23967 -- list of rep items for the given entity. This is accomplished
23968 -- by the call to Rep_Item_Too_Late (when no error is detected
23969 -- and False is returned).
23971 if Rep_Item_Too_Late (Ent, N) then
23974 Set_Has_Gigi_Rep_Item (Ent);
23978 -----------------------------
23979 -- Wide_Character_Encoding --
23980 -----------------------------
23982 -- pragma Wide_Character_Encoding (IDENTIFIER);
23984 when Pragma_Wide_Character_Encoding =>
23987 -- Nothing to do, handled in parser. Note that we do not enforce
23988 -- configuration pragma placement, this pragma can appear at any
23989 -- place in the source, allowing mixed encodings within a single
23994 --------------------
23995 -- Unknown_Pragma --
23996 --------------------
23998 -- Should be impossible, since the case of an unknown pragma is
23999 -- separately processed before the case statement is entered.
24001 when Unknown_Pragma =>
24002 raise Program_Error;
24005 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24006 -- until AI is formally approved.
24008 -- Check_Order_Dependence;
24011 when Pragma_Exit => null;
24012 end Analyze_Pragma;
24014 ---------------------------------------------
24015 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24016 ---------------------------------------------
24018 -- WARNING: This routine manages Ghost regions. Return statements must be
24019 -- replaced by gotos which jump to the end of the routine and restore the
24022 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24024 Freeze_Id : Entity_Id := Empty)
24026 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24027 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24029 Disp_Typ : Entity_Id;
24030 -- The dispatching type of the subprogram subject to the pre- or
24033 function Check_References (Nod : Node_Id) return Traverse_Result;
24034 -- Check that expression Nod does not mention non-primitives of the
24035 -- type, global objects of the type, or other illegalities described
24036 -- and implied by AI12-0113.
24038 ----------------------
24039 -- Check_References --
24040 ----------------------
24042 function Check_References (Nod : Node_Id) return Traverse_Result is
24044 if Nkind (Nod) = N_Function_Call
24045 and then Is_Entity_Name (Name (Nod))
24048 Func : constant Entity_Id := Entity (Name (Nod));
24052 -- An operation of the type must be a primitive
24054 if No (Find_Dispatching_Type (Func)) then
24055 Form := First_Formal (Func);
24056 while Present (Form) loop
24057 if Etype (Form) = Disp_Typ then
24059 ("operation in class-wide condition must be "
24060 & "primitive of &", Nod, Disp_Typ);
24063 Next_Formal (Form);
24066 -- A return object of the type is illegal as well
24068 if Etype (Func) = Disp_Typ
24069 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24072 ("operation in class-wide condition must be primitive "
24073 & "of &", Nod, Disp_Typ);
24076 -- Otherwise we have a call to an overridden primitive, and we
24077 -- will create a common class-wide clone for the body of
24078 -- original operation and its eventual inherited versions. If
24079 -- the original operation dispatches on result it is never
24080 -- inherited and there is no need for a clone. There is not
24081 -- need for a clone either in GNATprove mode, as cases that
24082 -- would require it are rejected (when an inherited primitive
24083 -- calls an overridden operation in a class-wide contract), and
24084 -- the clone would make proof impossible in some cases.
24086 elsif not Is_Abstract_Subprogram (Spec_Id)
24087 and then No (Class_Wide_Clone (Spec_Id))
24088 and then not Has_Controlling_Result (Spec_Id)
24089 and then not GNATprove_Mode
24091 Build_Class_Wide_Clone_Decl (Spec_Id);
24095 elsif Is_Entity_Name (Nod)
24097 (Etype (Nod) = Disp_Typ
24098 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24099 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24102 ("object in class-wide condition must be formal of type &",
24105 elsif Nkind (Nod) = N_Explicit_Dereference
24106 and then (Etype (Nod) = Disp_Typ
24107 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24108 and then (not Is_Entity_Name (Prefix (Nod))
24109 or else not Is_Formal (Entity (Prefix (Nod))))
24112 ("operation in class-wide condition must be primitive of &",
24117 end Check_References;
24119 procedure Check_Class_Wide_Condition is
24120 new Traverse_Proc (Check_References);
24124 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24125 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24126 -- Save the Ghost mode to restore on exit
24129 Restore_Scope : Boolean := False;
24131 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24134 -- Do not analyze the pragma multiple times
24136 if Is_Analyzed_Pragma (N) then
24140 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24141 -- analysis of the pragma, the Ghost mode at point of declaration and
24142 -- point of analysis may not necessarily be the same. Use the mode in
24143 -- effect at the point of declaration.
24145 Set_Ghost_Mode (N);
24147 -- Ensure that the subprogram and its formals are visible when analyzing
24148 -- the expression of the pragma.
24150 if not In_Open_Scopes (Spec_Id) then
24151 Restore_Scope := True;
24152 Push_Scope (Spec_Id);
24154 if Is_Generic_Subprogram (Spec_Id) then
24155 Install_Generic_Formals (Spec_Id);
24157 Install_Formals (Spec_Id);
24161 Errors := Serious_Errors_Detected;
24162 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24164 -- Emit a clarification message when the expression contains at least
24165 -- one undefined reference, possibly due to contract "freezing".
24167 if Errors /= Serious_Errors_Detected
24168 and then Present (Freeze_Id)
24169 and then Has_Undefined_Reference (Expr)
24171 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24174 if Class_Present (N) then
24176 -- Verify that a class-wide condition is legal, i.e. the operation is
24177 -- a primitive of a tagged type. Note that a generic subprogram is
24178 -- not a primitive operation.
24180 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24182 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24183 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24185 if From_Aspect_Specification (N) then
24187 ("aspect % can only be specified for a primitive operation "
24188 & "of a tagged type", Corresponding_Aspect (N));
24190 -- The pragma is a source construct
24194 ("pragma % can only be specified for a primitive operation "
24195 & "of a tagged type", N);
24198 -- Remaining semantic checks require a full tree traversal
24201 Check_Class_Wide_Condition (Expr);
24206 if Restore_Scope then
24210 -- If analysis of the condition indicates that a class-wide clone
24211 -- has been created, build and analyze its declaration.
24213 if Is_Subprogram (Spec_Id)
24214 and then Present (Class_Wide_Clone (Spec_Id))
24216 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
24219 -- Currently it is not possible to inline pre/postconditions on a
24220 -- subprogram subject to pragma Inline_Always.
24222 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24223 Set_Is_Analyzed_Pragma (N);
24225 Restore_Ghost_Mode (Saved_GM);
24226 end Analyze_Pre_Post_Condition_In_Decl_Part;
24228 ------------------------------------------
24229 -- Analyze_Refined_Depends_In_Decl_Part --
24230 ------------------------------------------
24232 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24233 procedure Check_Dependency_Clause
24234 (Spec_Id : Entity_Id;
24235 Dep_Clause : Node_Id;
24236 Dep_States : Elist_Id;
24237 Refinements : List_Id;
24238 Matched_Items : in out Elist_Id);
24239 -- Try to match a single dependency clause Dep_Clause against one or
24240 -- more refinement clauses found in list Refinements. Each successful
24241 -- match eliminates at least one refinement clause from Refinements.
24242 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24243 -- denotes the entities of all abstract states which appear in pragma
24244 -- Depends. Matched_Items contains the entities of all successfully
24245 -- matched items found in pragma Depends.
24247 procedure Check_Output_States
24248 (Spec_Id : Entity_Id;
24249 Spec_Inputs : Elist_Id;
24250 Spec_Outputs : Elist_Id;
24251 Body_Inputs : Elist_Id;
24252 Body_Outputs : Elist_Id);
24253 -- Determine whether pragma Depends contains an output state with a
24254 -- visible refinement and if so, ensure that pragma Refined_Depends
24255 -- mentions all its constituents as outputs. Spec_Id is the entity of
24256 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24257 -- inputs and outputs of the subprogram spec synthesized from pragma
24258 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24259 -- of the subprogram body synthesized from pragma Refined_Depends.
24261 function Collect_States (Clauses : List_Id) return Elist_Id;
24262 -- Given a normalized list of dependencies obtained from calling
24263 -- Normalize_Clauses, return a list containing the entities of all
24264 -- states appearing in dependencies. It helps in checking refinements
24265 -- involving a state and a corresponding constituent which is not a
24266 -- direct constituent of the state.
24268 procedure Normalize_Clauses (Clauses : List_Id);
24269 -- Given a list of dependence or refinement clauses Clauses, normalize
24270 -- each clause by creating multiple dependencies with exactly one input
24273 procedure Remove_Extra_Clauses
24274 (Clauses : List_Id;
24275 Matched_Items : Elist_Id);
24276 -- Given a list of refinement clauses Clauses, remove all clauses whose
24277 -- inputs and/or outputs have been previously matched. See the body for
24278 -- all special cases. Matched_Items contains the entities of all matched
24279 -- items found in pragma Depends.
24281 procedure Report_Extra_Clauses
24282 (Spec_Id : Entity_Id;
24283 Clauses : List_Id);
24284 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24285 -- denotes the entity of the related subprogram.
24287 -----------------------------
24288 -- Check_Dependency_Clause --
24289 -----------------------------
24291 procedure Check_Dependency_Clause
24292 (Spec_Id : Entity_Id;
24293 Dep_Clause : Node_Id;
24294 Dep_States : Elist_Id;
24295 Refinements : List_Id;
24296 Matched_Items : in out Elist_Id)
24298 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24299 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24301 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24302 -- Determine whether dependency item Dep_Item has been matched in a
24303 -- previous clause.
24305 function Is_In_Out_State_Clause return Boolean;
24306 -- Determine whether dependence clause Dep_Clause denotes an abstract
24307 -- state that depends on itself (State => State).
24309 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24310 -- Determine whether item Item denotes an abstract state with visible
24311 -- null refinement.
24313 procedure Match_Items
24314 (Dep_Item : Node_Id;
24315 Ref_Item : Node_Id;
24316 Matched : out Boolean);
24317 -- Try to match dependence item Dep_Item against refinement item
24318 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24319 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24320 -- the following conformance scenarios is in effect:
24321 -- 1) Both items denote null
24322 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24323 -- 3) Both items denote attribute 'Result
24324 -- 4) Both items denote the same object
24325 -- 5) Both items denote the same formal parameter
24326 -- 6) Both items denote the same current instance of a type
24327 -- 7) Both items denote the same discriminant
24328 -- 8) Dep_Item is an abstract state with visible null refinement
24329 -- and Ref_Item denotes null.
24330 -- 9) Dep_Item is an abstract state with visible null refinement
24331 -- and Ref_Item is Empty (special case).
24332 -- 10) Dep_Item is an abstract state with full or partial visible
24333 -- non-null refinement and Ref_Item denotes one of its
24335 -- 11) Dep_Item is an abstract state without a full visible
24336 -- refinement and Ref_Item denotes the same state.
24337 -- When scenario 10 is in effect, the entity of the abstract state
24338 -- denoted by Dep_Item is added to list Refined_States.
24340 procedure Record_Item (Item_Id : Entity_Id);
24341 -- Store the entity of an item denoted by Item_Id in Matched_Items
24343 ------------------------
24344 -- Is_Already_Matched --
24345 ------------------------
24347 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
24348 Item_Id : Entity_Id := Empty;
24351 -- When the dependency item denotes attribute 'Result, check for
24352 -- the entity of the related subprogram.
24354 if Is_Attribute_Result (Dep_Item) then
24355 Item_Id := Spec_Id;
24357 elsif Is_Entity_Name (Dep_Item) then
24358 Item_Id := Available_View (Entity_Of (Dep_Item));
24362 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
24363 end Is_Already_Matched;
24365 ----------------------------
24366 -- Is_In_Out_State_Clause --
24367 ----------------------------
24369 function Is_In_Out_State_Clause return Boolean is
24370 Dep_Input_Id : Entity_Id;
24371 Dep_Output_Id : Entity_Id;
24374 -- Detect the following clause:
24377 if Is_Entity_Name (Dep_Input)
24378 and then Is_Entity_Name (Dep_Output)
24380 -- Handle abstract views generated for limited with clauses
24382 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
24383 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
24386 Ekind (Dep_Input_Id) = E_Abstract_State
24387 and then Dep_Input_Id = Dep_Output_Id;
24391 end Is_In_Out_State_Clause;
24393 ---------------------------
24394 -- Is_Null_Refined_State --
24395 ---------------------------
24397 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
24398 Item_Id : Entity_Id;
24401 if Is_Entity_Name (Item) then
24403 -- Handle abstract views generated for limited with clauses
24405 Item_Id := Available_View (Entity_Of (Item));
24408 Ekind (Item_Id) = E_Abstract_State
24409 and then Has_Null_Visible_Refinement (Item_Id);
24413 end Is_Null_Refined_State;
24419 procedure Match_Items
24420 (Dep_Item : Node_Id;
24421 Ref_Item : Node_Id;
24422 Matched : out Boolean)
24424 Dep_Item_Id : Entity_Id;
24425 Ref_Item_Id : Entity_Id;
24428 -- Assume that the two items do not match
24432 -- A null matches null or Empty (special case)
24434 if Nkind (Dep_Item) = N_Null
24435 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24439 -- Attribute 'Result matches attribute 'Result
24441 elsif Is_Attribute_Result (Dep_Item)
24442 and then Is_Attribute_Result (Ref_Item)
24444 -- Put the entity of the related function on the list of
24445 -- matched items because attribute 'Result does not carry
24446 -- an entity similar to states and constituents.
24448 Record_Item (Spec_Id);
24451 -- Abstract states, current instances of concurrent types,
24452 -- discriminants, formal parameters and objects.
24454 elsif Is_Entity_Name (Dep_Item) then
24456 -- Handle abstract views generated for limited with clauses
24458 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
24460 if Ekind (Dep_Item_Id) = E_Abstract_State then
24462 -- An abstract state with visible null refinement matches
24463 -- null or Empty (special case).
24465 if Has_Null_Visible_Refinement (Dep_Item_Id)
24466 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24468 Record_Item (Dep_Item_Id);
24471 -- An abstract state with visible non-null refinement
24472 -- matches one of its constituents, or itself for an
24473 -- abstract state with partial visible refinement.
24475 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
24476 if Is_Entity_Name (Ref_Item) then
24477 Ref_Item_Id := Entity_Of (Ref_Item);
24479 if Ekind_In (Ref_Item_Id, E_Abstract_State,
24482 and then Present (Encapsulating_State (Ref_Item_Id))
24483 and then Find_Encapsulating_State
24484 (Dep_States, Ref_Item_Id) = Dep_Item_Id
24486 Record_Item (Dep_Item_Id);
24489 elsif not Has_Visible_Refinement (Dep_Item_Id)
24490 and then Ref_Item_Id = Dep_Item_Id
24492 Record_Item (Dep_Item_Id);
24497 -- An abstract state without a visible refinement matches
24500 elsif Is_Entity_Name (Ref_Item)
24501 and then Entity_Of (Ref_Item) = Dep_Item_Id
24503 Record_Item (Dep_Item_Id);
24507 -- A current instance of a concurrent type, discriminant,
24508 -- formal parameter or an object matches itself.
24510 elsif Is_Entity_Name (Ref_Item)
24511 and then Entity_Of (Ref_Item) = Dep_Item_Id
24513 Record_Item (Dep_Item_Id);
24523 procedure Record_Item (Item_Id : Entity_Id) is
24525 if No (Matched_Items) then
24526 Matched_Items := New_Elmt_List;
24529 Append_Unique_Elmt (Item_Id, Matched_Items);
24534 Clause_Matched : Boolean := False;
24535 Dummy : Boolean := False;
24536 Inputs_Match : Boolean;
24537 Next_Ref_Clause : Node_Id;
24538 Outputs_Match : Boolean;
24539 Ref_Clause : Node_Id;
24540 Ref_Input : Node_Id;
24541 Ref_Output : Node_Id;
24543 -- Start of processing for Check_Dependency_Clause
24546 -- Do not perform this check in an instance because it was already
24547 -- performed successfully in the generic template.
24549 if Is_Generic_Instance (Spec_Id) then
24553 -- Examine all refinement clauses and compare them against the
24554 -- dependence clause.
24556 Ref_Clause := First (Refinements);
24557 while Present (Ref_Clause) loop
24558 Next_Ref_Clause := Next (Ref_Clause);
24560 -- Obtain the attributes of the current refinement clause
24562 Ref_Input := Expression (Ref_Clause);
24563 Ref_Output := First (Choices (Ref_Clause));
24565 -- The current refinement clause matches the dependence clause
24566 -- when both outputs match and both inputs match. See routine
24567 -- Match_Items for all possible conformance scenarios.
24569 -- Depends Dep_Output => Dep_Input
24573 -- Refined_Depends Ref_Output => Ref_Input
24576 (Dep_Item => Dep_Input,
24577 Ref_Item => Ref_Input,
24578 Matched => Inputs_Match);
24581 (Dep_Item => Dep_Output,
24582 Ref_Item => Ref_Output,
24583 Matched => Outputs_Match);
24585 -- An In_Out state clause may be matched against a refinement with
24586 -- a null input or null output as long as the non-null side of the
24587 -- relation contains a valid constituent of the In_Out_State.
24589 if Is_In_Out_State_Clause then
24591 -- Depends => (State => State)
24592 -- Refined_Depends => (null => Constit) -- OK
24595 and then not Outputs_Match
24596 and then Nkind (Ref_Output) = N_Null
24598 Outputs_Match := True;
24601 -- Depends => (State => State)
24602 -- Refined_Depends => (Constit => null) -- OK
24604 if not Inputs_Match
24605 and then Outputs_Match
24606 and then Nkind (Ref_Input) = N_Null
24608 Inputs_Match := True;
24612 -- The current refinement clause is legally constructed following
24613 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24614 -- the pool of candidates. The seach continues because a single
24615 -- dependence clause may have multiple matching refinements.
24617 if Inputs_Match and Outputs_Match then
24618 Clause_Matched := True;
24619 Remove (Ref_Clause);
24622 Ref_Clause := Next_Ref_Clause;
24625 -- Depending on the order or composition of refinement clauses, an
24626 -- In_Out state clause may not be directly refinable.
24628 -- Refined_State => (State => (Constit_1, Constit_2))
24629 -- Depends => ((Output, State) => (Input, State))
24630 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24632 -- Matching normalized clause (State => State) fails because there is
24633 -- no direct refinement capable of satisfying this relation. Another
24634 -- similar case arises when clauses (Constit_1 => Input) and (Output
24635 -- => Constit_2) are matched first, leaving no candidates for clause
24636 -- (State => State). Both scenarios are legal as long as one of the
24637 -- previous clauses mentioned a valid constituent of State.
24639 if not Clause_Matched
24640 and then Is_In_Out_State_Clause
24641 and then Is_Already_Matched (Dep_Input)
24643 Clause_Matched := True;
24646 -- A clause where the input is an abstract state with visible null
24647 -- refinement or a 'Result attribute is implicitly matched when the
24648 -- output has already been matched in a previous clause.
24650 -- Refined_State => (State => null)
24651 -- Depends => (Output => State) -- implicitly OK
24652 -- Refined_Depends => (Output => ...)
24653 -- Depends => (...'Result => State) -- implicitly OK
24654 -- Refined_Depends => (...'Result => ...)
24656 if not Clause_Matched
24657 and then Is_Null_Refined_State (Dep_Input)
24658 and then Is_Already_Matched (Dep_Output)
24660 Clause_Matched := True;
24663 -- A clause where the output is an abstract state with visible null
24664 -- refinement is implicitly matched when the input has already been
24665 -- matched in a previous clause.
24667 -- Refined_State => (State => null)
24668 -- Depends => (State => Input) -- implicitly OK
24669 -- Refined_Depends => (... => Input)
24671 if not Clause_Matched
24672 and then Is_Null_Refined_State (Dep_Output)
24673 and then Is_Already_Matched (Dep_Input)
24675 Clause_Matched := True;
24678 -- At this point either all refinement clauses have been examined or
24679 -- pragma Refined_Depends contains a solitary null. Only an abstract
24680 -- state with null refinement can possibly match these cases.
24682 -- Refined_State => (State => null)
24683 -- Depends => (State => null)
24684 -- Refined_Depends => null -- OK
24686 if not Clause_Matched then
24688 (Dep_Item => Dep_Input,
24690 Matched => Inputs_Match);
24693 (Dep_Item => Dep_Output,
24695 Matched => Outputs_Match);
24697 Clause_Matched := Inputs_Match and Outputs_Match;
24700 -- If the contents of Refined_Depends are legal, then the current
24701 -- dependence clause should be satisfied either by an explicit match
24702 -- or by one of the special cases.
24704 if not Clause_Matched then
24706 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24707 & "matching refinement in body"), Dep_Clause, Spec_Id);
24709 end Check_Dependency_Clause;
24711 -------------------------
24712 -- Check_Output_States --
24713 -------------------------
24715 procedure Check_Output_States
24716 (Spec_Id : Entity_Id;
24717 Spec_Inputs : Elist_Id;
24718 Spec_Outputs : Elist_Id;
24719 Body_Inputs : Elist_Id;
24720 Body_Outputs : Elist_Id)
24722 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24723 -- Determine whether all constituents of state State_Id with full
24724 -- visible refinement are used as outputs in pragma Refined_Depends.
24725 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24727 -----------------------------
24728 -- Check_Constituent_Usage --
24729 -----------------------------
24731 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24732 Constits : constant Elist_Id :=
24733 Partial_Refinement_Constituents (State_Id);
24734 Constit_Elmt : Elmt_Id;
24735 Constit_Id : Entity_Id;
24736 Only_Partial : constant Boolean :=
24737 not Has_Visible_Refinement (State_Id);
24738 Posted : Boolean := False;
24741 if Present (Constits) then
24742 Constit_Elmt := First_Elmt (Constits);
24743 while Present (Constit_Elmt) loop
24744 Constit_Id := Node (Constit_Elmt);
24746 -- Issue an error when a constituent of State_Id is used,
24747 -- and State_Id has only partial visible refinement
24748 -- (SPARK RM 7.2.4(3d)).
24750 if Only_Partial then
24751 if (Present (Body_Inputs)
24752 and then Appears_In (Body_Inputs, Constit_Id))
24754 (Present (Body_Outputs)
24755 and then Appears_In (Body_Outputs, Constit_Id))
24757 Error_Msg_Name_1 := Chars (State_Id);
24759 ("constituent & of state % cannot be used in "
24760 & "dependence refinement", N, Constit_Id);
24761 Error_Msg_Name_1 := Chars (State_Id);
24762 SPARK_Msg_N ("\use state % instead", N);
24765 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24767 elsif Present (Body_Inputs)
24768 and then Appears_In (Body_Inputs, Constit_Id)
24770 Error_Msg_Name_1 := Chars (State_Id);
24772 ("constituent & of state % must act as output in "
24773 & "dependence refinement", N, Constit_Id);
24775 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24777 elsif No (Body_Outputs)
24778 or else not Appears_In (Body_Outputs, Constit_Id)
24783 ("output state & must be replaced by all its "
24784 & "constituents in dependence refinement",
24789 ("\constituent & is missing in output list",
24793 Next_Elmt (Constit_Elmt);
24796 end Check_Constituent_Usage;
24801 Item_Elmt : Elmt_Id;
24802 Item_Id : Entity_Id;
24804 -- Start of processing for Check_Output_States
24807 -- Do not perform this check in an instance because it was already
24808 -- performed successfully in the generic template.
24810 if Is_Generic_Instance (Spec_Id) then
24813 -- Inspect the outputs of pragma Depends looking for a state with a
24814 -- visible refinement.
24816 elsif Present (Spec_Outputs) then
24817 Item_Elmt := First_Elmt (Spec_Outputs);
24818 while Present (Item_Elmt) loop
24819 Item := Node (Item_Elmt);
24821 -- Deal with the mixed nature of the input and output lists
24823 if Nkind (Item) = N_Defining_Identifier then
24826 Item_Id := Available_View (Entity_Of (Item));
24829 if Ekind (Item_Id) = E_Abstract_State then
24831 -- The state acts as an input-output, skip it
24833 if Present (Spec_Inputs)
24834 and then Appears_In (Spec_Inputs, Item_Id)
24838 -- Ensure that all of the constituents are utilized as
24839 -- outputs in pragma Refined_Depends.
24841 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24842 Check_Constituent_Usage (Item_Id);
24846 Next_Elmt (Item_Elmt);
24849 end Check_Output_States;
24851 --------------------
24852 -- Collect_States --
24853 --------------------
24855 function Collect_States (Clauses : List_Id) return Elist_Id is
24856 procedure Collect_State
24858 States : in out Elist_Id);
24859 -- Add the entity of Item to list States when it denotes to a state
24861 -------------------
24862 -- Collect_State --
24863 -------------------
24865 procedure Collect_State
24867 States : in out Elist_Id)
24872 if Is_Entity_Name (Item) then
24873 Id := Entity_Of (Item);
24875 if Ekind (Id) = E_Abstract_State then
24876 if No (States) then
24877 States := New_Elmt_List;
24880 Append_Unique_Elmt (Id, States);
24890 States : Elist_Id := No_Elist;
24892 -- Start of processing for Collect_States
24895 Clause := First (Clauses);
24896 while Present (Clause) loop
24897 Input := Expression (Clause);
24898 Output := First (Choices (Clause));
24900 Collect_State (Input, States);
24901 Collect_State (Output, States);
24907 end Collect_States;
24909 -----------------------
24910 -- Normalize_Clauses --
24911 -----------------------
24913 procedure Normalize_Clauses (Clauses : List_Id) is
24914 procedure Normalize_Inputs (Clause : Node_Id);
24915 -- Normalize clause Clause by creating multiple clauses for each
24916 -- input item of Clause. It is assumed that Clause has exactly one
24917 -- output. The transformation is as follows:
24919 -- Output => (Input_1, Input_2) -- original
24921 -- Output => Input_1 -- normalizations
24922 -- Output => Input_2
24924 procedure Normalize_Outputs (Clause : Node_Id);
24925 -- Normalize clause Clause by creating multiple clause for each
24926 -- output item of Clause. The transformation is as follows:
24928 -- (Output_1, Output_2) => Input -- original
24930 -- Output_1 => Input -- normalization
24931 -- Output_2 => Input
24933 ----------------------
24934 -- Normalize_Inputs --
24935 ----------------------
24937 procedure Normalize_Inputs (Clause : Node_Id) is
24938 Inputs : constant Node_Id := Expression (Clause);
24939 Loc : constant Source_Ptr := Sloc (Clause);
24940 Output : constant List_Id := Choices (Clause);
24941 Last_Input : Node_Id;
24943 New_Clause : Node_Id;
24944 Next_Input : Node_Id;
24947 -- Normalization is performed only when the original clause has
24948 -- more than one input. Multiple inputs appear as an aggregate.
24950 if Nkind (Inputs) = N_Aggregate then
24951 Last_Input := Last (Expressions (Inputs));
24953 -- Create a new clause for each input
24955 Input := First (Expressions (Inputs));
24956 while Present (Input) loop
24957 Next_Input := Next (Input);
24959 -- Unhook the current input from the original input list
24960 -- because it will be relocated to a new clause.
24964 -- Special processing for the last input. At this point the
24965 -- original aggregate has been stripped down to one element.
24966 -- Replace the aggregate by the element itself.
24968 if Input = Last_Input then
24969 Rewrite (Inputs, Input);
24971 -- Generate a clause of the form:
24976 Make_Component_Association (Loc,
24977 Choices => New_Copy_List_Tree (Output),
24978 Expression => Input);
24980 -- The new clause contains replicated content that has
24981 -- already been analyzed, mark the clause as analyzed.
24983 Set_Analyzed (New_Clause);
24984 Insert_After (Clause, New_Clause);
24987 Input := Next_Input;
24990 end Normalize_Inputs;
24992 -----------------------
24993 -- Normalize_Outputs --
24994 -----------------------
24996 procedure Normalize_Outputs (Clause : Node_Id) is
24997 Inputs : constant Node_Id := Expression (Clause);
24998 Loc : constant Source_Ptr := Sloc (Clause);
24999 Outputs : constant Node_Id := First (Choices (Clause));
25000 Last_Output : Node_Id;
25001 New_Clause : Node_Id;
25002 Next_Output : Node_Id;
25006 -- Multiple outputs appear as an aggregate. Nothing to do when
25007 -- the clause has exactly one output.
25009 if Nkind (Outputs) = N_Aggregate then
25010 Last_Output := Last (Expressions (Outputs));
25012 -- Create a clause for each output. Note that each time a new
25013 -- clause is created, the original output list slowly shrinks
25014 -- until there is one item left.
25016 Output := First (Expressions (Outputs));
25017 while Present (Output) loop
25018 Next_Output := Next (Output);
25020 -- Unhook the output from the original output list as it
25021 -- will be relocated to a new clause.
25025 -- Special processing for the last output. At this point
25026 -- the original aggregate has been stripped down to one
25027 -- element. Replace the aggregate by the element itself.
25029 if Output = Last_Output then
25030 Rewrite (Outputs, Output);
25033 -- Generate a clause of the form:
25034 -- (Output => Inputs)
25037 Make_Component_Association (Loc,
25038 Choices => New_List (Output),
25039 Expression => New_Copy_Tree (Inputs));
25041 -- The new clause contains replicated content that has
25042 -- already been analyzed. There is not need to reanalyze
25045 Set_Analyzed (New_Clause);
25046 Insert_After (Clause, New_Clause);
25049 Output := Next_Output;
25052 end Normalize_Outputs;
25058 -- Start of processing for Normalize_Clauses
25061 Clause := First (Clauses);
25062 while Present (Clause) loop
25063 Normalize_Outputs (Clause);
25067 Clause := First (Clauses);
25068 while Present (Clause) loop
25069 Normalize_Inputs (Clause);
25072 end Normalize_Clauses;
25074 --------------------------
25075 -- Remove_Extra_Clauses --
25076 --------------------------
25078 procedure Remove_Extra_Clauses
25079 (Clauses : List_Id;
25080 Matched_Items : Elist_Id)
25084 Input_Id : Entity_Id;
25085 Next_Clause : Node_Id;
25087 State_Id : Entity_Id;
25090 Clause := First (Clauses);
25091 while Present (Clause) loop
25092 Next_Clause := Next (Clause);
25094 Input := Expression (Clause);
25095 Output := First (Choices (Clause));
25097 -- Recognize a clause of the form
25101 -- where Input is a constituent of a state which was already
25102 -- successfully matched. This clause must be removed because it
25103 -- simply indicates that some of the constituents of the state
25106 -- Refined_State => (State => (Constit_1, Constit_2))
25107 -- Depends => (Output => State)
25108 -- Refined_Depends => ((Output => Constit_1), -- State matched
25109 -- (null => Constit_2)) -- OK
25111 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
25113 -- Handle abstract views generated for limited with clauses
25115 Input_Id := Available_View (Entity_Of (Input));
25117 -- The input must be a constituent of a state
25119 if Ekind_In (Input_Id, E_Abstract_State,
25122 and then Present (Encapsulating_State (Input_Id))
25124 State_Id := Encapsulating_State (Input_Id);
25126 -- The state must have a non-null visible refinement and be
25127 -- matched in a previous clause.
25129 if Has_Non_Null_Visible_Refinement (State_Id)
25130 and then Contains (Matched_Items, State_Id)
25136 -- Recognize a clause of the form
25140 -- where Output is an arbitrary item. This clause must be removed
25141 -- because a null input legitimately matches anything.
25143 elsif Nkind (Input) = N_Null then
25147 Clause := Next_Clause;
25149 end Remove_Extra_Clauses;
25151 --------------------------
25152 -- Report_Extra_Clauses --
25153 --------------------------
25155 procedure Report_Extra_Clauses
25156 (Spec_Id : Entity_Id;
25162 -- Do not perform this check in an instance because it was already
25163 -- performed successfully in the generic template.
25165 if Is_Generic_Instance (Spec_Id) then
25168 elsif Present (Clauses) then
25169 Clause := First (Clauses);
25170 while Present (Clause) loop
25172 ("unmatched or extra clause in dependence refinement",
25178 end Report_Extra_Clauses;
25182 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25183 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25184 Errors : constant Nat := Serious_Errors_Detected;
25191 Body_Inputs : Elist_Id := No_Elist;
25192 Body_Outputs : Elist_Id := No_Elist;
25193 -- The inputs and outputs of the subprogram body synthesized from pragma
25194 -- Refined_Depends.
25196 Dependencies : List_Id := No_List;
25198 -- The corresponding Depends pragma along with its clauses
25200 Matched_Items : Elist_Id := No_Elist;
25201 -- A list containing the entities of all successfully matched items
25202 -- found in pragma Depends.
25204 Refinements : List_Id := No_List;
25205 -- The clauses of pragma Refined_Depends
25207 Spec_Id : Entity_Id;
25208 -- The entity of the subprogram subject to pragma Refined_Depends
25210 Spec_Inputs : Elist_Id := No_Elist;
25211 Spec_Outputs : Elist_Id := No_Elist;
25212 -- The inputs and outputs of the subprogram spec synthesized from pragma
25215 States : Elist_Id := No_Elist;
25216 -- A list containing the entities of all states whose constituents
25217 -- appear in pragma Depends.
25219 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25222 -- Do not analyze the pragma multiple times
25224 if Is_Analyzed_Pragma (N) then
25228 Spec_Id := Unique_Defining_Entity (Body_Decl);
25230 -- Use the anonymous object as the proper spec when Refined_Depends
25231 -- applies to the body of a single task type. The object carries the
25232 -- proper Chars as well as all non-refined versions of pragmas.
25234 if Is_Single_Concurrent_Type (Spec_Id) then
25235 Spec_Id := Anonymous_Object (Spec_Id);
25238 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
25240 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25241 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25243 if No (Depends) then
25245 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25246 & "& lacks aspect or pragma Depends"), N, Spec_Id);
25250 Deps := Expression (Get_Argument (Depends, Spec_Id));
25252 -- A null dependency relation renders the refinement useless because it
25253 -- cannot possibly mention abstract states with visible refinement. Note
25254 -- that the inverse is not true as states may be refined to null
25255 -- (SPARK RM 7.2.5(2)).
25257 if Nkind (Deps) = N_Null then
25259 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25260 & "depend on abstract state with visible refinement"), N, Spec_Id);
25264 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25265 -- This ensures that the categorization of all refined dependency items
25266 -- is consistent with their role.
25268 Analyze_Depends_In_Decl_Part (N);
25270 -- Do not match dependencies against refinements if Refined_Depends is
25271 -- illegal to avoid emitting misleading error.
25273 if Serious_Errors_Detected = Errors then
25275 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25276 -- the inputs and outputs of the subprogram spec and body to verify
25277 -- the use of states with visible refinement and their constituents.
25279 if No (Get_Pragma (Spec_Id, Pragma_Global))
25280 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
25282 Collect_Subprogram_Inputs_Outputs
25283 (Subp_Id => Spec_Id,
25284 Synthesize => True,
25285 Subp_Inputs => Spec_Inputs,
25286 Subp_Outputs => Spec_Outputs,
25287 Global_Seen => Dummy);
25289 Collect_Subprogram_Inputs_Outputs
25290 (Subp_Id => Body_Id,
25291 Synthesize => True,
25292 Subp_Inputs => Body_Inputs,
25293 Subp_Outputs => Body_Outputs,
25294 Global_Seen => Dummy);
25296 -- For an output state with a visible refinement, ensure that all
25297 -- constituents appear as outputs in the dependency refinement.
25299 Check_Output_States
25300 (Spec_Id => Spec_Id,
25301 Spec_Inputs => Spec_Inputs,
25302 Spec_Outputs => Spec_Outputs,
25303 Body_Inputs => Body_Inputs,
25304 Body_Outputs => Body_Outputs);
25307 -- Matching is disabled in ASIS because clauses are not normalized as
25308 -- this is a tree altering activity similar to expansion.
25314 -- Multiple dependency clauses appear as component associations of an
25315 -- aggregate. Note that the clauses are copied because the algorithm
25316 -- modifies them and this should not be visible in Depends.
25318 pragma Assert (Nkind (Deps) = N_Aggregate);
25319 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
25320 Normalize_Clauses (Dependencies);
25322 -- Gather all states which appear in Depends
25324 States := Collect_States (Dependencies);
25326 Refs := Expression (Get_Argument (N, Spec_Id));
25328 if Nkind (Refs) = N_Null then
25329 Refinements := No_List;
25331 -- Multiple dependency clauses appear as component associations of an
25332 -- aggregate. Note that the clauses are copied because the algorithm
25333 -- modifies them and this should not be visible in Refined_Depends.
25335 else pragma Assert (Nkind (Refs) = N_Aggregate);
25336 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
25337 Normalize_Clauses (Refinements);
25340 -- At this point the clauses of pragmas Depends and Refined_Depends
25341 -- have been normalized into simple dependencies between one output
25342 -- and one input. Examine all clauses of pragma Depends looking for
25343 -- matching clauses in pragma Refined_Depends.
25345 Clause := First (Dependencies);
25346 while Present (Clause) loop
25347 Check_Dependency_Clause
25348 (Spec_Id => Spec_Id,
25349 Dep_Clause => Clause,
25350 Dep_States => States,
25351 Refinements => Refinements,
25352 Matched_Items => Matched_Items);
25357 -- Pragma Refined_Depends may contain multiple clarification clauses
25358 -- which indicate that certain constituents do not influence the data
25359 -- flow in any way. Such clauses must be removed as long as the state
25360 -- has been matched, otherwise they will be incorrectly flagged as
25363 -- Refined_State => (State => (Constit_1, Constit_2))
25364 -- Depends => (Output => State)
25365 -- Refined_Depends => ((Output => Constit_1), -- State matched
25366 -- (null => Constit_2)) -- must be removed
25368 Remove_Extra_Clauses (Refinements, Matched_Items);
25370 if Serious_Errors_Detected = Errors then
25371 Report_Extra_Clauses (Spec_Id, Refinements);
25376 Set_Is_Analyzed_Pragma (N);
25377 end Analyze_Refined_Depends_In_Decl_Part;
25379 -----------------------------------------
25380 -- Analyze_Refined_Global_In_Decl_Part --
25381 -----------------------------------------
25383 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
25385 -- The corresponding Global pragma
25387 Has_In_State : Boolean := False;
25388 Has_In_Out_State : Boolean := False;
25389 Has_Out_State : Boolean := False;
25390 Has_Proof_In_State : Boolean := False;
25391 -- These flags are set when the corresponding Global pragma has a state
25392 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25395 Has_Null_State : Boolean := False;
25396 -- This flag is set when the corresponding Global pragma has at least
25397 -- one state with a null refinement.
25399 In_Constits : Elist_Id := No_Elist;
25400 In_Out_Constits : Elist_Id := No_Elist;
25401 Out_Constits : Elist_Id := No_Elist;
25402 Proof_In_Constits : Elist_Id := No_Elist;
25403 -- These lists contain the entities of all Input, In_Out, Output and
25404 -- Proof_In constituents that appear in Refined_Global and participate
25405 -- in state refinement.
25407 In_Items : Elist_Id := No_Elist;
25408 In_Out_Items : Elist_Id := No_Elist;
25409 Out_Items : Elist_Id := No_Elist;
25410 Proof_In_Items : Elist_Id := No_Elist;
25411 -- These lists contain the entities of all Input, In_Out, Output and
25412 -- Proof_In items defined in the corresponding Global pragma.
25414 Repeat_Items : Elist_Id := No_Elist;
25415 -- A list of all global items without full visible refinement found
25416 -- in pragma Global. These states should be repeated in the global
25417 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25418 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25420 Spec_Id : Entity_Id;
25421 -- The entity of the subprogram subject to pragma Refined_Global
25423 States : Elist_Id := No_Elist;
25424 -- A list of all states with full or partial visible refinement found in
25427 procedure Check_In_Out_States;
25428 -- Determine whether the corresponding Global pragma mentions In_Out
25429 -- states with visible refinement and if so, ensure that one of the
25430 -- following completions apply to the constituents of the state:
25431 -- 1) there is at least one constituent of mode In_Out
25432 -- 2) there is at least one Input and one Output constituent
25433 -- 3) not all constituents are present and one of them is of mode
25435 -- This routine may remove elements from In_Constits, In_Out_Constits,
25436 -- Out_Constits and Proof_In_Constits.
25438 procedure Check_Input_States;
25439 -- Determine whether the corresponding Global pragma mentions Input
25440 -- states with visible refinement and if so, ensure that at least one of
25441 -- its constituents appears as an Input item in Refined_Global.
25442 -- This routine may remove elements from In_Constits, In_Out_Constits,
25443 -- Out_Constits and Proof_In_Constits.
25445 procedure Check_Output_States;
25446 -- Determine whether the corresponding Global pragma mentions Output
25447 -- states with visible refinement and if so, ensure that all of its
25448 -- constituents appear as Output items in Refined_Global.
25449 -- This routine may remove elements from In_Constits, In_Out_Constits,
25450 -- Out_Constits and Proof_In_Constits.
25452 procedure Check_Proof_In_States;
25453 -- Determine whether the corresponding Global pragma mentions Proof_In
25454 -- states with visible refinement and if so, ensure that at least one of
25455 -- its constituents appears as a Proof_In item in Refined_Global.
25456 -- This routine may remove elements from In_Constits, In_Out_Constits,
25457 -- Out_Constits and Proof_In_Constits.
25459 procedure Check_Refined_Global_List
25461 Global_Mode : Name_Id := Name_Input);
25462 -- Verify the legality of a single global list declaration. Global_Mode
25463 -- denotes the current mode in effect.
25465 procedure Collect_Global_Items
25467 Mode : Name_Id := Name_Input);
25468 -- Gather all Input, In_Out, Output and Proof_In items from node List
25469 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25470 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25471 -- and Has_Proof_In_State are set when there is at least one abstract
25472 -- state with full or partial visible refinement available in the
25473 -- corresponding mode. Flag Has_Null_State is set when at least state
25474 -- has a null refinement. Mode denotes the current global mode in
25477 function Present_Then_Remove
25479 Item : Entity_Id) return Boolean;
25480 -- Search List for a particular entity Item. If Item has been found,
25481 -- remove it from List. This routine is used to strip lists In_Constits,
25482 -- In_Out_Constits and Out_Constits of valid constituents.
25484 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
25485 -- Same as function Present_Then_Remove, but do not report the presence
25486 -- of Item in List.
25488 procedure Report_Extra_Constituents;
25489 -- Emit an error for each constituent found in lists In_Constits,
25490 -- In_Out_Constits and Out_Constits.
25492 procedure Report_Missing_Items;
25493 -- Emit an error for each global item not repeated found in list
25496 -------------------------
25497 -- Check_In_Out_States --
25498 -------------------------
25500 procedure Check_In_Out_States is
25501 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25502 -- Determine whether one of the following coverage scenarios is in
25504 -- 1) there is at least one constituent of mode In_Out or Output
25505 -- 2) there is at least one pair of constituents with modes Input
25506 -- and Output, or Proof_In and Output.
25507 -- 3) there is at least one constituent of mode Output and not all
25508 -- constituents are present.
25509 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25511 -----------------------------
25512 -- Check_Constituent_Usage --
25513 -----------------------------
25515 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25516 Constits : constant Elist_Id :=
25517 Partial_Refinement_Constituents (State_Id);
25518 Constit_Elmt : Elmt_Id;
25519 Constit_Id : Entity_Id;
25520 Has_Missing : Boolean := False;
25521 In_Out_Seen : Boolean := False;
25522 Input_Seen : Boolean := False;
25523 Output_Seen : Boolean := False;
25524 Proof_In_Seen : Boolean := False;
25527 -- Process all the constituents of the state and note their modes
25528 -- within the global refinement.
25530 if Present (Constits) then
25531 Constit_Elmt := First_Elmt (Constits);
25532 while Present (Constit_Elmt) loop
25533 Constit_Id := Node (Constit_Elmt);
25535 if Present_Then_Remove (In_Constits, Constit_Id) then
25536 Input_Seen := True;
25538 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
25539 In_Out_Seen := True;
25541 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25542 Output_Seen := True;
25544 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25546 Proof_In_Seen := True;
25549 Has_Missing := True;
25552 Next_Elmt (Constit_Elmt);
25556 -- An In_Out constituent is a valid completion
25558 if In_Out_Seen then
25561 -- A pair of one Input/Proof_In and one Output constituent is a
25562 -- valid completion.
25564 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
25567 elsif Output_Seen then
25569 -- A single Output constituent is a valid completion only when
25570 -- some of the other constituents are missing.
25572 if Has_Missing then
25575 -- Otherwise all constituents are of mode Output
25579 ("global refinement of state & must include at least one "
25580 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25584 -- The state lacks a completion. When full refinement is visible,
25585 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25586 -- refinement is visible, emit an error if the abstract state
25587 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25588 -- both are utilized, Check_State_And_Constituent_Use. will issue
25591 elsif not Input_Seen
25592 and then not In_Out_Seen
25593 and then not Output_Seen
25594 and then not Proof_In_Seen
25596 if Has_Visible_Refinement (State_Id)
25597 or else Contains (Repeat_Items, State_Id)
25600 ("missing global refinement of state &", N, State_Id);
25603 -- Otherwise the state has a malformed completion where at least
25604 -- one of the constituents has a different mode.
25608 ("global refinement of state & redefines the mode of its "
25609 & "constituents", N, State_Id);
25611 end Check_Constituent_Usage;
25615 Item_Elmt : Elmt_Id;
25616 Item_Id : Entity_Id;
25618 -- Start of processing for Check_In_Out_States
25621 -- Do not perform this check in an instance because it was already
25622 -- performed successfully in the generic template.
25624 if Is_Generic_Instance (Spec_Id) then
25627 -- Inspect the In_Out items of the corresponding Global pragma
25628 -- looking for a state with a visible refinement.
25630 elsif Has_In_Out_State and then Present (In_Out_Items) then
25631 Item_Elmt := First_Elmt (In_Out_Items);
25632 while Present (Item_Elmt) loop
25633 Item_Id := Node (Item_Elmt);
25635 -- Ensure that one of the three coverage variants is satisfied
25637 if Ekind (Item_Id) = E_Abstract_State
25638 and then Has_Non_Null_Visible_Refinement (Item_Id)
25640 Check_Constituent_Usage (Item_Id);
25643 Next_Elmt (Item_Elmt);
25646 end Check_In_Out_States;
25648 ------------------------
25649 -- Check_Input_States --
25650 ------------------------
25652 procedure Check_Input_States is
25653 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25654 -- Determine whether at least one constituent of state State_Id with
25655 -- full or partial visible refinement is used and has mode Input.
25656 -- Ensure that the remaining constituents do not have In_Out or
25657 -- Output modes. Emit an error if this is not the case
25658 -- (SPARK RM 7.2.4(5)).
25660 -----------------------------
25661 -- Check_Constituent_Usage --
25662 -----------------------------
25664 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25665 Constits : constant Elist_Id :=
25666 Partial_Refinement_Constituents (State_Id);
25667 Constit_Elmt : Elmt_Id;
25668 Constit_Id : Entity_Id;
25669 In_Seen : Boolean := False;
25672 if Present (Constits) then
25673 Constit_Elmt := First_Elmt (Constits);
25674 while Present (Constit_Elmt) loop
25675 Constit_Id := Node (Constit_Elmt);
25677 -- At least one of the constituents appears as an Input
25679 if Present_Then_Remove (In_Constits, Constit_Id) then
25682 -- A Proof_In constituent can refine an Input state as long
25683 -- as there is at least one Input constituent present.
25685 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25689 -- The constituent appears in the global refinement, but has
25690 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25692 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
25693 or else Present_Then_Remove (Out_Constits, Constit_Id)
25695 Error_Msg_Name_1 := Chars (State_Id);
25697 ("constituent & of state % must have mode `Input` in "
25698 & "global refinement", N, Constit_Id);
25701 Next_Elmt (Constit_Elmt);
25705 -- Not one of the constituents appeared as Input. Always emit an
25706 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25707 -- When only partial refinement is visible, emit an error if the
25708 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25709 -- the case where both are utilized, an error will be issued in
25710 -- Check_State_And_Constituent_Use.
25713 and then (Has_Visible_Refinement (State_Id)
25714 or else Contains (Repeat_Items, State_Id))
25717 ("global refinement of state & must include at least one "
25718 & "constituent of mode `Input`", N, State_Id);
25720 end Check_Constituent_Usage;
25724 Item_Elmt : Elmt_Id;
25725 Item_Id : Entity_Id;
25727 -- Start of processing for Check_Input_States
25730 -- Do not perform this check in an instance because it was already
25731 -- performed successfully in the generic template.
25733 if Is_Generic_Instance (Spec_Id) then
25736 -- Inspect the Input items of the corresponding Global pragma looking
25737 -- for a state with a visible refinement.
25739 elsif Has_In_State and then Present (In_Items) then
25740 Item_Elmt := First_Elmt (In_Items);
25741 while Present (Item_Elmt) loop
25742 Item_Id := Node (Item_Elmt);
25744 -- When full refinement is visible, ensure that at least one of
25745 -- the constituents is utilized and is of mode Input. When only
25746 -- partial refinement is visible, ensure that either one of
25747 -- the constituents is utilized and is of mode Input, or the
25748 -- abstract state is repeated and no constituent is utilized.
25750 if Ekind (Item_Id) = E_Abstract_State
25751 and then Has_Non_Null_Visible_Refinement (Item_Id)
25753 Check_Constituent_Usage (Item_Id);
25756 Next_Elmt (Item_Elmt);
25759 end Check_Input_States;
25761 -------------------------
25762 -- Check_Output_States --
25763 -------------------------
25765 procedure Check_Output_States is
25766 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25767 -- Determine whether all constituents of state State_Id with full
25768 -- visible refinement are used and have mode Output. Emit an error
25769 -- if this is not the case (SPARK RM 7.2.4(5)).
25771 -----------------------------
25772 -- Check_Constituent_Usage --
25773 -----------------------------
25775 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25776 Constits : constant Elist_Id :=
25777 Partial_Refinement_Constituents (State_Id);
25778 Only_Partial : constant Boolean :=
25779 not Has_Visible_Refinement (State_Id);
25780 Constit_Elmt : Elmt_Id;
25781 Constit_Id : Entity_Id;
25782 Posted : Boolean := False;
25785 if Present (Constits) then
25786 Constit_Elmt := First_Elmt (Constits);
25787 while Present (Constit_Elmt) loop
25788 Constit_Id := Node (Constit_Elmt);
25790 -- Issue an error when a constituent of State_Id is utilized
25791 -- and State_Id has only partial visible refinement
25792 -- (SPARK RM 7.2.4(3d)).
25794 if Only_Partial then
25795 if Present_Then_Remove (Out_Constits, Constit_Id)
25796 or else Present_Then_Remove (In_Constits, Constit_Id)
25798 Present_Then_Remove (In_Out_Constits, Constit_Id)
25800 Present_Then_Remove (Proof_In_Constits, Constit_Id)
25802 Error_Msg_Name_1 := Chars (State_Id);
25804 ("constituent & of state % cannot be used in global "
25805 & "refinement", N, Constit_Id);
25806 Error_Msg_Name_1 := Chars (State_Id);
25807 SPARK_Msg_N ("\use state % instead", N);
25810 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25813 -- The constituent appears in the global refinement, but has
25814 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25816 elsif Present_Then_Remove (In_Constits, Constit_Id)
25817 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25818 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
25820 Error_Msg_Name_1 := Chars (State_Id);
25822 ("constituent & of state % must have mode `Output` in "
25823 & "global refinement", N, Constit_Id);
25825 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25831 ("`Output` state & must be replaced by all its "
25832 & "constituents in global refinement", N, State_Id);
25836 ("\constituent & is missing in output list",
25840 Next_Elmt (Constit_Elmt);
25843 end Check_Constituent_Usage;
25847 Item_Elmt : Elmt_Id;
25848 Item_Id : Entity_Id;
25850 -- Start of processing for Check_Output_States
25853 -- Do not perform this check in an instance because it was already
25854 -- performed successfully in the generic template.
25856 if Is_Generic_Instance (Spec_Id) then
25859 -- Inspect the Output items of the corresponding Global pragma
25860 -- looking for a state with a visible refinement.
25862 elsif Has_Out_State and then Present (Out_Items) then
25863 Item_Elmt := First_Elmt (Out_Items);
25864 while Present (Item_Elmt) loop
25865 Item_Id := Node (Item_Elmt);
25867 -- When full refinement is visible, ensure that all of the
25868 -- constituents are utilized and they have mode Output. When
25869 -- only partial refinement is visible, ensure that no
25870 -- constituent is utilized.
25872 if Ekind (Item_Id) = E_Abstract_State
25873 and then Has_Non_Null_Visible_Refinement (Item_Id)
25875 Check_Constituent_Usage (Item_Id);
25878 Next_Elmt (Item_Elmt);
25881 end Check_Output_States;
25883 ---------------------------
25884 -- Check_Proof_In_States --
25885 ---------------------------
25887 procedure Check_Proof_In_States is
25888 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25889 -- Determine whether at least one constituent of state State_Id with
25890 -- full or partial visible refinement is used and has mode Proof_In.
25891 -- Ensure that the remaining constituents do not have Input, In_Out,
25892 -- or Output modes. Emit an error if this is not the case
25893 -- (SPARK RM 7.2.4(5)).
25895 -----------------------------
25896 -- Check_Constituent_Usage --
25897 -----------------------------
25899 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25900 Constits : constant Elist_Id :=
25901 Partial_Refinement_Constituents (State_Id);
25902 Constit_Elmt : Elmt_Id;
25903 Constit_Id : Entity_Id;
25904 Proof_In_Seen : Boolean := False;
25907 if Present (Constits) then
25908 Constit_Elmt := First_Elmt (Constits);
25909 while Present (Constit_Elmt) loop
25910 Constit_Id := Node (Constit_Elmt);
25912 -- At least one of the constituents appears as Proof_In
25914 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
25915 Proof_In_Seen := True;
25917 -- The constituent appears in the global refinement, but has
25918 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25920 elsif Present_Then_Remove (In_Constits, Constit_Id)
25921 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25922 or else Present_Then_Remove (Out_Constits, Constit_Id)
25924 Error_Msg_Name_1 := Chars (State_Id);
25926 ("constituent & of state % must have mode `Proof_In` "
25927 & "in global refinement", N, Constit_Id);
25930 Next_Elmt (Constit_Elmt);
25934 -- Not one of the constituents appeared as Proof_In. Always emit
25935 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25936 -- When only partial refinement is visible, emit an error if the
25937 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25938 -- the case where both are utilized, an error will be issued by
25939 -- Check_State_And_Constituent_Use.
25941 if not Proof_In_Seen
25942 and then (Has_Visible_Refinement (State_Id)
25943 or else Contains (Repeat_Items, State_Id))
25946 ("global refinement of state & must include at least one "
25947 & "constituent of mode `Proof_In`", N, State_Id);
25949 end Check_Constituent_Usage;
25953 Item_Elmt : Elmt_Id;
25954 Item_Id : Entity_Id;
25956 -- Start of processing for Check_Proof_In_States
25959 -- Do not perform this check in an instance because it was already
25960 -- performed successfully in the generic template.
25962 if Is_Generic_Instance (Spec_Id) then
25965 -- Inspect the Proof_In items of the corresponding Global pragma
25966 -- looking for a state with a visible refinement.
25968 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25969 Item_Elmt := First_Elmt (Proof_In_Items);
25970 while Present (Item_Elmt) loop
25971 Item_Id := Node (Item_Elmt);
25973 -- Ensure that at least one of the constituents is utilized
25974 -- and is of mode Proof_In. When only partial refinement is
25975 -- visible, ensure that either one of the constituents is
25976 -- utilized and is of mode Proof_In, or the abstract state
25977 -- is repeated and no constituent is utilized.
25979 if Ekind (Item_Id) = E_Abstract_State
25980 and then Has_Non_Null_Visible_Refinement (Item_Id)
25982 Check_Constituent_Usage (Item_Id);
25985 Next_Elmt (Item_Elmt);
25988 end Check_Proof_In_States;
25990 -------------------------------
25991 -- Check_Refined_Global_List --
25992 -------------------------------
25994 procedure Check_Refined_Global_List
25996 Global_Mode : Name_Id := Name_Input)
25998 procedure Check_Refined_Global_Item
26000 Global_Mode : Name_Id);
26001 -- Verify the legality of a single global item declaration. Parameter
26002 -- Global_Mode denotes the current mode in effect.
26004 -------------------------------
26005 -- Check_Refined_Global_Item --
26006 -------------------------------
26008 procedure Check_Refined_Global_Item
26010 Global_Mode : Name_Id)
26012 Item_Id : constant Entity_Id := Entity_Of (Item);
26014 procedure Inconsistent_Mode_Error (Expect : Name_Id);
26015 -- Issue a common error message for all mode mismatches. Expect
26016 -- denotes the expected mode.
26018 -----------------------------
26019 -- Inconsistent_Mode_Error --
26020 -----------------------------
26022 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
26025 ("global item & has inconsistent modes", Item, Item_Id);
26027 Error_Msg_Name_1 := Global_Mode;
26028 Error_Msg_Name_2 := Expect;
26029 SPARK_Msg_N ("\expected mode %, found mode %", Item);
26030 end Inconsistent_Mode_Error;
26034 Enc_State : Entity_Id := Empty;
26035 -- Encapsulating state for constituent, Empty otherwise
26037 -- Start of processing for Check_Refined_Global_Item
26040 if Ekind_In (Item_Id, E_Abstract_State,
26044 Enc_State := Find_Encapsulating_State (States, Item_Id);
26047 -- When the state or object acts as a constituent of another
26048 -- state with a visible refinement, collect it for the state
26049 -- completeness checks performed later on. Note that the item
26050 -- acts as a constituent only when the encapsulating state is
26051 -- present in pragma Global.
26053 if Present (Enc_State)
26054 and then (Has_Visible_Refinement (Enc_State)
26055 or else Has_Partial_Visible_Refinement (Enc_State))
26056 and then Contains (States, Enc_State)
26058 -- If the state has only partial visible refinement, remove it
26059 -- from the list of items that should be repeated from pragma
26062 if not Has_Visible_Refinement (Enc_State) then
26063 Present_Then_Remove (Repeat_Items, Enc_State);
26066 if Global_Mode = Name_Input then
26067 Append_New_Elmt (Item_Id, In_Constits);
26069 elsif Global_Mode = Name_In_Out then
26070 Append_New_Elmt (Item_Id, In_Out_Constits);
26072 elsif Global_Mode = Name_Output then
26073 Append_New_Elmt (Item_Id, Out_Constits);
26075 elsif Global_Mode = Name_Proof_In then
26076 Append_New_Elmt (Item_Id, Proof_In_Constits);
26079 -- When not a constituent, ensure that both occurrences of the
26080 -- item in pragmas Global and Refined_Global match. Also remove
26081 -- it when present from the list of items that should be repeated
26082 -- from pragma Global.
26085 Present_Then_Remove (Repeat_Items, Item_Id);
26087 if Contains (In_Items, Item_Id) then
26088 if Global_Mode /= Name_Input then
26089 Inconsistent_Mode_Error (Name_Input);
26092 elsif Contains (In_Out_Items, Item_Id) then
26093 if Global_Mode /= Name_In_Out then
26094 Inconsistent_Mode_Error (Name_In_Out);
26097 elsif Contains (Out_Items, Item_Id) then
26098 if Global_Mode /= Name_Output then
26099 Inconsistent_Mode_Error (Name_Output);
26102 elsif Contains (Proof_In_Items, Item_Id) then
26105 -- The item does not appear in the corresponding Global pragma,
26106 -- it must be an extra (SPARK RM 7.2.4(3)).
26109 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
26112 end Check_Refined_Global_Item;
26118 -- Start of processing for Check_Refined_Global_List
26121 -- Do not perform this check in an instance because it was already
26122 -- performed successfully in the generic template.
26124 if Is_Generic_Instance (Spec_Id) then
26127 elsif Nkind (List) = N_Null then
26130 -- Single global item declaration
26132 elsif Nkind_In (List, N_Expanded_Name,
26134 N_Selected_Component)
26136 Check_Refined_Global_Item (List, Global_Mode);
26138 -- Simple global list or moded global list declaration
26140 elsif Nkind (List) = N_Aggregate then
26142 -- The declaration of a simple global list appear as a collection
26145 if Present (Expressions (List)) then
26146 Item := First (Expressions (List));
26147 while Present (Item) loop
26148 Check_Refined_Global_Item (Item, Global_Mode);
26152 -- The declaration of a moded global list appears as a collection
26153 -- of component associations where individual choices denote
26156 elsif Present (Component_Associations (List)) then
26157 Item := First (Component_Associations (List));
26158 while Present (Item) loop
26159 Check_Refined_Global_List
26160 (List => Expression (Item),
26161 Global_Mode => Chars (First (Choices (Item))));
26169 raise Program_Error;
26175 raise Program_Error;
26177 end Check_Refined_Global_List;
26179 --------------------------
26180 -- Collect_Global_Items --
26181 --------------------------
26183 procedure Collect_Global_Items
26185 Mode : Name_Id := Name_Input)
26187 procedure Collect_Global_Item
26189 Item_Mode : Name_Id);
26190 -- Add a single item to the appropriate list. Item_Mode denotes the
26191 -- current mode in effect.
26193 -------------------------
26194 -- Collect_Global_Item --
26195 -------------------------
26197 procedure Collect_Global_Item
26199 Item_Mode : Name_Id)
26201 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
26202 -- The above handles abstract views of variables and states built
26203 -- for limited with clauses.
26206 -- Signal that the global list contains at least one abstract
26207 -- state with a visible refinement. Note that the refinement may
26208 -- be null in which case there are no constituents.
26210 if Ekind (Item_Id) = E_Abstract_State then
26211 if Has_Null_Visible_Refinement (Item_Id) then
26212 Has_Null_State := True;
26214 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26215 Append_New_Elmt (Item_Id, States);
26217 if Item_Mode = Name_Input then
26218 Has_In_State := True;
26219 elsif Item_Mode = Name_In_Out then
26220 Has_In_Out_State := True;
26221 elsif Item_Mode = Name_Output then
26222 Has_Out_State := True;
26223 elsif Item_Mode = Name_Proof_In then
26224 Has_Proof_In_State := True;
26229 -- Record global items without full visible refinement found in
26230 -- pragma Global which should be repeated in the global refinement
26231 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26233 if Ekind (Item_Id) /= E_Abstract_State
26234 or else not Has_Visible_Refinement (Item_Id)
26236 Append_New_Elmt (Item_Id, Repeat_Items);
26239 -- Add the item to the proper list
26241 if Item_Mode = Name_Input then
26242 Append_New_Elmt (Item_Id, In_Items);
26243 elsif Item_Mode = Name_In_Out then
26244 Append_New_Elmt (Item_Id, In_Out_Items);
26245 elsif Item_Mode = Name_Output then
26246 Append_New_Elmt (Item_Id, Out_Items);
26247 elsif Item_Mode = Name_Proof_In then
26248 Append_New_Elmt (Item_Id, Proof_In_Items);
26250 end Collect_Global_Item;
26256 -- Start of processing for Collect_Global_Items
26259 if Nkind (List) = N_Null then
26262 -- Single global item declaration
26264 elsif Nkind_In (List, N_Expanded_Name,
26266 N_Selected_Component)
26268 Collect_Global_Item (List, Mode);
26270 -- Single global list or moded global list declaration
26272 elsif Nkind (List) = N_Aggregate then
26274 -- The declaration of a simple global list appear as a collection
26277 if Present (Expressions (List)) then
26278 Item := First (Expressions (List));
26279 while Present (Item) loop
26280 Collect_Global_Item (Item, Mode);
26284 -- The declaration of a moded global list appears as a collection
26285 -- of component associations where individual choices denote mode.
26287 elsif Present (Component_Associations (List)) then
26288 Item := First (Component_Associations (List));
26289 while Present (Item) loop
26290 Collect_Global_Items
26291 (List => Expression (Item),
26292 Mode => Chars (First (Choices (Item))));
26300 raise Program_Error;
26303 -- To accommodate partial decoration of disabled SPARK features, this
26304 -- routine may be called with illegal input. If this is the case, do
26305 -- not raise Program_Error.
26310 end Collect_Global_Items;
26312 -------------------------
26313 -- Present_Then_Remove --
26314 -------------------------
26316 function Present_Then_Remove
26318 Item : Entity_Id) return Boolean
26323 if Present (List) then
26324 Elmt := First_Elmt (List);
26325 while Present (Elmt) loop
26326 if Node (Elmt) = Item then
26327 Remove_Elmt (List, Elmt);
26336 end Present_Then_Remove;
26338 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
26341 Ignore := Present_Then_Remove (List, Item);
26342 end Present_Then_Remove;
26344 -------------------------------
26345 -- Report_Extra_Constituents --
26346 -------------------------------
26348 procedure Report_Extra_Constituents is
26349 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
26350 -- Emit an error for every element of List
26352 ---------------------------------------
26353 -- Report_Extra_Constituents_In_List --
26354 ---------------------------------------
26356 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
26357 Constit_Elmt : Elmt_Id;
26360 if Present (List) then
26361 Constit_Elmt := First_Elmt (List);
26362 while Present (Constit_Elmt) loop
26363 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
26364 Next_Elmt (Constit_Elmt);
26367 end Report_Extra_Constituents_In_List;
26369 -- Start of processing for Report_Extra_Constituents
26372 -- Do not perform this check in an instance because it was already
26373 -- performed successfully in the generic template.
26375 if Is_Generic_Instance (Spec_Id) then
26379 Report_Extra_Constituents_In_List (In_Constits);
26380 Report_Extra_Constituents_In_List (In_Out_Constits);
26381 Report_Extra_Constituents_In_List (Out_Constits);
26382 Report_Extra_Constituents_In_List (Proof_In_Constits);
26384 end Report_Extra_Constituents;
26386 --------------------------
26387 -- Report_Missing_Items --
26388 --------------------------
26390 procedure Report_Missing_Items is
26391 Item_Elmt : Elmt_Id;
26392 Item_Id : Entity_Id;
26395 -- Do not perform this check in an instance because it was already
26396 -- performed successfully in the generic template.
26398 if Is_Generic_Instance (Spec_Id) then
26402 if Present (Repeat_Items) then
26403 Item_Elmt := First_Elmt (Repeat_Items);
26404 while Present (Item_Elmt) loop
26405 Item_Id := Node (Item_Elmt);
26406 SPARK_Msg_NE ("missing global item &", N, Item_Id);
26407 Next_Elmt (Item_Elmt);
26411 end Report_Missing_Items;
26415 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26416 Errors : constant Nat := Serious_Errors_Detected;
26418 No_Constit : Boolean;
26420 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26423 -- Do not analyze the pragma multiple times
26425 if Is_Analyzed_Pragma (N) then
26429 Spec_Id := Unique_Defining_Entity (Body_Decl);
26431 -- Use the anonymous object as the proper spec when Refined_Global
26432 -- applies to the body of a single task type. The object carries the
26433 -- proper Chars as well as all non-refined versions of pragmas.
26435 if Is_Single_Concurrent_Type (Spec_Id) then
26436 Spec_Id := Anonymous_Object (Spec_Id);
26439 Global := Get_Pragma (Spec_Id, Pragma_Global);
26440 Items := Expression (Get_Argument (N, Spec_Id));
26442 -- The subprogram declaration lacks pragma Global. This renders
26443 -- Refined_Global useless as there is nothing to refine.
26445 if No (Global) then
26447 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26448 & "& lacks aspect or pragma Global"), N, Spec_Id);
26452 -- Extract all relevant items from the corresponding Global pragma
26454 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
26456 -- Package and subprogram bodies are instantiated individually in
26457 -- a separate compiler pass. Due to this mode of instantiation, the
26458 -- refinement of a state may no longer be visible when a subprogram
26459 -- body contract is instantiated. Since the generic template is legal,
26460 -- do not perform this check in the instance to circumvent this oddity.
26462 if Is_Generic_Instance (Spec_Id) then
26465 -- Non-instance case
26468 -- The corresponding Global pragma must mention at least one
26469 -- state with a visible refinement at the point Refined_Global
26470 -- is processed. States with null refinements need Refined_Global
26471 -- pragma (SPARK RM 7.2.4(2)).
26473 if not Has_In_State
26474 and then not Has_In_Out_State
26475 and then not Has_Out_State
26476 and then not Has_Proof_In_State
26477 and then not Has_Null_State
26480 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26481 & "depend on abstract state with visible refinement"),
26485 -- The global refinement of inputs and outputs cannot be null when
26486 -- the corresponding Global pragma contains at least one item except
26487 -- in the case where we have states with null refinements.
26489 elsif Nkind (Items) = N_Null
26491 (Present (In_Items)
26492 or else Present (In_Out_Items)
26493 or else Present (Out_Items)
26494 or else Present (Proof_In_Items))
26495 and then not Has_Null_State
26498 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
26499 & "global items"), N, Spec_Id);
26504 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26505 -- This ensures that the categorization of all refined global items is
26506 -- consistent with their role.
26508 Analyze_Global_In_Decl_Part (N);
26510 -- Perform all refinement checks with respect to completeness and mode
26513 if Serious_Errors_Detected = Errors then
26514 Check_Refined_Global_List (Items);
26517 -- Store the information that no constituent is used in the global
26518 -- refinement, prior to calling checking procedures which remove items
26519 -- from the list of constituents.
26523 and then No (In_Out_Constits)
26524 and then No (Out_Constits)
26525 and then No (Proof_In_Constits);
26527 -- For Input states with visible refinement, at least one constituent
26528 -- must be used as an Input in the global refinement.
26530 if Serious_Errors_Detected = Errors then
26531 Check_Input_States;
26534 -- Verify all possible completion variants for In_Out states with
26535 -- visible refinement.
26537 if Serious_Errors_Detected = Errors then
26538 Check_In_Out_States;
26541 -- For Output states with visible refinement, all constituents must be
26542 -- used as Outputs in the global refinement.
26544 if Serious_Errors_Detected = Errors then
26545 Check_Output_States;
26548 -- For Proof_In states with visible refinement, at least one constituent
26549 -- must be used as Proof_In in the global refinement.
26551 if Serious_Errors_Detected = Errors then
26552 Check_Proof_In_States;
26555 -- Emit errors for all constituents that belong to other states with
26556 -- visible refinement that do not appear in Global.
26558 if Serious_Errors_Detected = Errors then
26559 Report_Extra_Constituents;
26562 -- Emit errors for all items in Global that are not repeated in the
26563 -- global refinement and for which there is no full visible refinement
26564 -- and, in the case of states with partial visible refinement, no
26565 -- constituent is mentioned in the global refinement.
26567 if Serious_Errors_Detected = Errors then
26568 Report_Missing_Items;
26571 -- Emit an error if no constituent is used in the global refinement
26572 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26573 -- one may be issued by the checking procedures. Do not perform this
26574 -- check in an instance because it was already performed successfully
26575 -- in the generic template.
26577 if Serious_Errors_Detected = Errors
26578 and then not Is_Generic_Instance (Spec_Id)
26579 and then not Has_Null_State
26580 and then No_Constit
26582 SPARK_Msg_N ("missing refinement", N);
26586 Set_Is_Analyzed_Pragma (N);
26587 end Analyze_Refined_Global_In_Decl_Part;
26589 ----------------------------------------
26590 -- Analyze_Refined_State_In_Decl_Part --
26591 ----------------------------------------
26593 procedure Analyze_Refined_State_In_Decl_Part
26595 Freeze_Id : Entity_Id := Empty)
26597 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
26598 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26599 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
26601 Available_States : Elist_Id := No_Elist;
26602 -- A list of all abstract states defined in the package declaration that
26603 -- are available for refinement. The list is used to report unrefined
26606 Body_States : Elist_Id := No_Elist;
26607 -- A list of all hidden states that appear in the body of the related
26608 -- package. The list is used to report unused hidden states.
26610 Constituents_Seen : Elist_Id := No_Elist;
26611 -- A list that contains all constituents processed so far. The list is
26612 -- used to detect multiple uses of the same constituent.
26614 Freeze_Posted : Boolean := False;
26615 -- A flag that controls the output of a freezing-related error (see use
26618 Refined_States_Seen : Elist_Id := No_Elist;
26619 -- A list that contains all refined states processed so far. The list is
26620 -- used to detect duplicate refinements.
26622 procedure Analyze_Refinement_Clause (Clause : Node_Id);
26623 -- Perform full analysis of a single refinement clause
26625 procedure Report_Unrefined_States (States : Elist_Id);
26626 -- Emit errors for all unrefined abstract states found in list States
26628 -------------------------------
26629 -- Analyze_Refinement_Clause --
26630 -------------------------------
26632 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
26633 AR_Constit : Entity_Id := Empty;
26634 AW_Constit : Entity_Id := Empty;
26635 ER_Constit : Entity_Id := Empty;
26636 EW_Constit : Entity_Id := Empty;
26637 -- The entities of external constituents that contain one of the
26638 -- following enabled properties: Async_Readers, Async_Writers,
26639 -- Effective_Reads and Effective_Writes.
26641 External_Constit_Seen : Boolean := False;
26642 -- Flag used to mark when at least one external constituent is part
26643 -- of the state refinement.
26645 Non_Null_Seen : Boolean := False;
26646 Null_Seen : Boolean := False;
26647 -- Flags used to detect multiple uses of null in a single clause or a
26648 -- mixture of null and non-null constituents.
26650 Part_Of_Constits : Elist_Id := No_Elist;
26651 -- A list of all candidate constituents subject to indicator Part_Of
26652 -- where the encapsulating state is the current state.
26655 State_Id : Entity_Id;
26656 -- The current state being refined
26658 procedure Analyze_Constituent (Constit : Node_Id);
26659 -- Perform full analysis of a single constituent
26661 procedure Check_External_Property
26662 (Prop_Nam : Name_Id;
26664 Constit : Entity_Id);
26665 -- Determine whether a property denoted by name Prop_Nam is present
26666 -- in the refined state. Emit an error if this is not the case. Flag
26667 -- Enabled should be set when the property applies to the refined
26668 -- state. Constit denotes the constituent (if any) which introduces
26669 -- the property in the refinement.
26671 procedure Match_State;
26672 -- Determine whether the state being refined appears in list
26673 -- Available_States. Emit an error when attempting to re-refine the
26674 -- state or when the state is not defined in the package declaration,
26675 -- otherwise remove the state from Available_States.
26677 procedure Report_Unused_Constituents (Constits : Elist_Id);
26678 -- Emit errors for all unused Part_Of constituents in list Constits
26680 -------------------------
26681 -- Analyze_Constituent --
26682 -------------------------
26684 procedure Analyze_Constituent (Constit : Node_Id) is
26685 procedure Match_Constituent (Constit_Id : Entity_Id);
26686 -- Determine whether constituent Constit denoted by its entity
26687 -- Constit_Id appears in Body_States. Emit an error when the
26688 -- constituent is not a valid hidden state of the related package
26689 -- or when it is used more than once. Otherwise remove the
26690 -- constituent from Body_States.
26692 -----------------------
26693 -- Match_Constituent --
26694 -----------------------
26696 procedure Match_Constituent (Constit_Id : Entity_Id) is
26697 procedure Collect_Constituent;
26698 -- Verify the legality of constituent Constit_Id and add it to
26699 -- the refinements of State_Id.
26701 -------------------------
26702 -- Collect_Constituent --
26703 -------------------------
26705 procedure Collect_Constituent is
26706 Constits : Elist_Id;
26709 -- The Ghost policy in effect at the point of abstract state
26710 -- declaration and constituent must match (SPARK RM 6.9(15))
26712 Check_Ghost_Refinement
26713 (State, State_Id, Constit, Constit_Id);
26715 -- A synchronized state must be refined by a synchronized
26716 -- object or another synchronized state (SPARK RM 9.6).
26718 if Is_Synchronized_State (State_Id)
26719 and then not Is_Synchronized_Object (Constit_Id)
26720 and then not Is_Synchronized_State (Constit_Id)
26723 ("constituent of synchronized state & must be "
26724 & "synchronized", Constit, State_Id);
26727 -- Add the constituent to the list of processed items to aid
26728 -- with the detection of duplicates.
26730 Append_New_Elmt (Constit_Id, Constituents_Seen);
26732 -- Collect the constituent in the list of refinement items
26733 -- and establish a relation between the refined state and
26736 Constits := Refinement_Constituents (State_Id);
26738 if No (Constits) then
26739 Constits := New_Elmt_List;
26740 Set_Refinement_Constituents (State_Id, Constits);
26743 Append_Elmt (Constit_Id, Constits);
26744 Set_Encapsulating_State (Constit_Id, State_Id);
26746 -- The state has at least one legal constituent, mark the
26747 -- start of the refinement region. The region ends when the
26748 -- body declarations end (see routine Analyze_Declarations).
26750 Set_Has_Visible_Refinement (State_Id);
26752 -- When the constituent is external, save its relevant
26753 -- property for further checks.
26755 if Async_Readers_Enabled (Constit_Id) then
26756 AR_Constit := Constit_Id;
26757 External_Constit_Seen := True;
26760 if Async_Writers_Enabled (Constit_Id) then
26761 AW_Constit := Constit_Id;
26762 External_Constit_Seen := True;
26765 if Effective_Reads_Enabled (Constit_Id) then
26766 ER_Constit := Constit_Id;
26767 External_Constit_Seen := True;
26770 if Effective_Writes_Enabled (Constit_Id) then
26771 EW_Constit := Constit_Id;
26772 External_Constit_Seen := True;
26774 end Collect_Constituent;
26778 State_Elmt : Elmt_Id;
26780 -- Start of processing for Match_Constituent
26783 -- Detect a duplicate use of a constituent
26785 if Contains (Constituents_Seen, Constit_Id) then
26787 ("duplicate use of constituent &", Constit, Constit_Id);
26791 -- The constituent is subject to a Part_Of indicator
26793 if Present (Encapsulating_State (Constit_Id)) then
26794 if Encapsulating_State (Constit_Id) = State_Id then
26795 Remove (Part_Of_Constits, Constit_Id);
26796 Collect_Constituent;
26798 -- The constituent is part of another state and is used
26799 -- incorrectly in the refinement of the current state.
26802 Error_Msg_Name_1 := Chars (State_Id);
26804 ("& cannot act as constituent of state %",
26805 Constit, Constit_Id);
26807 ("\Part_Of indicator specifies encapsulator &",
26808 Constit, Encapsulating_State (Constit_Id));
26811 -- The only other source of legal constituents is the body
26812 -- state space of the related package.
26815 if Present (Body_States) then
26816 State_Elmt := First_Elmt (Body_States);
26817 while Present (State_Elmt) loop
26819 -- Consume a valid constituent to signal that it has
26820 -- been encountered.
26822 if Node (State_Elmt) = Constit_Id then
26823 Remove_Elmt (Body_States, State_Elmt);
26824 Collect_Constituent;
26828 Next_Elmt (State_Elmt);
26832 -- Constants are part of the hidden state of a package, but
26833 -- the compiler cannot determine whether they have variable
26834 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26835 -- hidden state. Accept the constant quietly even if it is
26836 -- a visible state or lacks a Part_Of indicator.
26838 if Ekind (Constit_Id) = E_Constant then
26839 Collect_Constituent;
26841 -- If we get here, then the constituent is not a hidden
26842 -- state of the related package and may not be used in a
26843 -- refinement (SPARK RM 7.2.2(9)).
26846 Error_Msg_Name_1 := Chars (Spec_Id);
26848 ("cannot use & in refinement, constituent is not a "
26849 & "hidden state of package %", Constit, Constit_Id);
26852 end Match_Constituent;
26856 Constit_Id : Entity_Id;
26857 Constits : Elist_Id;
26859 -- Start of processing for Analyze_Constituent
26862 -- Detect multiple uses of null in a single refinement clause or a
26863 -- mixture of null and non-null constituents.
26865 if Nkind (Constit) = N_Null then
26868 ("multiple null constituents not allowed", Constit);
26870 elsif Non_Null_Seen then
26872 ("cannot mix null and non-null constituents", Constit);
26877 -- Collect the constituent in the list of refinement items
26879 Constits := Refinement_Constituents (State_Id);
26881 if No (Constits) then
26882 Constits := New_Elmt_List;
26883 Set_Refinement_Constituents (State_Id, Constits);
26886 Append_Elmt (Constit, Constits);
26888 -- The state has at least one legal constituent, mark the
26889 -- start of the refinement region. The region ends when the
26890 -- body declarations end (see Analyze_Declarations).
26892 Set_Has_Visible_Refinement (State_Id);
26895 -- Non-null constituents
26898 Non_Null_Seen := True;
26902 ("cannot mix null and non-null constituents", Constit);
26906 Resolve_State (Constit);
26908 -- Ensure that the constituent denotes a valid state or a
26909 -- whole object (SPARK RM 7.2.2(5)).
26911 if Is_Entity_Name (Constit) then
26912 Constit_Id := Entity_Of (Constit);
26914 -- When a constituent is declared after a subprogram body
26915 -- that caused "freezing" of the related contract where
26916 -- pragma Refined_State resides, the constituent appears
26917 -- undefined and carries Any_Id as its entity.
26919 -- package body Pack
26920 -- with Refined_State => (State => Constit)
26923 -- with Refined_Global => (Input => Constit)
26931 if Constit_Id = Any_Id then
26932 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
26934 -- Emit a specialized info message when the contract of
26935 -- the related package body was "frozen" by another body.
26936 -- Note that it is not possible to precisely identify why
26937 -- the constituent is undefined because it is not visible
26938 -- when pragma Refined_State is analyzed. This message is
26939 -- a reasonable approximation.
26941 if Present (Freeze_Id) and then not Freeze_Posted then
26942 Freeze_Posted := True;
26944 Error_Msg_Name_1 := Chars (Body_Id);
26945 Error_Msg_Sloc := Sloc (Freeze_Id);
26947 ("body & declared # freezes the contract of %",
26950 ("\all constituents must be declared before body #",
26953 -- A misplaced constituent is a critical error because
26954 -- pragma Refined_Depends or Refined_Global depends on
26955 -- the proper link between a state and a constituent.
26956 -- Stop the compilation, as this leads to a multitude
26957 -- of misleading cascaded errors.
26959 raise Program_Error;
26962 -- The constituent is a valid state or object
26964 elsif Ekind_In (Constit_Id, E_Abstract_State,
26968 Match_Constituent (Constit_Id);
26970 -- The variable may eventually become a constituent of a
26971 -- single protected/task type. Record the reference now
26972 -- and verify its legality when analyzing the contract of
26973 -- the variable (SPARK RM 9.3).
26975 if Ekind (Constit_Id) = E_Variable then
26976 Record_Possible_Part_Of_Reference
26977 (Var_Id => Constit_Id,
26981 -- Otherwise the constituent is illegal
26985 ("constituent & must denote object or state",
26986 Constit, Constit_Id);
26989 -- The constituent is illegal
26992 SPARK_Msg_N ("malformed constituent", Constit);
26995 end Analyze_Constituent;
26997 -----------------------------
26998 -- Check_External_Property --
26999 -----------------------------
27001 procedure Check_External_Property
27002 (Prop_Nam : Name_Id;
27004 Constit : Entity_Id)
27007 -- The property is missing in the declaration of the state, but
27008 -- a constituent is introducing it in the state refinement
27009 -- (SPARK RM 7.2.8(2)).
27011 if not Enabled and then Present (Constit) then
27012 Error_Msg_Name_1 := Prop_Nam;
27013 Error_Msg_Name_2 := Chars (State_Id);
27015 ("constituent & introduces external property % in refinement "
27016 & "of state %", State, Constit);
27018 Error_Msg_Sloc := Sloc (State_Id);
27020 ("\property is missing in abstract state declaration #",
27023 end Check_External_Property;
27029 procedure Match_State is
27030 State_Elmt : Elmt_Id;
27033 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27035 if Contains (Refined_States_Seen, State_Id) then
27037 ("duplicate refinement of state &", State, State_Id);
27041 -- Inspect the abstract states defined in the package declaration
27042 -- looking for a match.
27044 State_Elmt := First_Elmt (Available_States);
27045 while Present (State_Elmt) loop
27047 -- A valid abstract state is being refined in the body. Add
27048 -- the state to the list of processed refined states to aid
27049 -- with the detection of duplicate refinements. Remove the
27050 -- state from Available_States to signal that it has already
27053 if Node (State_Elmt) = State_Id then
27054 Append_New_Elmt (State_Id, Refined_States_Seen);
27055 Remove_Elmt (Available_States, State_Elmt);
27059 Next_Elmt (State_Elmt);
27062 -- If we get here, we are refining a state that is not defined in
27063 -- the package declaration.
27065 Error_Msg_Name_1 := Chars (Spec_Id);
27067 ("cannot refine state, & is not defined in package %",
27071 --------------------------------
27072 -- Report_Unused_Constituents --
27073 --------------------------------
27075 procedure Report_Unused_Constituents (Constits : Elist_Id) is
27076 Constit_Elmt : Elmt_Id;
27077 Constit_Id : Entity_Id;
27078 Posted : Boolean := False;
27081 if Present (Constits) then
27082 Constit_Elmt := First_Elmt (Constits);
27083 while Present (Constit_Elmt) loop
27084 Constit_Id := Node (Constit_Elmt);
27086 -- Generate an error message of the form:
27088 -- state ... has unused Part_Of constituents
27089 -- abstract state ... defined at ...
27090 -- constant ... defined at ...
27091 -- variable ... defined at ...
27096 ("state & has unused Part_Of constituents",
27100 Error_Msg_Sloc := Sloc (Constit_Id);
27102 if Ekind (Constit_Id) = E_Abstract_State then
27104 ("\abstract state & defined #", State, Constit_Id);
27106 elsif Ekind (Constit_Id) = E_Constant then
27108 ("\constant & defined #", State, Constit_Id);
27111 pragma Assert (Ekind (Constit_Id) = E_Variable);
27112 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
27115 Next_Elmt (Constit_Elmt);
27118 end Report_Unused_Constituents;
27120 -- Local declarations
27122 Body_Ref : Node_Id;
27123 Body_Ref_Elmt : Elmt_Id;
27125 Extra_State : Node_Id;
27127 -- Start of processing for Analyze_Refinement_Clause
27130 -- A refinement clause appears as a component association where the
27131 -- sole choice is the state and the expressions are the constituents.
27132 -- This is a syntax error, always report.
27134 if Nkind (Clause) /= N_Component_Association then
27135 Error_Msg_N ("malformed state refinement clause", Clause);
27139 -- Analyze the state name of a refinement clause
27141 State := First (Choices (Clause));
27144 Resolve_State (State);
27146 -- Ensure that the state name denotes a valid abstract state that is
27147 -- defined in the spec of the related package.
27149 if Is_Entity_Name (State) then
27150 State_Id := Entity_Of (State);
27152 -- When the abstract state is undefined, it appears as Any_Id. Do
27153 -- not continue with the analysis of the clause.
27155 if State_Id = Any_Id then
27158 -- Catch any attempts to re-refine a state or refine a state that
27159 -- is not defined in the package declaration.
27161 elsif Ekind (State_Id) = E_Abstract_State then
27165 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
27169 -- References to a state with visible refinement are illegal.
27170 -- When nested packages are involved, detecting such references is
27171 -- tricky because pragma Refined_State is analyzed later than the
27172 -- offending pragma Depends or Global. References that occur in
27173 -- such nested context are stored in a list. Emit errors for all
27174 -- references found in Body_References (SPARK RM 6.1.4(8)).
27176 if Present (Body_References (State_Id)) then
27177 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
27178 while Present (Body_Ref_Elmt) loop
27179 Body_Ref := Node (Body_Ref_Elmt);
27181 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
27182 Error_Msg_Sloc := Sloc (State);
27183 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
27185 Next_Elmt (Body_Ref_Elmt);
27189 -- The state name is illegal. This is a syntax error, always report.
27192 Error_Msg_N ("malformed state name in refinement clause", State);
27196 -- A refinement clause may only refine one state at a time
27198 Extra_State := Next (State);
27200 if Present (Extra_State) then
27202 ("refinement clause cannot cover multiple states", Extra_State);
27205 -- Replicate the Part_Of constituents of the refined state because
27206 -- the algorithm will consume items.
27208 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
27210 -- Analyze all constituents of the refinement. Multiple constituents
27211 -- appear as an aggregate.
27213 Constit := Expression (Clause);
27215 if Nkind (Constit) = N_Aggregate then
27216 if Present (Component_Associations (Constit)) then
27218 ("constituents of refinement clause must appear in "
27219 & "positional form", Constit);
27221 else pragma Assert (Present (Expressions (Constit)));
27222 Constit := First (Expressions (Constit));
27223 while Present (Constit) loop
27224 Analyze_Constituent (Constit);
27229 -- Various forms of a single constituent. Note that these may include
27230 -- malformed constituents.
27233 Analyze_Constituent (Constit);
27236 -- Verify that external constituents do not introduce new external
27237 -- property in the state refinement (SPARK RM 7.2.8(2)).
27239 if Is_External_State (State_Id) then
27240 Check_External_Property
27241 (Prop_Nam => Name_Async_Readers,
27242 Enabled => Async_Readers_Enabled (State_Id),
27243 Constit => AR_Constit);
27245 Check_External_Property
27246 (Prop_Nam => Name_Async_Writers,
27247 Enabled => Async_Writers_Enabled (State_Id),
27248 Constit => AW_Constit);
27250 Check_External_Property
27251 (Prop_Nam => Name_Effective_Reads,
27252 Enabled => Effective_Reads_Enabled (State_Id),
27253 Constit => ER_Constit);
27255 Check_External_Property
27256 (Prop_Nam => Name_Effective_Writes,
27257 Enabled => Effective_Writes_Enabled (State_Id),
27258 Constit => EW_Constit);
27260 -- When a refined state is not external, it should not have external
27261 -- constituents (SPARK RM 7.2.8(1)).
27263 elsif External_Constit_Seen then
27265 ("non-external state & cannot contain external constituents in "
27266 & "refinement", State, State_Id);
27269 -- Ensure that all Part_Of candidate constituents have been mentioned
27270 -- in the refinement clause.
27272 Report_Unused_Constituents (Part_Of_Constits);
27273 end Analyze_Refinement_Clause;
27275 -----------------------------
27276 -- Report_Unrefined_States --
27277 -----------------------------
27279 procedure Report_Unrefined_States (States : Elist_Id) is
27280 State_Elmt : Elmt_Id;
27283 if Present (States) then
27284 State_Elmt := First_Elmt (States);
27285 while Present (State_Elmt) loop
27287 ("abstract state & must be refined", Node (State_Elmt));
27289 Next_Elmt (State_Elmt);
27292 end Report_Unrefined_States;
27294 -- Local declarations
27296 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27299 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27302 -- Do not analyze the pragma multiple times
27304 if Is_Analyzed_Pragma (N) then
27308 -- Replicate the abstract states declared by the package because the
27309 -- matching algorithm will consume states.
27311 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
27313 -- Gather all abstract states and objects declared in the visible
27314 -- state space of the package body. These items must be utilized as
27315 -- constituents in a state refinement.
27317 Body_States := Collect_Body_States (Body_Id);
27319 -- Multiple non-null state refinements appear as an aggregate
27321 if Nkind (Clauses) = N_Aggregate then
27322 if Present (Expressions (Clauses)) then
27324 ("state refinements must appear as component associations",
27327 else pragma Assert (Present (Component_Associations (Clauses)));
27328 Clause := First (Component_Associations (Clauses));
27329 while Present (Clause) loop
27330 Analyze_Refinement_Clause (Clause);
27335 -- Various forms of a single state refinement. Note that these may
27336 -- include malformed refinements.
27339 Analyze_Refinement_Clause (Clauses);
27342 -- List all abstract states that were left unrefined
27344 Report_Unrefined_States (Available_States);
27346 Set_Is_Analyzed_Pragma (N);
27347 end Analyze_Refined_State_In_Decl_Part;
27349 ------------------------------------
27350 -- Analyze_Test_Case_In_Decl_Part --
27351 ------------------------------------
27353 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
27354 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27355 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27357 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
27358 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27359 -- denoted by Arg_Nam.
27361 ------------------------------
27362 -- Preanalyze_Test_Case_Arg --
27363 ------------------------------
27365 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
27369 -- Preanalyze the original aspect argument for ASIS or for a generic
27370 -- subprogram to properly capture global references.
27372 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
27376 Arg_Nam => Arg_Nam,
27377 From_Aspect => True);
27379 if Present (Arg) then
27380 Preanalyze_Assert_Expression
27381 (Expression (Arg), Standard_Boolean);
27385 Arg := Test_Case_Arg (N, Arg_Nam);
27387 if Present (Arg) then
27388 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
27390 end Preanalyze_Test_Case_Arg;
27394 Restore_Scope : Boolean := False;
27396 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27399 -- Do not analyze the pragma multiple times
27401 if Is_Analyzed_Pragma (N) then
27405 -- Ensure that the formal parameters are visible when analyzing all
27406 -- clauses. This falls out of the general rule of aspects pertaining
27407 -- to subprogram declarations.
27409 if not In_Open_Scopes (Spec_Id) then
27410 Restore_Scope := True;
27411 Push_Scope (Spec_Id);
27413 if Is_Generic_Subprogram (Spec_Id) then
27414 Install_Generic_Formals (Spec_Id);
27416 Install_Formals (Spec_Id);
27420 Preanalyze_Test_Case_Arg (Name_Requires);
27421 Preanalyze_Test_Case_Arg (Name_Ensures);
27423 if Restore_Scope then
27427 -- Currently it is not possible to inline pre/postconditions on a
27428 -- subprogram subject to pragma Inline_Always.
27430 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27432 Set_Is_Analyzed_Pragma (N);
27433 end Analyze_Test_Case_In_Decl_Part;
27439 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
27444 if Present (List) then
27445 Elmt := First_Elmt (List);
27446 while Present (Elmt) loop
27447 if Nkind (Node (Elmt)) = N_Defining_Identifier then
27450 Id := Entity_Of (Node (Elmt));
27453 if Id = Item_Id then
27464 -----------------------------------
27465 -- Build_Pragma_Check_Equivalent --
27466 -----------------------------------
27468 function Build_Pragma_Check_Equivalent
27470 Subp_Id : Entity_Id := Empty;
27471 Inher_Id : Entity_Id := Empty;
27472 Keep_Pragma_Id : Boolean := False) return Node_Id
27474 function Suppress_Reference (N : Node_Id) return Traverse_Result;
27475 -- Detect whether node N references a formal parameter subject to
27476 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27477 -- to False to suppress the generation of a reference when analyzing
27480 ------------------------
27481 -- Suppress_Reference --
27482 ------------------------
27484 function Suppress_Reference (N : Node_Id) return Traverse_Result is
27485 Formal : Entity_Id;
27488 if Is_Entity_Name (N) and then Present (Entity (N)) then
27489 Formal := Entity (N);
27491 -- The formal parameter is subject to pragma Unreferenced. Prevent
27492 -- the generation of references by resetting the Comes_From_Source
27495 if Is_Formal (Formal)
27496 and then Has_Pragma_Unreferenced (Formal)
27498 Set_Comes_From_Source (N, False);
27503 end Suppress_Reference;
27505 procedure Suppress_References is
27506 new Traverse_Proc (Suppress_Reference);
27510 Loc : constant Source_Ptr := Sloc (Prag);
27511 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27512 Check_Prag : Node_Id;
27516 Needs_Wrapper : Boolean;
27517 pragma Unreferenced (Needs_Wrapper);
27519 -- Start of processing for Build_Pragma_Check_Equivalent
27522 -- When the pre- or postcondition is inherited, map the formals of the
27523 -- inherited subprogram to those of the current subprogram. In addition,
27524 -- map primitive operations of the parent type into the corresponding
27525 -- primitive operations of the descendant.
27527 if Present (Inher_Id) then
27528 pragma Assert (Present (Subp_Id));
27530 Update_Primitives_Mapping (Inher_Id, Subp_Id);
27532 -- Use generic machinery to copy inherited pragma, as if it were an
27533 -- instantiation, resetting source locations appropriately, so that
27534 -- expressions inside the inherited pragma use chained locations.
27535 -- This is used in particular in GNATprove to locate precisely
27536 -- messages on a given inherited pragma.
27538 Set_Copied_Sloc_For_Inherited_Pragma
27539 (Unit_Declaration_Node (Subp_Id), Inher_Id);
27540 Check_Prag := New_Copy_Tree (Source => Prag);
27542 -- Build the inherited class-wide condition
27544 Build_Class_Wide_Expression
27545 (Prag => Check_Prag,
27547 Par_Subp => Inher_Id,
27548 Adjust_Sloc => True,
27549 Needs_Wrapper => Needs_Wrapper);
27551 -- If not an inherited condition simply copy the original pragma
27554 Check_Prag := New_Copy_Tree (Source => Prag);
27557 -- Mark the pragma as being internally generated and reset the Analyzed
27560 Set_Analyzed (Check_Prag, False);
27561 Set_Comes_From_Source (Check_Prag, False);
27563 -- The tree of the original pragma may contain references to the
27564 -- formal parameters of the related subprogram. At the same time
27565 -- the corresponding body may mark the formals as unreferenced:
27567 -- procedure Proc (Formal : ...)
27568 -- with Pre => Formal ...;
27570 -- procedure Proc (Formal : ...) is
27571 -- pragma Unreferenced (Formal);
27574 -- This creates problems because all pragma Check equivalents are
27575 -- analyzed at the end of the body declarations. Since all source
27576 -- references have already been accounted for, reset any references
27577 -- to such formals in the generated pragma Check equivalent.
27579 Suppress_References (Check_Prag);
27581 if Present (Corresponding_Aspect (Prag)) then
27582 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
27587 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27588 -- the copied pragma in the newly created pragma, convert the copy into
27589 -- pragma Check by correcting the name and adding a check_kind argument.
27591 if not Keep_Pragma_Id then
27592 Set_Class_Present (Check_Prag, False);
27594 Set_Pragma_Identifier
27595 (Check_Prag, Make_Identifier (Loc, Name_Check));
27597 Prepend_To (Pragma_Argument_Associations (Check_Prag),
27598 Make_Pragma_Argument_Association (Loc,
27599 Expression => Make_Identifier (Loc, Nam)));
27602 -- Update the error message when the pragma is inherited
27604 if Present (Inher_Id) then
27605 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
27607 if Chars (Msg_Arg) = Name_Message then
27608 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
27610 -- Insert "inherited" to improve the error message
27612 if Name_Buffer (1 .. 8) = "failed p" then
27613 Insert_Str_In_Name_Buffer ("inherited ", 8);
27614 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
27620 end Build_Pragma_Check_Equivalent;
27622 -----------------------------
27623 -- Check_Applicable_Policy --
27624 -----------------------------
27626 procedure Check_Applicable_Policy (N : Node_Id) is
27630 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
27633 -- No effect if not valid assertion kind name
27635 if not Is_Valid_Assertion_Kind (Ename) then
27639 -- Loop through entries in check policy list
27641 PP := Opt.Check_Policy_List;
27642 while Present (PP) loop
27644 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27645 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27649 or else Pnm = Name_Assertion
27650 or else (Pnm = Name_Statement_Assertions
27651 and then Nam_In (Ename, Name_Assert,
27652 Name_Assert_And_Cut,
27654 Name_Loop_Invariant,
27655 Name_Loop_Variant))
27657 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
27663 Set_Is_Ignored (N, True);
27664 Set_Is_Checked (N, False);
27669 Set_Is_Checked (N, True);
27670 Set_Is_Ignored (N, False);
27672 when Name_Disable =>
27673 Set_Is_Ignored (N, True);
27674 Set_Is_Checked (N, False);
27675 Set_Is_Disabled (N, True);
27677 -- That should be exhaustive, the null here is a defence
27678 -- against a malformed tree from previous errors.
27687 PP := Next_Pragma (PP);
27691 -- If there are no specific entries that matched, then we let the
27692 -- setting of assertions govern. Note that this provides the needed
27693 -- compatibility with the RM for the cases of assertion, invariant,
27694 -- precondition, predicate, and postcondition.
27696 if Assertions_Enabled then
27697 Set_Is_Checked (N, True);
27698 Set_Is_Ignored (N, False);
27700 Set_Is_Checked (N, False);
27701 Set_Is_Ignored (N, True);
27703 end Check_Applicable_Policy;
27705 -------------------------------
27706 -- Check_External_Properties --
27707 -------------------------------
27709 procedure Check_External_Properties
27717 -- All properties enabled
27719 if AR and AW and ER and EW then
27722 -- Async_Readers + Effective_Writes
27723 -- Async_Readers + Async_Writers + Effective_Writes
27725 elsif AR and EW and not ER then
27728 -- Async_Writers + Effective_Reads
27729 -- Async_Readers + Async_Writers + Effective_Reads
27731 elsif AW and ER and not EW then
27734 -- Async_Readers + Async_Writers
27736 elsif AR and AW and not ER and not EW then
27741 elsif AR and not AW and not ER and not EW then
27746 elsif AW and not AR and not ER and not EW then
27751 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27754 end Check_External_Properties;
27760 function Check_Kind (Nam : Name_Id) return Name_Id is
27764 -- Loop through entries in check policy list
27766 PP := Opt.Check_Policy_List;
27767 while Present (PP) loop
27769 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27770 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27774 or else (Pnm = Name_Assertion
27775 and then Is_Valid_Assertion_Kind (Nam))
27776 or else (Pnm = Name_Statement_Assertions
27777 and then Nam_In (Nam, Name_Assert,
27778 Name_Assert_And_Cut,
27780 Name_Loop_Invariant,
27781 Name_Loop_Variant))
27783 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
27792 return Name_Ignore;
27794 when Name_Disable =>
27795 return Name_Disable;
27798 raise Program_Error;
27802 PP := Next_Pragma (PP);
27807 -- If there are no specific entries that matched, then we let the
27808 -- setting of assertions govern. Note that this provides the needed
27809 -- compatibility with the RM for the cases of assertion, invariant,
27810 -- precondition, predicate, and postcondition.
27812 if Assertions_Enabled then
27815 return Name_Ignore;
27819 ---------------------------
27820 -- Check_Missing_Part_Of --
27821 ---------------------------
27823 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
27824 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
27825 -- Determine whether a package denoted by Pack_Id declares at least one
27828 -----------------------
27829 -- Has_Visible_State --
27830 -----------------------
27832 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
27833 Item_Id : Entity_Id;
27836 -- Traverse the entity chain of the package trying to find at least
27837 -- one visible abstract state, variable or a package [instantiation]
27838 -- that declares a visible state.
27840 Item_Id := First_Entity (Pack_Id);
27841 while Present (Item_Id)
27842 and then not In_Private_Part (Item_Id)
27844 -- Do not consider internally generated items
27846 if not Comes_From_Source (Item_Id) then
27849 -- A visible state has been found
27851 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
27854 -- Recursively peek into nested packages and instantiations
27856 elsif Ekind (Item_Id) = E_Package
27857 and then Has_Visible_State (Item_Id)
27862 Next_Entity (Item_Id);
27866 end Has_Visible_State;
27870 Pack_Id : Entity_Id;
27871 Placement : State_Space_Kind;
27873 -- Start of processing for Check_Missing_Part_Of
27876 -- Do not consider abstract states, variables or package instantiations
27877 -- coming from an instance as those always inherit the Part_Of indicator
27878 -- of the instance itself.
27880 if In_Instance then
27883 -- Do not consider internally generated entities as these can never
27884 -- have a Part_Of indicator.
27886 elsif not Comes_From_Source (Item_Id) then
27889 -- Perform these checks only when SPARK_Mode is enabled as they will
27890 -- interfere with standard Ada rules and produce false positives.
27892 elsif SPARK_Mode /= On then
27895 -- Do not consider constants, because the compiler cannot accurately
27896 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27897 -- act as a hidden state of a package.
27899 elsif Ekind (Item_Id) = E_Constant then
27903 -- Find where the abstract state, variable or package instantiation
27904 -- lives with respect to the state space.
27906 Find_Placement_In_State_Space
27907 (Item_Id => Item_Id,
27908 Placement => Placement,
27909 Pack_Id => Pack_Id);
27911 -- Items that appear in a non-package construct (subprogram, block, etc)
27912 -- do not require a Part_Of indicator because they can never act as a
27915 if Placement = Not_In_Package then
27918 -- An item declared in the body state space of a package always act as a
27919 -- constituent and does not need explicit Part_Of indicator.
27921 elsif Placement = Body_State_Space then
27924 -- In general an item declared in the visible state space of a package
27925 -- does not require a Part_Of indicator. The only exception is when the
27926 -- related package is a private child unit in which case Part_Of must
27927 -- denote a state in the parent unit or in one of its descendants.
27929 elsif Placement = Visible_State_Space then
27930 if Is_Child_Unit (Pack_Id)
27931 and then Is_Private_Descendant (Pack_Id)
27933 -- A package instantiation does not need a Part_Of indicator when
27934 -- the related generic template has no visible state.
27936 if Ekind (Item_Id) = E_Package
27937 and then Is_Generic_Instance (Item_Id)
27938 and then not Has_Visible_State (Item_Id)
27942 -- All other cases require Part_Of
27946 ("indicator Part_Of is required in this context "
27947 & "(SPARK RM 7.2.6(3))", Item_Id);
27948 Error_Msg_Name_1 := Chars (Pack_Id);
27950 ("\& is declared in the visible part of private child "
27951 & "unit %", Item_Id);
27955 -- When the item appears in the private state space of a packge, it must
27956 -- be a part of some state declared by the said package.
27958 else pragma Assert (Placement = Private_State_Space);
27960 -- The related package does not declare a state, the item cannot act
27961 -- as a Part_Of constituent.
27963 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
27966 -- A package instantiation does not need a Part_Of indicator when the
27967 -- related generic template has no visible state.
27969 elsif Ekind (Pack_Id) = E_Package
27970 and then Is_Generic_Instance (Pack_Id)
27971 and then not Has_Visible_State (Pack_Id)
27975 -- All other cases require Part_Of
27979 ("indicator Part_Of is required in this context "
27980 & "(SPARK RM 7.2.6(2))", Item_Id);
27981 Error_Msg_Name_1 := Chars (Pack_Id);
27983 ("\& is declared in the private part of package %", Item_Id);
27986 end Check_Missing_Part_Of;
27988 ---------------------------------------------------
27989 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27990 ---------------------------------------------------
27992 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27994 Spec_Id : Entity_Id)
27997 if Warn_On_Redundant_Constructs
27998 and then Has_Pragma_Inline_Always (Spec_Id)
28000 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
28002 if From_Aspect_Specification (Prag) then
28004 ("aspect % not enforced on inlined subprogram &?r?",
28005 Corresponding_Aspect (Prag), Spec_Id);
28008 ("pragma % not enforced on inlined subprogram &?r?",
28012 end Check_Postcondition_Use_In_Inlined_Subprogram;
28014 -------------------------------------
28015 -- Check_State_And_Constituent_Use --
28016 -------------------------------------
28018 procedure Check_State_And_Constituent_Use
28019 (States : Elist_Id;
28020 Constits : Elist_Id;
28023 Constit_Elmt : Elmt_Id;
28024 Constit_Id : Entity_Id;
28025 State_Id : Entity_Id;
28028 -- Nothing to do if there are no states or constituents
28030 if No (States) or else No (Constits) then
28034 -- Inspect the list of constituents and try to determine whether its
28035 -- encapsulating state is in list States.
28037 Constit_Elmt := First_Elmt (Constits);
28038 while Present (Constit_Elmt) loop
28039 Constit_Id := Node (Constit_Elmt);
28041 -- Determine whether the constituent is part of an encapsulating
28042 -- state that appears in the same context and if this is the case,
28043 -- emit an error (SPARK RM 7.2.6(7)).
28045 State_Id := Find_Encapsulating_State (States, Constit_Id);
28047 if Present (State_Id) then
28048 Error_Msg_Name_1 := Chars (Constit_Id);
28050 ("cannot mention state & and its constituent % in the same "
28051 & "context", Context, State_Id);
28055 Next_Elmt (Constit_Elmt);
28057 end Check_State_And_Constituent_Use;
28059 ---------------------------------------------
28060 -- Collect_Inherited_Class_Wide_Conditions --
28061 ---------------------------------------------
28063 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
28064 Parent_Subp : constant Entity_Id :=
28065 Ultimate_Alias (Overridden_Operation (Subp));
28066 -- The Overridden_Operation may itself be inherited and as such have no
28067 -- explicit contract.
28069 Prags : constant Node_Id := Contract (Parent_Subp);
28070 In_Spec_Expr : Boolean;
28071 Installed : Boolean;
28073 New_Prag : Node_Id;
28076 Installed := False;
28078 -- Iterate over the contract of the overridden subprogram to find all
28079 -- inherited class-wide pre- and postconditions.
28081 if Present (Prags) then
28082 Prag := Pre_Post_Conditions (Prags);
28084 while Present (Prag) loop
28085 if Nam_In (Pragma_Name_Unmapped (Prag),
28086 Name_Precondition, Name_Postcondition)
28087 and then Class_Present (Prag)
28089 -- The generated pragma must be analyzed in the context of
28090 -- the subprogram, to make its formals visible. In addition,
28091 -- we must inhibit freezing and full analysis because the
28092 -- controlling type of the subprogram is not frozen yet, and
28093 -- may have further primitives.
28095 if not Installed then
28098 Install_Formals (Subp);
28099 In_Spec_Expr := In_Spec_Expression;
28100 In_Spec_Expression := True;
28104 Build_Pragma_Check_Equivalent
28105 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
28107 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
28108 Preanalyze (New_Prag);
28110 -- Prevent further analysis in subsequent processing of the
28111 -- current list of declarations
28113 Set_Analyzed (New_Prag);
28116 Prag := Next_Pragma (Prag);
28120 In_Spec_Expression := In_Spec_Expr;
28124 end Collect_Inherited_Class_Wide_Conditions;
28126 ---------------------------------------
28127 -- Collect_Subprogram_Inputs_Outputs --
28128 ---------------------------------------
28130 procedure Collect_Subprogram_Inputs_Outputs
28131 (Subp_Id : Entity_Id;
28132 Synthesize : Boolean := False;
28133 Subp_Inputs : in out Elist_Id;
28134 Subp_Outputs : in out Elist_Id;
28135 Global_Seen : out Boolean)
28137 procedure Collect_Dependency_Clause (Clause : Node_Id);
28138 -- Collect all relevant items from a dependency clause
28140 procedure Collect_Global_List
28142 Mode : Name_Id := Name_Input);
28143 -- Collect all relevant items from a global list
28145 -------------------------------
28146 -- Collect_Dependency_Clause --
28147 -------------------------------
28149 procedure Collect_Dependency_Clause (Clause : Node_Id) is
28150 procedure Collect_Dependency_Item
28152 Is_Input : Boolean);
28153 -- Add an item to the proper subprogram input or output collection
28155 -----------------------------
28156 -- Collect_Dependency_Item --
28157 -----------------------------
28159 procedure Collect_Dependency_Item
28161 Is_Input : Boolean)
28166 -- Nothing to collect when the item is null
28168 if Nkind (Item) = N_Null then
28171 -- Ditto for attribute 'Result
28173 elsif Is_Attribute_Result (Item) then
28176 -- Multiple items appear as an aggregate
28178 elsif Nkind (Item) = N_Aggregate then
28179 Extra := First (Expressions (Item));
28180 while Present (Extra) loop
28181 Collect_Dependency_Item (Extra, Is_Input);
28185 -- Otherwise this is a solitary item
28189 Append_New_Elmt (Item, Subp_Inputs);
28191 Append_New_Elmt (Item, Subp_Outputs);
28194 end Collect_Dependency_Item;
28196 -- Start of processing for Collect_Dependency_Clause
28199 if Nkind (Clause) = N_Null then
28202 -- A dependency cause appears as component association
28204 elsif Nkind (Clause) = N_Component_Association then
28205 Collect_Dependency_Item
28206 (Item => Expression (Clause),
28209 Collect_Dependency_Item
28210 (Item => First (Choices (Clause)),
28211 Is_Input => False);
28213 -- To accommodate partial decoration of disabled SPARK features, this
28214 -- routine may be called with illegal input. If this is the case, do
28215 -- not raise Program_Error.
28220 end Collect_Dependency_Clause;
28222 -------------------------
28223 -- Collect_Global_List --
28224 -------------------------
28226 procedure Collect_Global_List
28228 Mode : Name_Id := Name_Input)
28230 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
28231 -- Add an item to the proper subprogram input or output collection
28233 -------------------------
28234 -- Collect_Global_Item --
28235 -------------------------
28237 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
28239 if Nam_In (Mode, Name_In_Out, Name_Input) then
28240 Append_New_Elmt (Item, Subp_Inputs);
28243 if Nam_In (Mode, Name_In_Out, Name_Output) then
28244 Append_New_Elmt (Item, Subp_Outputs);
28246 end Collect_Global_Item;
28253 -- Start of processing for Collect_Global_List
28256 if Nkind (List) = N_Null then
28259 -- Single global item declaration
28261 elsif Nkind_In (List, N_Expanded_Name,
28263 N_Selected_Component)
28265 Collect_Global_Item (List, Mode);
28267 -- Simple global list or moded global list declaration
28269 elsif Nkind (List) = N_Aggregate then
28270 if Present (Expressions (List)) then
28271 Item := First (Expressions (List));
28272 while Present (Item) loop
28273 Collect_Global_Item (Item, Mode);
28278 Assoc := First (Component_Associations (List));
28279 while Present (Assoc) loop
28280 Collect_Global_List
28281 (List => Expression (Assoc),
28282 Mode => Chars (First (Choices (Assoc))));
28287 -- To accommodate partial decoration of disabled SPARK features, this
28288 -- routine may be called with illegal input. If this is the case, do
28289 -- not raise Program_Error.
28294 end Collect_Global_List;
28301 Formal : Entity_Id;
28303 Spec_Id : Entity_Id;
28304 Subp_Decl : Node_Id;
28307 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28310 Global_Seen := False;
28312 -- Process all formal parameters of entries, [generic] subprograms, and
28315 if Ekind_In (Subp_Id, E_Entry,
28318 E_Generic_Function,
28319 E_Generic_Procedure,
28323 Subp_Decl := Unit_Declaration_Node (Subp_Id);
28324 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28326 -- Process all [generic] formal parameters
28328 Formal := First_Entity (Spec_Id);
28329 while Present (Formal) loop
28330 if Ekind_In (Formal, E_Generic_In_Parameter,
28331 E_In_Out_Parameter,
28334 Append_New_Elmt (Formal, Subp_Inputs);
28337 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
28338 E_In_Out_Parameter,
28341 Append_New_Elmt (Formal, Subp_Outputs);
28343 -- Out parameters can act as inputs when the related type is
28344 -- tagged, unconstrained array, unconstrained record, or record
28345 -- with unconstrained components.
28347 if Ekind (Formal) = E_Out_Parameter
28348 and then Is_Unconstrained_Or_Tagged_Item (Formal)
28350 Append_New_Elmt (Formal, Subp_Inputs);
28354 Next_Entity (Formal);
28357 -- Otherwise the input denotes a task type, a task body, or the
28358 -- anonymous object created for a single task type.
28360 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
28361 or else Is_Single_Task_Object (Subp_Id)
28363 Subp_Decl := Declaration_Node (Subp_Id);
28364 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28367 -- When processing an entry, subprogram or task body, look for pragmas
28368 -- Refined_Depends and Refined_Global as they specify the inputs and
28371 if Is_Entry_Body (Subp_Id)
28372 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
28374 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
28375 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
28377 -- Subprogram declaration or stand alone body case, look for pragmas
28378 -- Depends and Global
28381 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
28382 Global := Get_Pragma (Spec_Id, Pragma_Global);
28385 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28386 -- because it provides finer granularity of inputs and outputs.
28388 if Present (Global) then
28389 Global_Seen := True;
28390 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
28392 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28393 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28394 -- the inputs and outputs from [Refined_]Depends.
28396 elsif Synthesize and then Present (Depends) then
28397 Clauses := Expression (Get_Argument (Depends, Spec_Id));
28399 -- Multiple dependency clauses appear as an aggregate
28401 if Nkind (Clauses) = N_Aggregate then
28402 Clause := First (Component_Associations (Clauses));
28403 while Present (Clause) loop
28404 Collect_Dependency_Clause (Clause);
28408 -- Otherwise this is a single dependency clause
28411 Collect_Dependency_Clause (Clauses);
28415 -- The current instance of a protected type acts as a formal parameter
28416 -- of mode IN for functions and IN OUT for entries and procedures
28417 -- (SPARK RM 6.1.4).
28419 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
28420 Typ := Scope (Spec_Id);
28422 -- Use the anonymous object when the type is single protected
28424 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28425 Typ := Anonymous_Object (Typ);
28428 Append_New_Elmt (Typ, Subp_Inputs);
28430 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
28431 Append_New_Elmt (Typ, Subp_Outputs);
28434 -- The current instance of a task type acts as a formal parameter of
28435 -- mode IN OUT (SPARK RM 6.1.4).
28437 elsif Ekind (Spec_Id) = E_Task_Type then
28440 -- Use the anonymous object when the type is single task
28442 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28443 Typ := Anonymous_Object (Typ);
28446 Append_New_Elmt (Typ, Subp_Inputs);
28447 Append_New_Elmt (Typ, Subp_Outputs);
28449 elsif Is_Single_Task_Object (Spec_Id) then
28450 Append_New_Elmt (Spec_Id, Subp_Inputs);
28451 Append_New_Elmt (Spec_Id, Subp_Outputs);
28453 end Collect_Subprogram_Inputs_Outputs;
28455 ---------------------------
28456 -- Contract_Freeze_Error --
28457 ---------------------------
28459 procedure Contract_Freeze_Error
28460 (Contract_Id : Entity_Id;
28461 Freeze_Id : Entity_Id)
28464 Error_Msg_Name_1 := Chars (Contract_Id);
28465 Error_Msg_Sloc := Sloc (Freeze_Id);
28468 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
28470 ("\all contractual items must be declared before body #", Contract_Id);
28471 end Contract_Freeze_Error;
28473 ---------------------------------
28474 -- Delay_Config_Pragma_Analyze --
28475 ---------------------------------
28477 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
28479 return Nam_In (Pragma_Name_Unmapped (N),
28480 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
28481 end Delay_Config_Pragma_Analyze;
28483 -----------------------
28484 -- Duplication_Error --
28485 -----------------------
28487 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
28488 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
28489 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
28492 Error_Msg_Sloc := Sloc (Prev);
28493 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
28495 -- Emit a precise message to distinguish between source pragmas and
28496 -- pragmas generated from aspects. The ordering of the two pragmas is
28500 -- Prag -- duplicate
28502 -- No error is emitted when both pragmas come from aspects because this
28503 -- is already detected by the general aspect analysis mechanism.
28505 if Prag_From_Asp and Prev_From_Asp then
28507 elsif Prag_From_Asp then
28508 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
28509 elsif Prev_From_Asp then
28510 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
28512 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
28514 end Duplication_Error;
28516 ------------------------------
28517 -- Find_Encapsulating_State --
28518 ------------------------------
28520 function Find_Encapsulating_State
28521 (States : Elist_Id;
28522 Constit_Id : Entity_Id) return Entity_Id
28524 State_Id : Entity_Id;
28527 -- Since a constituent may be part of a larger constituent set, climb
28528 -- the encapsulating state chain looking for a state that appears in
28531 State_Id := Encapsulating_State (Constit_Id);
28532 while Present (State_Id) loop
28533 if Contains (States, State_Id) then
28537 State_Id := Encapsulating_State (State_Id);
28541 end Find_Encapsulating_State;
28543 --------------------------
28544 -- Find_Related_Context --
28545 --------------------------
28547 function Find_Related_Context
28549 Do_Checks : Boolean := False) return Node_Id
28554 Stmt := Prev (Prag);
28555 while Present (Stmt) loop
28557 -- Skip prior pragmas, but check for duplicates
28559 if Nkind (Stmt) = N_Pragma then
28561 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
28568 -- Skip internally generated code
28570 elsif not Comes_From_Source (Stmt) then
28572 -- The anonymous object created for a single concurrent type is a
28573 -- suitable context.
28575 if Nkind (Stmt) = N_Object_Declaration
28576 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28581 -- Return the current source construct
28591 end Find_Related_Context;
28593 --------------------------------------
28594 -- Find_Related_Declaration_Or_Body --
28595 --------------------------------------
28597 function Find_Related_Declaration_Or_Body
28599 Do_Checks : Boolean := False) return Node_Id
28601 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
28603 procedure Expression_Function_Error;
28604 -- Emit an error concerning pragma Prag that illegaly applies to an
28605 -- expression function.
28607 -------------------------------
28608 -- Expression_Function_Error --
28609 -------------------------------
28611 procedure Expression_Function_Error is
28613 Error_Msg_Name_1 := Prag_Nam;
28615 -- Emit a precise message to distinguish between source pragmas and
28616 -- pragmas generated from aspects.
28618 if From_Aspect_Specification (Prag) then
28620 ("aspect % cannot apply to a stand alone expression function",
28624 ("pragma % cannot apply to a stand alone expression function",
28627 end Expression_Function_Error;
28631 Context : constant Node_Id := Parent (Prag);
28634 Look_For_Body : constant Boolean :=
28635 Nam_In (Prag_Nam, Name_Refined_Depends,
28636 Name_Refined_Global,
28637 Name_Refined_Post);
28638 -- Refinement pragmas must be associated with a subprogram body [stub]
28640 -- Start of processing for Find_Related_Declaration_Or_Body
28643 Stmt := Prev (Prag);
28644 while Present (Stmt) loop
28646 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28647 -- by splitting a complex pre/postcondition are not considered to
28650 if Nkind (Stmt) = N_Pragma then
28652 and then not Split_PPC (Stmt)
28653 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
28660 -- Emit an error when a refinement pragma appears on an expression
28661 -- function without a completion.
28664 and then Look_For_Body
28665 and then Nkind (Stmt) = N_Subprogram_Declaration
28666 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
28667 and then not Has_Completion (Defining_Entity (Stmt))
28669 Expression_Function_Error;
28672 -- The refinement pragma applies to a subprogram body stub
28674 elsif Look_For_Body
28675 and then Nkind (Stmt) = N_Subprogram_Body_Stub
28679 -- Skip internally generated code
28681 elsif not Comes_From_Source (Stmt) then
28683 -- The anonymous object created for a single concurrent type is a
28684 -- suitable context.
28686 if Nkind (Stmt) = N_Object_Declaration
28687 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28691 elsif Nkind (Stmt) = N_Subprogram_Declaration then
28693 -- The subprogram declaration is an internally generated spec
28694 -- for an expression function.
28696 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28699 -- The subprogram is actually an instance housed within an
28700 -- anonymous wrapper package.
28702 elsif Present (Generic_Parent (Specification (Stmt))) then
28707 -- Return the current construct which is either a subprogram body,
28708 -- a subprogram declaration or is illegal.
28717 -- If we fall through, then the pragma was either the first declaration
28718 -- or it was preceded by other pragmas and no source constructs.
28720 -- The pragma is associated with a library-level subprogram
28722 if Nkind (Context) = N_Compilation_Unit_Aux then
28723 return Unit (Parent (Context));
28725 -- The pragma appears inside the declarations of an entry body
28727 elsif Nkind (Context) = N_Entry_Body then
28730 -- The pragma appears inside the statements of a subprogram body. This
28731 -- placement is the result of subprogram contract expansion.
28733 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
28734 return Parent (Context);
28736 -- The pragma appears inside the declarative part of a subprogram body
28738 elsif Nkind (Context) = N_Subprogram_Body then
28741 -- The pragma appears inside the declarative part of a task body
28743 elsif Nkind (Context) = N_Task_Body then
28746 -- The pragma is a byproduct of aspect expansion, return the related
28747 -- context of the original aspect. This case has a lower priority as
28748 -- the above circuitry pinpoints precisely the related context.
28750 elsif Present (Corresponding_Aspect (Prag)) then
28751 return Parent (Corresponding_Aspect (Prag));
28753 -- No candidate subprogram [body] found
28758 end Find_Related_Declaration_Or_Body;
28760 ----------------------------------
28761 -- Find_Related_Package_Or_Body --
28762 ----------------------------------
28764 function Find_Related_Package_Or_Body
28766 Do_Checks : Boolean := False) return Node_Id
28768 Context : constant Node_Id := Parent (Prag);
28769 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
28773 Stmt := Prev (Prag);
28774 while Present (Stmt) loop
28776 -- Skip prior pragmas, but check for duplicates
28778 if Nkind (Stmt) = N_Pragma then
28779 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
28785 -- Skip internally generated code
28787 elsif not Comes_From_Source (Stmt) then
28788 if Nkind (Stmt) = N_Subprogram_Declaration then
28790 -- The subprogram declaration is an internally generated spec
28791 -- for an expression function.
28793 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28796 -- The subprogram is actually an instance housed within an
28797 -- anonymous wrapper package.
28799 elsif Present (Generic_Parent (Specification (Stmt))) then
28804 -- Return the current source construct which is illegal
28813 -- If we fall through, then the pragma was either the first declaration
28814 -- or it was preceded by other pragmas and no source constructs.
28816 -- The pragma is associated with a package. The immediate context in
28817 -- this case is the specification of the package.
28819 if Nkind (Context) = N_Package_Specification then
28820 return Parent (Context);
28822 -- The pragma appears in the declarations of a package body
28824 elsif Nkind (Context) = N_Package_Body then
28827 -- The pragma appears in the statements of a package body
28829 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
28830 and then Nkind (Parent (Context)) = N_Package_Body
28832 return Parent (Context);
28834 -- The pragma is a byproduct of aspect expansion, return the related
28835 -- context of the original aspect. This case has a lower priority as
28836 -- the above circuitry pinpoints precisely the related context.
28838 elsif Present (Corresponding_Aspect (Prag)) then
28839 return Parent (Corresponding_Aspect (Prag));
28841 -- No candidate packge [body] found
28846 end Find_Related_Package_Or_Body;
28852 function Get_Argument
28854 Context_Id : Entity_Id := Empty) return Node_Id
28856 Args : constant List_Id := Pragma_Argument_Associations (Prag);
28859 -- Use the expression of the original aspect when compiling for ASIS or
28860 -- when analyzing the template of a generic unit. In both cases the
28861 -- aspect's tree must be decorated to allow for ASIS queries or to save
28862 -- the global references in the generic context.
28864 if From_Aspect_Specification (Prag)
28865 and then (ASIS_Mode or else (Present (Context_Id)
28866 and then Is_Generic_Unit (Context_Id)))
28868 return Corresponding_Aspect (Prag);
28870 -- Otherwise use the expression of the pragma
28872 elsif Present (Args) then
28873 return First (Args);
28880 -------------------------
28881 -- Get_Base_Subprogram --
28882 -------------------------
28884 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
28885 Result : Entity_Id;
28888 -- Follow subprogram renaming chain
28892 if Is_Subprogram (Result)
28894 Nkind (Parent (Declaration_Node (Result))) =
28895 N_Subprogram_Renaming_Declaration
28896 and then Present (Alias (Result))
28898 Result := Alias (Result);
28902 end Get_Base_Subprogram;
28904 -----------------------
28905 -- Get_SPARK_Mode_Type --
28906 -----------------------
28908 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
28910 if N = Name_On then
28912 elsif N = Name_Off then
28915 -- Any other argument is illegal
28918 raise Program_Error;
28920 end Get_SPARK_Mode_Type;
28922 ------------------------------------
28923 -- Get_SPARK_Mode_From_Annotation --
28924 ------------------------------------
28926 function Get_SPARK_Mode_From_Annotation
28927 (N : Node_Id) return SPARK_Mode_Type
28932 if Nkind (N) = N_Aspect_Specification then
28933 Mode := Expression (N);
28935 else pragma Assert (Nkind (N) = N_Pragma);
28936 Mode := First (Pragma_Argument_Associations (N));
28938 if Present (Mode) then
28939 Mode := Get_Pragma_Arg (Mode);
28943 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28945 if Present (Mode) then
28946 if Nkind (Mode) = N_Identifier then
28947 return Get_SPARK_Mode_Type (Chars (Mode));
28949 -- In case of a malformed aspect or pragma, return the default None
28955 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28960 end Get_SPARK_Mode_From_Annotation;
28962 ---------------------------
28963 -- Has_Extra_Parentheses --
28964 ---------------------------
28966 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28970 -- The aggregate should not have an expression list because a clause
28971 -- is always interpreted as a component association. The only way an
28972 -- expression list can sneak in is by adding extra parentheses around
28973 -- the individual clauses:
28975 -- Depends (Output => Input) -- proper form
28976 -- Depends ((Output => Input)) -- extra parentheses
28978 -- Since the extra parentheses are not allowed by the syntax of the
28979 -- pragma, flag them now to avoid emitting misleading errors down the
28982 if Nkind (Clause) = N_Aggregate
28983 and then Present (Expressions (Clause))
28985 Expr := First (Expressions (Clause));
28986 while Present (Expr) loop
28988 -- A dependency clause surrounded by extra parentheses appears
28989 -- as an aggregate of component associations with an optional
28990 -- Paren_Count set.
28992 if Nkind (Expr) = N_Aggregate
28993 and then Present (Component_Associations (Expr))
28996 ("dependency clause contains extra parentheses", Expr);
28998 -- Otherwise the expression is a malformed construct
29001 SPARK_Msg_N ("malformed dependency clause", Expr);
29011 end Has_Extra_Parentheses;
29017 procedure Initialize is
29028 Dummy := Dummy + 1;
29031 -----------------------------
29032 -- Is_Config_Static_String --
29033 -----------------------------
29035 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
29037 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
29038 -- This is an internal recursive function that is just like the outer
29039 -- function except that it adds the string to the name buffer rather
29040 -- than placing the string in the name buffer.
29042 ------------------------------
29043 -- Add_Config_Static_String --
29044 ------------------------------
29046 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
29053 if Nkind (N) = N_Op_Concat then
29054 if Add_Config_Static_String (Left_Opnd (N)) then
29055 N := Right_Opnd (N);
29061 if Nkind (N) /= N_String_Literal then
29062 Error_Msg_N ("string literal expected for pragma argument", N);
29066 for J in 1 .. String_Length (Strval (N)) loop
29067 C := Get_String_Char (Strval (N), J);
29069 if not In_Character_Range (C) then
29071 ("string literal contains invalid wide character",
29072 Sloc (N) + 1 + Source_Ptr (J));
29076 Add_Char_To_Name_Buffer (Get_Character (C));
29081 end Add_Config_Static_String;
29083 -- Start of processing for Is_Config_Static_String
29088 return Add_Config_Static_String (Arg);
29089 end Is_Config_Static_String;
29091 ---------------------
29092 -- Is_CCT_Instance --
29093 ---------------------
29095 function Is_CCT_Instance
29096 (Ref_Id : Entity_Id;
29097 Context_Id : Entity_Id) return Boolean
29103 -- When the reference denotes a single protected type, the context is
29104 -- either a protected subprogram or its body.
29106 if Is_Single_Protected_Object (Ref_Id) then
29107 Typ := Scope (Context_Id);
29110 Ekind (Typ) = E_Protected_Type
29111 and then Present (Anonymous_Object (Typ))
29112 and then Anonymous_Object (Typ) = Ref_Id;
29114 -- When the reference denotes a single task type, the context is either
29115 -- the same type or if inside the body, the anonymous task type.
29117 elsif Is_Single_Task_Object (Ref_Id) then
29118 if Ekind (Context_Id) = E_Task_Type then
29120 Present (Anonymous_Object (Context_Id))
29121 and then Anonymous_Object (Context_Id) = Ref_Id;
29123 return Ref_Id = Context_Id;
29126 -- Otherwise the reference denotes a protected or a task type. Climb the
29127 -- scope chain looking for an enclosing concurrent type that matches the
29128 -- referenced entity.
29131 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
29133 S := Current_Scope;
29134 while Present (S) and then S /= Standard_Standard loop
29135 if Ekind_In (S, E_Protected_Type, E_Task_Type)
29136 and then S = Ref_Id
29146 end Is_CCT_Instance;
29148 -------------------------------
29149 -- Is_Elaboration_SPARK_Mode --
29150 -------------------------------
29152 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
29155 (Nkind (N) = N_Pragma
29156 and then Pragma_Name (N) = Name_SPARK_Mode
29157 and then Is_List_Member (N));
29159 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29160 -- appears in the statement part of the body.
29163 Present (Parent (N))
29164 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
29165 and then List_Containing (N) = Statements (Parent (N))
29166 and then Present (Parent (Parent (N)))
29167 and then Nkind (Parent (Parent (N))) = N_Package_Body;
29168 end Is_Elaboration_SPARK_Mode;
29170 -----------------------
29171 -- Is_Enabled_Pragma --
29172 -----------------------
29174 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
29178 if Present (Prag) then
29179 Arg := First (Pragma_Argument_Associations (Prag));
29181 if Present (Arg) then
29182 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
29184 -- The lack of a Boolean argument automatically enables the pragma
29190 -- The pragma is missing, therefore it is not enabled
29195 end Is_Enabled_Pragma;
29197 -----------------------------------------
29198 -- Is_Non_Significant_Pragma_Reference --
29199 -----------------------------------------
29201 -- This function makes use of the following static table which indicates
29202 -- whether appearance of some name in a given pragma is to be considered
29203 -- as a reference for the purposes of warnings about unreferenced objects.
29205 -- -1 indicates that appearence in any argument is significant
29206 -- 0 indicates that appearance in any argument is not significant
29207 -- +n indicates that appearance as argument n is significant, but all
29208 -- other arguments are not significant
29209 -- 9n arguments from n on are significant, before n insignificant
29211 Sig_Flags : constant array (Pragma_Id) of Int :=
29212 (Pragma_Abort_Defer => -1,
29213 Pragma_Abstract_State => -1,
29214 Pragma_Ada_83 => -1,
29215 Pragma_Ada_95 => -1,
29216 Pragma_Ada_05 => -1,
29217 Pragma_Ada_2005 => -1,
29218 Pragma_Ada_12 => -1,
29219 Pragma_Ada_2012 => -1,
29220 Pragma_All_Calls_Remote => -1,
29221 Pragma_Allow_Integer_Address => -1,
29222 Pragma_Annotate => 93,
29223 Pragma_Assert => -1,
29224 Pragma_Assert_And_Cut => -1,
29225 Pragma_Assertion_Policy => 0,
29226 Pragma_Assume => -1,
29227 Pragma_Assume_No_Invalid_Values => 0,
29228 Pragma_Async_Readers => 0,
29229 Pragma_Async_Writers => 0,
29230 Pragma_Asynchronous => 0,
29231 Pragma_Atomic => 0,
29232 Pragma_Atomic_Components => 0,
29233 Pragma_Attach_Handler => -1,
29234 Pragma_Attribute_Definition => 92,
29235 Pragma_Check => -1,
29236 Pragma_Check_Float_Overflow => 0,
29237 Pragma_Check_Name => 0,
29238 Pragma_Check_Policy => 0,
29239 Pragma_CPP_Class => 0,
29240 Pragma_CPP_Constructor => 0,
29241 Pragma_CPP_Virtual => 0,
29242 Pragma_CPP_Vtable => 0,
29244 Pragma_C_Pass_By_Copy => 0,
29245 Pragma_Comment => -1,
29246 Pragma_Common_Object => 0,
29247 Pragma_Compile_Time_Error => -1,
29248 Pragma_Compile_Time_Warning => -1,
29249 Pragma_Compiler_Unit => -1,
29250 Pragma_Compiler_Unit_Warning => -1,
29251 Pragma_Complete_Representation => 0,
29252 Pragma_Complex_Representation => 0,
29253 Pragma_Component_Alignment => 0,
29254 Pragma_Constant_After_Elaboration => 0,
29255 Pragma_Contract_Cases => -1,
29256 Pragma_Controlled => 0,
29257 Pragma_Convention => 0,
29258 Pragma_Convention_Identifier => 0,
29259 Pragma_Deadline_Floor => -1,
29260 Pragma_Debug => -1,
29261 Pragma_Debug_Policy => 0,
29262 Pragma_Detect_Blocking => 0,
29263 Pragma_Default_Initial_Condition => -1,
29264 Pragma_Default_Scalar_Storage_Order => 0,
29265 Pragma_Default_Storage_Pool => 0,
29266 Pragma_Depends => -1,
29267 Pragma_Disable_Atomic_Synchronization => 0,
29268 Pragma_Discard_Names => 0,
29269 Pragma_Dispatching_Domain => -1,
29270 Pragma_Effective_Reads => 0,
29271 Pragma_Effective_Writes => 0,
29272 Pragma_Elaborate => 0,
29273 Pragma_Elaborate_All => 0,
29274 Pragma_Elaborate_Body => 0,
29275 Pragma_Elaboration_Checks => 0,
29276 Pragma_Eliminate => 0,
29277 Pragma_Enable_Atomic_Synchronization => 0,
29278 Pragma_Export => -1,
29279 Pragma_Export_Function => -1,
29280 Pragma_Export_Object => -1,
29281 Pragma_Export_Procedure => -1,
29282 Pragma_Export_Value => -1,
29283 Pragma_Export_Valued_Procedure => -1,
29284 Pragma_Extend_System => -1,
29285 Pragma_Extensions_Allowed => 0,
29286 Pragma_Extensions_Visible => 0,
29287 Pragma_External => -1,
29288 Pragma_Favor_Top_Level => 0,
29289 Pragma_External_Name_Casing => 0,
29290 Pragma_Fast_Math => 0,
29291 Pragma_Finalize_Storage_Only => 0,
29293 Pragma_Global => -1,
29294 Pragma_Ident => -1,
29295 Pragma_Ignore_Pragma => 0,
29296 Pragma_Implementation_Defined => -1,
29297 Pragma_Implemented => -1,
29298 Pragma_Implicit_Packing => 0,
29299 Pragma_Import => 93,
29300 Pragma_Import_Function => 0,
29301 Pragma_Import_Object => 0,
29302 Pragma_Import_Procedure => 0,
29303 Pragma_Import_Valued_Procedure => 0,
29304 Pragma_Independent => 0,
29305 Pragma_Independent_Components => 0,
29306 Pragma_Initial_Condition => -1,
29307 Pragma_Initialize_Scalars => 0,
29308 Pragma_Initializes => -1,
29309 Pragma_Inline => 0,
29310 Pragma_Inline_Always => 0,
29311 Pragma_Inline_Generic => 0,
29312 Pragma_Inspection_Point => -1,
29313 Pragma_Interface => 92,
29314 Pragma_Interface_Name => 0,
29315 Pragma_Interrupt_Handler => -1,
29316 Pragma_Interrupt_Priority => -1,
29317 Pragma_Interrupt_State => -1,
29318 Pragma_Invariant => -1,
29319 Pragma_Keep_Names => 0,
29320 Pragma_License => 0,
29321 Pragma_Link_With => -1,
29322 Pragma_Linker_Alias => -1,
29323 Pragma_Linker_Constructor => -1,
29324 Pragma_Linker_Destructor => -1,
29325 Pragma_Linker_Options => -1,
29326 Pragma_Linker_Section => 0,
29328 Pragma_Lock_Free => 0,
29329 Pragma_Locking_Policy => 0,
29330 Pragma_Loop_Invariant => -1,
29331 Pragma_Loop_Optimize => 0,
29332 Pragma_Loop_Variant => -1,
29333 Pragma_Machine_Attribute => -1,
29335 Pragma_Main_Storage => -1,
29336 Pragma_Max_Queue_Length => 0,
29337 Pragma_Memory_Size => 0,
29338 Pragma_No_Return => 0,
29339 Pragma_No_Body => 0,
29340 Pragma_No_Component_Reordering => -1,
29341 Pragma_No_Elaboration_Code_All => 0,
29342 Pragma_No_Heap_Finalization => 0,
29343 Pragma_No_Inline => 0,
29344 Pragma_No_Run_Time => -1,
29345 Pragma_No_Strict_Aliasing => -1,
29346 Pragma_No_Tagged_Streams => 0,
29347 Pragma_Normalize_Scalars => 0,
29348 Pragma_Obsolescent => 0,
29349 Pragma_Optimize => 0,
29350 Pragma_Optimize_Alignment => 0,
29351 Pragma_Overflow_Mode => 0,
29352 Pragma_Overriding_Renamings => 0,
29353 Pragma_Ordered => 0,
29356 Pragma_Part_Of => 0,
29357 Pragma_Partition_Elaboration_Policy => 0,
29358 Pragma_Passive => 0,
29359 Pragma_Persistent_BSS => 0,
29360 Pragma_Polling => 0,
29361 Pragma_Prefix_Exception_Messages => 0,
29363 Pragma_Postcondition => -1,
29364 Pragma_Post_Class => -1,
29366 Pragma_Precondition => -1,
29367 Pragma_Predicate => -1,
29368 Pragma_Predicate_Failure => -1,
29369 Pragma_Preelaborable_Initialization => -1,
29370 Pragma_Preelaborate => 0,
29371 Pragma_Pre_Class => -1,
29372 Pragma_Priority => -1,
29373 Pragma_Priority_Specific_Dispatching => 0,
29374 Pragma_Profile => 0,
29375 Pragma_Profile_Warnings => 0,
29376 Pragma_Propagate_Exceptions => 0,
29377 Pragma_Provide_Shift_Operators => 0,
29378 Pragma_Psect_Object => 0,
29380 Pragma_Pure_Function => 0,
29381 Pragma_Queuing_Policy => 0,
29382 Pragma_Rational => 0,
29383 Pragma_Ravenscar => 0,
29384 Pragma_Refined_Depends => -1,
29385 Pragma_Refined_Global => -1,
29386 Pragma_Refined_Post => -1,
29387 Pragma_Refined_State => -1,
29388 Pragma_Relative_Deadline => 0,
29389 Pragma_Rename_Pragma => 0,
29390 Pragma_Remote_Access_Type => -1,
29391 Pragma_Remote_Call_Interface => -1,
29392 Pragma_Remote_Types => -1,
29393 Pragma_Restricted_Run_Time => 0,
29394 Pragma_Restriction_Warnings => 0,
29395 Pragma_Restrictions => 0,
29396 Pragma_Reviewable => -1,
29397 Pragma_Secondary_Stack_Size => -1,
29398 Pragma_Short_Circuit_And_Or => 0,
29399 Pragma_Share_Generic => 0,
29400 Pragma_Shared => 0,
29401 Pragma_Shared_Passive => 0,
29402 Pragma_Short_Descriptors => 0,
29403 Pragma_Simple_Storage_Pool_Type => 0,
29404 Pragma_Source_File_Name => 0,
29405 Pragma_Source_File_Name_Project => 0,
29406 Pragma_Source_Reference => 0,
29407 Pragma_SPARK_Mode => 0,
29408 Pragma_Storage_Size => -1,
29409 Pragma_Storage_Unit => 0,
29410 Pragma_Static_Elaboration_Desired => 0,
29411 Pragma_Stream_Convert => 0,
29412 Pragma_Style_Checks => 0,
29413 Pragma_Subtitle => 0,
29414 Pragma_Suppress => 0,
29415 Pragma_Suppress_Exception_Locations => 0,
29416 Pragma_Suppress_All => 0,
29417 Pragma_Suppress_Debug_Info => 0,
29418 Pragma_Suppress_Initialization => 0,
29419 Pragma_System_Name => 0,
29420 Pragma_Task_Dispatching_Policy => 0,
29421 Pragma_Task_Info => -1,
29422 Pragma_Task_Name => -1,
29423 Pragma_Task_Storage => -1,
29424 Pragma_Test_Case => -1,
29425 Pragma_Thread_Local_Storage => -1,
29426 Pragma_Time_Slice => -1,
29428 Pragma_Type_Invariant => -1,
29429 Pragma_Type_Invariant_Class => -1,
29430 Pragma_Unchecked_Union => 0,
29431 Pragma_Unevaluated_Use_Of_Old => 0,
29432 Pragma_Unimplemented_Unit => 0,
29433 Pragma_Universal_Aliasing => 0,
29434 Pragma_Universal_Data => 0,
29435 Pragma_Unmodified => 0,
29436 Pragma_Unreferenced => 0,
29437 Pragma_Unreferenced_Objects => 0,
29438 Pragma_Unreserve_All_Interrupts => 0,
29439 Pragma_Unsuppress => 0,
29440 Pragma_Unused => 0,
29441 Pragma_Use_VADS_Size => 0,
29442 Pragma_Validity_Checks => 0,
29443 Pragma_Volatile => 0,
29444 Pragma_Volatile_Components => 0,
29445 Pragma_Volatile_Full_Access => 0,
29446 Pragma_Volatile_Function => 0,
29447 Pragma_Warning_As_Error => 0,
29448 Pragma_Warnings => 0,
29449 Pragma_Weak_External => 0,
29450 Pragma_Wide_Character_Encoding => 0,
29451 Unknown_Pragma => 0);
29453 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
29459 function Arg_No return Nat;
29460 -- Returns an integer showing what argument we are in. A value of
29461 -- zero means we are not in any of the arguments.
29467 function Arg_No return Nat is
29472 A := First (Pragma_Argument_Associations (Parent (P)));
29486 -- Start of processing for Non_Significant_Pragma_Reference
29491 if Nkind (P) /= N_Pragma_Argument_Association then
29495 Id := Get_Pragma_Id (Parent (P));
29496 C := Sig_Flags (Id);
29511 return AN < (C - 90);
29517 end Is_Non_Significant_Pragma_Reference;
29519 ------------------------------
29520 -- Is_Pragma_String_Literal --
29521 ------------------------------
29523 -- This function returns true if the corresponding pragma argument is a
29524 -- static string expression. These are the only cases in which string
29525 -- literals can appear as pragma arguments. We also allow a string literal
29526 -- as the first argument to pragma Assert (although it will of course
29527 -- always generate a type error).
29529 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
29530 Pragn : constant Node_Id := Parent (Par);
29531 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
29532 Pname : constant Name_Id := Pragma_Name (Pragn);
29538 N := First (Assoc);
29545 if Pname = Name_Assert then
29548 elsif Pname = Name_Export then
29551 elsif Pname = Name_Ident then
29554 elsif Pname = Name_Import then
29557 elsif Pname = Name_Interface_Name then
29560 elsif Pname = Name_Linker_Alias then
29563 elsif Pname = Name_Linker_Section then
29566 elsif Pname = Name_Machine_Attribute then
29569 elsif Pname = Name_Source_File_Name then
29572 elsif Pname = Name_Source_Reference then
29575 elsif Pname = Name_Title then
29578 elsif Pname = Name_Subtitle then
29584 end Is_Pragma_String_Literal;
29586 ---------------------------
29587 -- Is_Private_SPARK_Mode --
29588 ---------------------------
29590 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
29593 (Nkind (N) = N_Pragma
29594 and then Pragma_Name (N) = Name_SPARK_Mode
29595 and then Is_List_Member (N));
29597 -- For pragma SPARK_Mode to be private, it has to appear in the private
29598 -- declarations of a package.
29601 Present (Parent (N))
29602 and then Nkind (Parent (N)) = N_Package_Specification
29603 and then List_Containing (N) = Private_Declarations (Parent (N));
29604 end Is_Private_SPARK_Mode;
29606 -------------------------------------
29607 -- Is_Unconstrained_Or_Tagged_Item --
29608 -------------------------------------
29610 function Is_Unconstrained_Or_Tagged_Item
29611 (Item : Entity_Id) return Boolean
29613 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
29614 -- Determine whether record type Typ has at least one unconstrained
29617 ---------------------------------
29618 -- Has_Unconstrained_Component --
29619 ---------------------------------
29621 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
29625 Comp := First_Component (Typ);
29626 while Present (Comp) loop
29627 if Is_Unconstrained_Or_Tagged_Item (Comp) then
29631 Next_Component (Comp);
29635 end Has_Unconstrained_Component;
29639 Typ : constant Entity_Id := Etype (Item);
29641 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29644 if Is_Tagged_Type (Typ) then
29647 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
29650 elsif Is_Record_Type (Typ) then
29651 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
29654 return Has_Unconstrained_Component (Typ);
29657 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
29663 end Is_Unconstrained_Or_Tagged_Item;
29665 -----------------------------
29666 -- Is_Valid_Assertion_Kind --
29667 -----------------------------
29669 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
29676 | Name_Assertion_Policy
29677 | Name_Static_Predicate
29678 | Name_Dynamic_Predicate
29683 | Name_Type_Invariant
29684 | Name_uType_Invariant
29688 | Name_Assert_And_Cut
29690 | Name_Contract_Cases
29692 | Name_Default_Initial_Condition
29694 | Name_Initial_Condition
29697 | Name_Loop_Invariant
29698 | Name_Loop_Variant
29699 | Name_Postcondition
29700 | Name_Precondition
29702 | Name_Refined_Post
29703 | Name_Statement_Assertions
29710 end Is_Valid_Assertion_Kind;
29712 --------------------------------------
29713 -- Process_Compilation_Unit_Pragmas --
29714 --------------------------------------
29716 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
29718 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29719 -- strange because it comes at the end of the unit. Rational has the
29720 -- same name for a pragma, but treats it as a program unit pragma, In
29721 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29722 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29723 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29724 -- the context clause to ensure the correct processing.
29726 if Has_Pragma_Suppress_All (N) then
29727 Prepend_To (Context_Items (N),
29728 Make_Pragma (Sloc (N),
29729 Chars => Name_Suppress,
29730 Pragma_Argument_Associations => New_List (
29731 Make_Pragma_Argument_Association (Sloc (N),
29732 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
29735 -- Nothing else to do at the current time
29737 end Process_Compilation_Unit_Pragmas;
29739 -------------------------------------------
29740 -- Process_Compile_Time_Warning_Or_Error --
29741 -------------------------------------------
29743 procedure Process_Compile_Time_Warning_Or_Error
29747 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
29748 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
29749 Arg2 : constant Node_Id := Next (Arg1);
29752 Analyze_And_Resolve (Arg1x, Standard_Boolean);
29754 if Compile_Time_Known_Value (Arg1x) then
29755 if Is_True (Expr_Value (Arg1x)) then
29757 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
29758 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
29759 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
29760 Str : constant String_Id := Strval (Get_Pragma_Arg (Arg2));
29761 Str_Len : constant Nat := String_Length (Str);
29763 Force : constant Boolean :=
29764 Prag_Id = Pragma_Compile_Time_Warning
29765 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
29766 and then (Ekind (Cent) /= E_Package
29767 or else not In_Private_Part (Cent));
29768 -- Set True if this is the warning case, and we are in the
29769 -- visible part of a package spec, or in a subprogram spec,
29770 -- in which case we want to force the client to see the
29771 -- warning, even though it is not in the main unit.
29779 -- Loop through segments of message separated by line feeds.
29780 -- We output these segments as separate messages with
29781 -- continuation marks for all but the first.
29786 Error_Msg_Strlen := 0;
29788 -- Loop to copy characters from argument to error message
29792 exit when Ptr > Str_Len;
29793 CC := Get_String_Char (Str, Ptr);
29796 -- Ignore wide chars ??? else store character
29798 if In_Character_Range (CC) then
29799 C := Get_Character (CC);
29800 exit when C = ASCII.LF;
29801 Error_Msg_Strlen := Error_Msg_Strlen + 1;
29802 Error_Msg_String (Error_Msg_Strlen) := C;
29806 -- Here with one line ready to go
29808 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
29810 -- If this is a warning in a spec, then we want clients
29811 -- to see the warning, so mark the message with the
29812 -- special sequence !! to force the warning. In the case
29813 -- of a package spec, we do not force this if we are in
29814 -- the private part of the spec.
29817 if Cont = False then
29818 Error_Msg ("<<~!!", Eloc);
29821 Error_Msg ("\<<~!!", Eloc);
29824 -- Error, rather than warning, or in a body, so we do not
29825 -- need to force visibility for client (error will be
29826 -- output in any case, and this is the situation in which
29827 -- we do not want a client to get a warning, since the
29828 -- warning is in the body or the spec private part).
29831 if Cont = False then
29832 Error_Msg ("<<~", Eloc);
29835 Error_Msg ("\<<~", Eloc);
29839 exit when Ptr > Str_Len;
29844 end Process_Compile_Time_Warning_Or_Error;
29846 ------------------------------------
29847 -- Record_Possible_Body_Reference --
29848 ------------------------------------
29850 procedure Record_Possible_Body_Reference
29851 (State_Id : Entity_Id;
29855 Spec_Id : Entity_Id;
29858 -- Ensure that we are dealing with a reference to a state
29860 pragma Assert (Ekind (State_Id) = E_Abstract_State);
29862 -- Climb the tree starting from the reference looking for a package body
29863 -- whose spec declares the referenced state. This criteria automatically
29864 -- excludes references in package specs which are legal. Note that it is
29865 -- not wise to emit an error now as the package body may lack pragma
29866 -- Refined_State or the referenced state may not be mentioned in the
29867 -- refinement. This approach avoids the generation of misleading errors.
29870 while Present (Context) loop
29871 if Nkind (Context) = N_Package_Body then
29872 Spec_Id := Corresponding_Spec (Context);
29874 if Present (Abstract_States (Spec_Id))
29875 and then Contains (Abstract_States (Spec_Id), State_Id)
29877 if No (Body_References (State_Id)) then
29878 Set_Body_References (State_Id, New_Elmt_List);
29881 Append_Elmt (Ref, To => Body_References (State_Id));
29886 Context := Parent (Context);
29888 end Record_Possible_Body_Reference;
29890 ------------------------------------------
29891 -- Relocate_Pragmas_To_Anonymous_Object --
29892 ------------------------------------------
29894 procedure Relocate_Pragmas_To_Anonymous_Object
29895 (Typ_Decl : Node_Id;
29896 Obj_Decl : Node_Id)
29900 Next_Decl : Node_Id;
29903 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
29904 Def := Protected_Definition (Typ_Decl);
29906 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
29907 Def := Task_Definition (Typ_Decl);
29910 -- The concurrent definition has a visible declaration list. Inspect it
29911 -- and relocate all canidate pragmas.
29913 if Present (Def) and then Present (Visible_Declarations (Def)) then
29914 Decl := First (Visible_Declarations (Def));
29915 while Present (Decl) loop
29917 -- Preserve the following declaration for iteration purposes due
29918 -- to possible relocation of a pragma.
29920 Next_Decl := Next (Decl);
29922 if Nkind (Decl) = N_Pragma
29923 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
29926 Insert_After (Obj_Decl, Decl);
29928 -- Skip internally generated code
29930 elsif not Comes_From_Source (Decl) then
29933 -- No candidate pragmas are available for relocation
29942 end Relocate_Pragmas_To_Anonymous_Object;
29944 ------------------------------
29945 -- Relocate_Pragmas_To_Body --
29946 ------------------------------
29948 procedure Relocate_Pragmas_To_Body
29949 (Subp_Body : Node_Id;
29950 Target_Body : Node_Id := Empty)
29952 procedure Relocate_Pragma (Prag : Node_Id);
29953 -- Remove a single pragma from its current list and add it to the
29954 -- declarations of the proper body (either Subp_Body or Target_Body).
29956 ---------------------
29957 -- Relocate_Pragma --
29958 ---------------------
29960 procedure Relocate_Pragma (Prag : Node_Id) is
29965 -- When subprogram stubs or expression functions are involves, the
29966 -- destination declaration list belongs to the proper body.
29968 if Present (Target_Body) then
29969 Target := Target_Body;
29971 Target := Subp_Body;
29974 Decls := Declarations (Target);
29978 Set_Declarations (Target, Decls);
29981 -- Unhook the pragma from its current list
29984 Prepend (Prag, Decls);
29985 end Relocate_Pragma;
29989 Body_Id : constant Entity_Id :=
29990 Defining_Unit_Name (Specification (Subp_Body));
29991 Next_Stmt : Node_Id;
29994 -- Start of processing for Relocate_Pragmas_To_Body
29997 -- Do not process a body that comes from a separate unit as no construct
29998 -- can possibly follow it.
30000 if not Is_List_Member (Subp_Body) then
30003 -- Do not relocate pragmas that follow a stub if the stub does not have
30006 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
30007 and then No (Target_Body)
30011 -- Do not process internally generated routine _Postconditions
30013 elsif Ekind (Body_Id) = E_Procedure
30014 and then Chars (Body_Id) = Name_uPostconditions
30019 -- Look at what is following the body. We are interested in certain kind
30020 -- of pragmas (either from source or byproducts of expansion) that can
30021 -- apply to a body [stub].
30023 Stmt := Next (Subp_Body);
30024 while Present (Stmt) loop
30026 -- Preserve the following statement for iteration purposes due to a
30027 -- possible relocation of a pragma.
30029 Next_Stmt := Next (Stmt);
30031 -- Move a candidate pragma following the body to the declarations of
30034 if Nkind (Stmt) = N_Pragma
30035 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
30038 -- If a source pragma Warnings follows the body, it applies to
30039 -- following statements and does not belong in the body.
30041 if Get_Pragma_Id (Stmt) = Pragma_Warnings
30042 and then Comes_From_Source (Stmt)
30046 Relocate_Pragma (Stmt);
30049 -- Skip internally generated code
30051 elsif not Comes_From_Source (Stmt) then
30054 -- No candidate pragmas are available for relocation
30062 end Relocate_Pragmas_To_Body;
30064 -------------------
30065 -- Resolve_State --
30066 -------------------
30068 procedure Resolve_State (N : Node_Id) is
30073 if Is_Entity_Name (N) and then Present (Entity (N)) then
30074 Func := Entity (N);
30076 -- Handle overloading of state names by functions. Traverse the
30077 -- homonym chain looking for an abstract state.
30079 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
30080 State := Homonym (Func);
30081 while Present (State) loop
30083 -- Resolve the overloading by setting the proper entity of the
30084 -- reference to that of the state.
30086 if Ekind (State) = E_Abstract_State then
30087 Set_Etype (N, Standard_Void_Type);
30088 Set_Entity (N, State);
30089 Set_Associated_Node (N, State);
30093 State := Homonym (State);
30096 -- A function can never act as a state. If the homonym chain does
30097 -- not contain a corresponding state, then something went wrong in
30098 -- the overloading mechanism.
30100 raise Program_Error;
30105 ----------------------------
30106 -- Rewrite_Assertion_Kind --
30107 ----------------------------
30109 procedure Rewrite_Assertion_Kind
30111 From_Policy : Boolean := False)
30117 if Nkind (N) = N_Attribute_Reference
30118 and then Attribute_Name (N) = Name_Class
30119 and then Nkind (Prefix (N)) = N_Identifier
30121 case Chars (Prefix (N)) is
30128 when Name_Type_Invariant =>
30129 Nam := Name_uType_Invariant;
30131 when Name_Invariant =>
30132 Nam := Name_uInvariant;
30138 -- Recommend standard use of aspect names Pre/Post
30140 elsif Nkind (N) = N_Identifier
30141 and then From_Policy
30142 and then Serious_Errors_Detected = 0
30143 and then not ASIS_Mode
30145 if Chars (N) = Name_Precondition
30146 or else Chars (N) = Name_Postcondition
30148 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
30150 ("\use Assertion_Policy and aspect names Pre/Post for "
30151 & "Ada2012 conformance?", N);
30157 if Nam /= No_Name then
30158 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
30160 end Rewrite_Assertion_Kind;
30168 Dummy := Dummy + 1;
30171 --------------------------------
30172 -- Set_Encoded_Interface_Name --
30173 --------------------------------
30175 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
30176 Str : constant String_Id := Strval (S);
30177 Len : constant Nat := String_Length (Str);
30182 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
30185 -- Stores encoded value of character code CC. The encoding we use an
30186 -- underscore followed by four lower case hex digits.
30192 procedure Encode is
30194 Store_String_Char (Get_Char_Code ('_'));
30196 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
30198 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
30200 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
30202 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
30205 -- Start of processing for Set_Encoded_Interface_Name
30208 -- If first character is asterisk, this is a link name, and we leave it
30209 -- completely unmodified. We also ignore null strings (the latter case
30210 -- happens only in error cases).
30213 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
30215 Set_Interface_Name (E, S);
30220 CC := Get_String_Char (Str, J);
30222 exit when not In_Character_Range (CC);
30224 C := Get_Character (CC);
30226 exit when C /= '_' and then C /= '$'
30227 and then C not in '0' .. '9'
30228 and then C not in 'a' .. 'z'
30229 and then C not in 'A' .. 'Z';
30232 Set_Interface_Name (E, S);
30240 -- Here we need to encode. The encoding we use as follows:
30241 -- three underscores + four hex digits (lower case)
30245 for J in 1 .. String_Length (Str) loop
30246 CC := Get_String_Char (Str, J);
30248 if not In_Character_Range (CC) then
30251 C := Get_Character (CC);
30253 if C = '_' or else C = '$'
30254 or else C in '0' .. '9'
30255 or else C in 'a' .. 'z'
30256 or else C in 'A' .. 'Z'
30258 Store_String_Char (CC);
30265 Set_Interface_Name (E,
30266 Make_String_Literal (Sloc (S),
30267 Strval => End_String));
30269 end Set_Encoded_Interface_Name;
30271 ------------------------
30272 -- Set_Elab_Unit_Name --
30273 ------------------------
30275 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
30280 if Nkind (N) = N_Identifier
30281 and then Nkind (With_Item) = N_Identifier
30283 Set_Entity (N, Entity (With_Item));
30285 elsif Nkind (N) = N_Selected_Component then
30286 Change_Selected_Component_To_Expanded_Name (N);
30287 Set_Entity (N, Entity (With_Item));
30288 Set_Entity (Selector_Name (N), Entity (N));
30290 Pref := Prefix (N);
30291 Scop := Scope (Entity (N));
30292 while Nkind (Pref) = N_Selected_Component loop
30293 Change_Selected_Component_To_Expanded_Name (Pref);
30294 Set_Entity (Selector_Name (Pref), Scop);
30295 Set_Entity (Pref, Scop);
30296 Pref := Prefix (Pref);
30297 Scop := Scope (Scop);
30300 Set_Entity (Pref, Scop);
30303 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
30304 end Set_Elab_Unit_Name;
30306 -------------------
30307 -- Test_Case_Arg --
30308 -------------------
30310 function Test_Case_Arg
30313 From_Aspect : Boolean := False) return Node_Id
30315 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
30320 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
30325 -- The caller requests the aspect argument
30327 if From_Aspect then
30328 if Present (Aspect)
30329 and then Nkind (Expression (Aspect)) = N_Aggregate
30331 Args := Expression (Aspect);
30333 -- "Name" and "Mode" may appear without an identifier as a
30334 -- positional association.
30336 if Present (Expressions (Args)) then
30337 Arg := First (Expressions (Args));
30339 if Present (Arg) and then Arg_Nam = Name_Name then
30347 if Present (Arg) and then Arg_Nam = Name_Mode then
30352 -- Some or all arguments may appear as component associatons
30354 if Present (Component_Associations (Args)) then
30355 Arg := First (Component_Associations (Args));
30356 while Present (Arg) loop
30357 if Chars (First (Choices (Arg))) = Arg_Nam then
30366 -- Otherwise retrieve the argument directly from the pragma
30369 Arg := First (Pragma_Argument_Associations (Prag));
30371 if Present (Arg) and then Arg_Nam = Name_Name then
30375 -- Skip argument "Name"
30379 if Present (Arg) and then Arg_Nam = Name_Mode then
30383 -- Skip argument "Mode"
30387 -- Arguments "Requires" and "Ensures" are optional and may not be
30390 while Present (Arg) loop
30391 if Chars (Arg) = Arg_Nam then