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);
1462 -- Output case (SPARK RM 6.1.5(10))
1467 Add_Item_To_Name_Buffer (Item_Id);
1468 Add_Str_To_Name_Buffer
1469 (" & is missing from output dependence list");
1471 Error_Msg := Name_Find;
1472 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1480 Item_Id : Entity_Id;
1482 -- Start of processing for Check_Usage
1485 if No (Subp_Items) then
1489 -- Each input or output of the subprogram must appear in a dependency
1492 Elmt := First_Elmt (Subp_Items);
1493 while Present (Elmt) loop
1494 Item := Node (Elmt);
1496 if Nkind (Item) = N_Defining_Identifier then
1499 Item_Id := Entity_Of (Item);
1502 -- The item does not appear in a dependency
1504 if Present (Item_Id)
1505 and then not Contains (Used_Items, Item_Id)
1507 if Is_Formal (Item_Id) then
1508 Usage_Error (Item_Id);
1510 -- The current instance of a protected type behaves as a formal
1511 -- parameter (SPARK RM 6.1.4).
1513 elsif Ekind (Item_Id) = E_Protected_Type
1514 or else Is_Single_Protected_Object (Item_Id)
1516 Usage_Error (Item_Id);
1518 -- The current instance of a task type behaves as a formal
1519 -- parameter (SPARK RM 6.1.4).
1521 elsif Ekind (Item_Id) = E_Task_Type
1522 or else Is_Single_Task_Object (Item_Id)
1524 -- The dependence of a task unit on itself is implicit and
1525 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1526 -- Emit an error if only one input/output is present.
1528 if Task_Input_Seen /= Task_Output_Seen then
1529 Usage_Error (Item_Id);
1532 -- States and global objects are not used properly only when
1533 -- the subprogram is subject to pragma Global.
1535 elsif Global_Seen then
1536 Usage_Error (Item_Id);
1544 ----------------------
1545 -- Normalize_Clause --
1546 ----------------------
1548 procedure Normalize_Clause (Clause : Node_Id) is
1549 procedure Create_Or_Modify_Clause
1555 Multiple : Boolean);
1556 -- Create a brand new clause to represent the self-reference or
1557 -- modify the input and/or output lists of an existing clause. Output
1558 -- denotes a self-referencial output. Outputs is the output list of a
1559 -- clause. Inputs is the input list of a clause. After denotes the
1560 -- clause after which the new clause is to be inserted. Flag In_Place
1561 -- should be set when normalizing the last output of an output list.
1562 -- Flag Multiple should be set when Output comes from a list with
1565 -----------------------------
1566 -- Create_Or_Modify_Clause --
1567 -----------------------------
1569 procedure Create_Or_Modify_Clause
1577 procedure Propagate_Output
1580 -- Handle the various cases of output propagation to the input
1581 -- list. Output denotes a self-referencial output item. Inputs
1582 -- is the input list of a clause.
1584 ----------------------
1585 -- Propagate_Output --
1586 ----------------------
1588 procedure Propagate_Output
1592 function In_Input_List
1594 Inputs : List_Id) return Boolean;
1595 -- Determine whether a particulat item appears in the input
1596 -- list of a clause.
1602 function In_Input_List
1604 Inputs : List_Id) return Boolean
1609 Elmt := First (Inputs);
1610 while Present (Elmt) loop
1611 if Entity_Of (Elmt) = Item then
1623 Output_Id : constant Entity_Id := Entity_Of (Output);
1626 -- Start of processing for Propagate_Output
1629 -- The clause is of the form:
1631 -- (Output =>+ null)
1633 -- Remove null input and replace it with a copy of the output:
1635 -- (Output => Output)
1637 if Nkind (Inputs) = N_Null then
1638 Rewrite (Inputs, New_Copy_Tree (Output));
1640 -- The clause is of the form:
1642 -- (Output =>+ (Input1, ..., InputN))
1644 -- Determine whether the output is not already mentioned in the
1645 -- input list and if not, add it to the list of inputs:
1647 -- (Output => (Output, Input1, ..., InputN))
1649 elsif Nkind (Inputs) = N_Aggregate then
1650 Grouped := Expressions (Inputs);
1652 if not In_Input_List
1656 Prepend_To (Grouped, New_Copy_Tree (Output));
1659 -- The clause is of the form:
1661 -- (Output =>+ Input)
1663 -- If the input does not mention the output, group the two
1666 -- (Output => (Output, Input))
1668 elsif Entity_Of (Inputs) /= Output_Id then
1670 Make_Aggregate (Loc,
1671 Expressions => New_List (
1672 New_Copy_Tree (Output),
1673 New_Copy_Tree (Inputs))));
1675 end Propagate_Output;
1679 Loc : constant Source_Ptr := Sloc (Clause);
1680 New_Clause : Node_Id;
1682 -- Start of processing for Create_Or_Modify_Clause
1685 -- A null output depending on itself does not require any
1688 if Nkind (Output) = N_Null then
1691 -- A function result cannot depend on itself because it cannot
1692 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1694 elsif Is_Attribute_Result (Output) then
1695 SPARK_Msg_N ("function result cannot depend on itself", Output);
1699 -- When performing the transformation in place, simply add the
1700 -- output to the list of inputs (if not already there). This
1701 -- case arises when dealing with the last output of an output
1702 -- list. Perform the normalization in place to avoid generating
1703 -- a malformed tree.
1706 Propagate_Output (Output, Inputs);
1708 -- A list with multiple outputs is slowly trimmed until only
1709 -- one element remains. When this happens, replace aggregate
1710 -- with the element itself.
1714 Rewrite (Outputs, Output);
1720 -- Unchain the output from its output list as it will appear in
1721 -- a new clause. Note that we cannot simply rewrite the output
1722 -- as null because this will violate the semantics of pragma
1727 -- Generate a new clause of the form:
1728 -- (Output => Inputs)
1731 Make_Component_Association (Loc,
1732 Choices => New_List (Output),
1733 Expression => New_Copy_Tree (Inputs));
1735 -- The new clause contains replicated content that has already
1736 -- been analyzed. There is not need to reanalyze or renormalize
1739 Set_Analyzed (New_Clause);
1742 (Output => First (Choices (New_Clause)),
1743 Inputs => Expression (New_Clause));
1745 Insert_After (After, New_Clause);
1747 end Create_Or_Modify_Clause;
1751 Outputs : constant Node_Id := First (Choices (Clause));
1753 Last_Output : Node_Id;
1754 Next_Output : Node_Id;
1757 -- Start of processing for Normalize_Clause
1760 -- A self-dependency appears as operator "+". Remove the "+" from the
1761 -- tree by moving the real inputs to their proper place.
1763 if Nkind (Expression (Clause)) = N_Op_Plus then
1764 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1765 Inputs := Expression (Clause);
1767 -- Multiple outputs appear as an aggregate
1769 if Nkind (Outputs) = N_Aggregate then
1770 Last_Output := Last (Expressions (Outputs));
1772 Output := First (Expressions (Outputs));
1773 while Present (Output) loop
1775 -- Normalization may remove an output from its list,
1776 -- preserve the subsequent output now.
1778 Next_Output := Next (Output);
1780 Create_Or_Modify_Clause
1785 In_Place => Output = Last_Output,
1788 Output := Next_Output;
1794 Create_Or_Modify_Clause
1803 end Normalize_Clause;
1807 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1808 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1812 Last_Clause : Node_Id;
1813 Restore_Scope : Boolean := False;
1815 -- Start of processing for Analyze_Depends_In_Decl_Part
1818 -- Do not analyze the pragma multiple times
1820 if Is_Analyzed_Pragma (N) then
1824 -- Empty dependency list
1826 if Nkind (Deps) = N_Null then
1828 -- Gather all states, objects and formal parameters that the
1829 -- subprogram may depend on. These items are obtained from the
1830 -- parameter profile or pragma [Refined_]Global (if available).
1832 Collect_Subprogram_Inputs_Outputs
1833 (Subp_Id => Subp_Id,
1834 Subp_Inputs => Subp_Inputs,
1835 Subp_Outputs => Subp_Outputs,
1836 Global_Seen => Global_Seen);
1838 -- Verify that every input or output of the subprogram appear in a
1841 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1842 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1843 Check_Function_Return;
1845 -- Dependency clauses appear as component associations of an aggregate
1847 elsif Nkind (Deps) = N_Aggregate then
1849 -- Do not attempt to perform analysis of a syntactically illegal
1850 -- clause as this will lead to misleading errors.
1852 if Has_Extra_Parentheses (Deps) then
1856 if Present (Component_Associations (Deps)) then
1857 Last_Clause := Last (Component_Associations (Deps));
1859 -- Gather all states, objects and formal parameters that the
1860 -- subprogram may depend on. These items are obtained from the
1861 -- parameter profile or pragma [Refined_]Global (if available).
1863 Collect_Subprogram_Inputs_Outputs
1864 (Subp_Id => Subp_Id,
1865 Subp_Inputs => Subp_Inputs,
1866 Subp_Outputs => Subp_Outputs,
1867 Global_Seen => Global_Seen);
1869 -- When pragma [Refined_]Depends appears on a single concurrent
1870 -- type, it is relocated to the anonymous object.
1872 if Is_Single_Concurrent_Object (Spec_Id) then
1875 -- Ensure that the formal parameters are visible when analyzing
1876 -- all clauses. This falls out of the general rule of aspects
1877 -- pertaining to subprogram declarations.
1879 elsif not In_Open_Scopes (Spec_Id) then
1880 Restore_Scope := True;
1881 Push_Scope (Spec_Id);
1883 if Ekind (Spec_Id) = E_Task_Type then
1884 if Has_Discriminants (Spec_Id) then
1885 Install_Discriminants (Spec_Id);
1888 elsif Is_Generic_Subprogram (Spec_Id) then
1889 Install_Generic_Formals (Spec_Id);
1892 Install_Formals (Spec_Id);
1896 Clause := First (Component_Associations (Deps));
1897 while Present (Clause) loop
1898 Errors := Serious_Errors_Detected;
1900 -- The normalization mechanism may create extra clauses that
1901 -- contain replicated input and output names. There is no need
1902 -- to reanalyze them.
1904 if not Analyzed (Clause) then
1905 Set_Analyzed (Clause);
1907 Analyze_Dependency_Clause
1909 Is_Last => Clause = Last_Clause);
1912 -- Do not normalize a clause if errors were detected (count
1913 -- of Serious_Errors has increased) because the inputs and/or
1914 -- outputs may denote illegal items. Normalization is disabled
1915 -- in ASIS mode as it alters the tree by introducing new nodes
1916 -- similar to expansion.
1918 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1919 Normalize_Clause (Clause);
1925 if Restore_Scope then
1929 -- Verify that every input or output of the subprogram appear in a
1932 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1933 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1934 Check_Function_Return;
1936 -- The dependency list is malformed. This is a syntax error, always
1940 Error_Msg_N ("malformed dependency relation", Deps);
1944 -- The top level dependency relation is malformed. This is a syntax
1945 -- error, always report.
1948 Error_Msg_N ("malformed dependency relation", Deps);
1952 -- Ensure that a state and a corresponding constituent do not appear
1953 -- together in pragma [Refined_]Depends.
1955 Check_State_And_Constituent_Use
1956 (States => States_Seen,
1957 Constits => Constits_Seen,
1961 Set_Is_Analyzed_Pragma (N);
1962 end Analyze_Depends_In_Decl_Part;
1964 --------------------------------------------
1965 -- Analyze_External_Property_In_Decl_Part --
1966 --------------------------------------------
1968 procedure Analyze_External_Property_In_Decl_Part
1970 Expr_Val : out Boolean)
1972 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1973 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1974 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1980 -- Do not analyze the pragma multiple times
1982 if Is_Analyzed_Pragma (N) then
1986 Error_Msg_Name_1 := Pragma_Name (N);
1988 -- An external property pragma must apply to an effectively volatile
1989 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1990 -- The check is performed at the end of the declarative region due to a
1991 -- possible out-of-order arrangement of pragmas:
1994 -- pragma Async_Readers (Obj);
1995 -- pragma Volatile (Obj);
1997 if not Is_Effectively_Volatile (Obj_Id) then
1999 ("external property % must apply to a volatile object", N);
2002 -- Ensure that the Boolean expression (if present) is static. A missing
2003 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2007 if Present (Arg1) then
2008 Expr := Get_Pragma_Arg (Arg1);
2010 if Is_OK_Static_Expression (Expr) then
2011 Expr_Val := Is_True (Expr_Value (Expr));
2015 Set_Is_Analyzed_Pragma (N);
2016 end Analyze_External_Property_In_Decl_Part;
2018 ---------------------------------
2019 -- Analyze_Global_In_Decl_Part --
2020 ---------------------------------
2022 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2023 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2024 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2025 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2027 Constits_Seen : Elist_Id := No_Elist;
2028 -- A list containing the entities of all constituents processed so far.
2029 -- It aids in detecting illegal usage of a state and a corresponding
2030 -- constituent in pragma [Refinde_]Global.
2032 Seen : Elist_Id := No_Elist;
2033 -- A list containing the entities of all the items processed so far. It
2034 -- plays a role in detecting distinct entities.
2036 States_Seen : Elist_Id := No_Elist;
2037 -- A list containing the entities of all states processed so far. It
2038 -- helps in detecting illegal usage of a state and a corresponding
2039 -- constituent in pragma [Refined_]Global.
2041 In_Out_Seen : Boolean := False;
2042 Input_Seen : Boolean := False;
2043 Output_Seen : Boolean := False;
2044 Proof_Seen : Boolean := False;
2045 -- Flags used to verify the consistency of modes
2047 procedure Analyze_Global_List
2049 Global_Mode : Name_Id := Name_Input);
2050 -- Verify the legality of a single global list declaration. Global_Mode
2051 -- denotes the current mode in effect.
2053 -------------------------
2054 -- Analyze_Global_List --
2055 -------------------------
2057 procedure Analyze_Global_List
2059 Global_Mode : Name_Id := Name_Input)
2061 procedure Analyze_Global_Item
2063 Global_Mode : Name_Id);
2064 -- Verify the legality of a single global item declaration denoted by
2065 -- Item. Global_Mode denotes the current mode in effect.
2067 procedure Check_Duplicate_Mode
2069 Status : in out Boolean);
2070 -- Flag Status denotes whether a particular mode has been seen while
2071 -- processing a global list. This routine verifies that Mode is not a
2072 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2074 procedure Check_Mode_Restriction_In_Enclosing_Context
2076 Item_Id : Entity_Id);
2077 -- Verify that an item of mode In_Out or Output does not appear as an
2078 -- input in the Global aspect of an enclosing subprogram. If this is
2079 -- the case, emit an error. Item and Item_Id are respectively the
2080 -- item and its entity.
2082 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2083 -- Mode denotes either In_Out or Output. Depending on the kind of the
2084 -- related subprogram, emit an error if those two modes apply to a
2085 -- function (SPARK RM 6.1.4(10)).
2087 -------------------------
2088 -- Analyze_Global_Item --
2089 -------------------------
2091 procedure Analyze_Global_Item
2093 Global_Mode : Name_Id)
2095 Item_Id : Entity_Id;
2098 -- Detect one of the following cases
2100 -- with Global => (null, Name)
2101 -- with Global => (Name_1, null, Name_2)
2102 -- with Global => (Name, null)
2104 if Nkind (Item) = N_Null then
2105 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2110 Resolve_State (Item);
2112 -- Find the entity of the item. If this is a renaming, climb the
2113 -- renaming chain to reach the root object. Renamings of non-
2114 -- entire objects do not yield an entity (Empty).
2116 Item_Id := Entity_Of (Item);
2118 if Present (Item_Id) then
2120 -- A global item may denote a formal parameter of an enclosing
2121 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2122 -- provide a better error diagnostic.
2124 if Is_Formal (Item_Id) then
2125 if Scope (Item_Id) = Spec_Id then
2127 (Fix_Msg (Spec_Id, "global item cannot reference "
2128 & "parameter of subprogram &"), Item, Spec_Id);
2132 -- A global item may denote a concurrent type as long as it is
2133 -- the current instance of an enclosing protected or task type
2134 -- (SPARK RM 6.1.4).
2136 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2137 if Is_CCT_Instance (Item_Id, Spec_Id) then
2139 -- Pragma [Refined_]Global associated with a protected
2140 -- subprogram cannot mention the current instance of a
2141 -- protected type because the instance behaves as a
2142 -- formal parameter.
2144 if Ekind (Item_Id) = E_Protected_Type then
2145 Error_Msg_Name_1 := Chars (Item_Id);
2147 (Fix_Msg (Spec_Id, "global item of subprogram & "
2148 & "cannot reference current instance of protected "
2149 & "type %"), Item, Spec_Id);
2152 -- Pragma [Refined_]Global associated with a task type
2153 -- cannot mention the current instance of a task type
2154 -- because the instance behaves as a formal parameter.
2156 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2157 Error_Msg_Name_1 := Chars (Item_Id);
2159 (Fix_Msg (Spec_Id, "global item of subprogram & "
2160 & "cannot reference current instance of task type "
2161 & "%"), Item, Spec_Id);
2165 -- Otherwise the global item denotes a subtype mark that is
2166 -- not a current instance.
2170 ("invalid use of subtype mark in global list", Item);
2174 -- A global item may denote the anonymous object created for a
2175 -- single protected/task type as long as the current instance
2176 -- is the same single type (SPARK RM 6.1.4).
2178 elsif Is_Single_Concurrent_Object (Item_Id)
2179 and then Is_CCT_Instance (Item_Id, Spec_Id)
2181 -- Pragma [Refined_]Global associated with a protected
2182 -- subprogram cannot mention the current instance of a
2183 -- protected type because the instance behaves as a formal
2186 if Is_Single_Protected_Object (Item_Id) then
2187 Error_Msg_Name_1 := Chars (Item_Id);
2189 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2190 & "reference current instance of protected type %"),
2194 -- Pragma [Refined_]Global associated with a task type
2195 -- cannot mention the current instance of a task type
2196 -- because the instance behaves as a formal parameter.
2198 else pragma Assert (Is_Single_Task_Object (Item_Id));
2199 Error_Msg_Name_1 := Chars (Item_Id);
2201 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2202 & "reference current instance of task type %"),
2207 -- A formal object may act as a global item inside a generic
2209 elsif Is_Formal_Object (Item_Id) then
2212 -- The only legal references are those to abstract states,
2213 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2215 elsif not Ekind_In (Item_Id, E_Abstract_State,
2221 ("global item must denote object, state or current "
2222 & "instance of concurrent type", Item);
2226 -- State related checks
2228 if Ekind (Item_Id) = E_Abstract_State then
2230 -- Package and subprogram bodies are instantiated
2231 -- individually in a separate compiler pass. Due to this
2232 -- mode of instantiation, the refinement of a state may
2233 -- no longer be visible when a subprogram body contract
2234 -- is instantiated. Since the generic template is legal,
2235 -- do not perform this check in the instance to circumvent
2238 if Is_Generic_Instance (Spec_Id) then
2241 -- An abstract state with visible refinement cannot appear
2242 -- in pragma [Refined_]Global as its place must be taken by
2243 -- some of its constituents (SPARK RM 6.1.4(7)).
2245 elsif Has_Visible_Refinement (Item_Id) then
2247 ("cannot mention state & in global refinement",
2249 SPARK_Msg_N ("\use its constituents instead", Item);
2252 -- An external state cannot appear as a global item of a
2253 -- nonvolatile function (SPARK RM 7.1.3(8)).
2255 elsif Is_External_State (Item_Id)
2256 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2257 and then not Is_Volatile_Function (Spec_Id)
2260 ("external state & cannot act as global item of "
2261 & "nonvolatile function", Item, Item_Id);
2264 -- If the reference to the abstract state appears in an
2265 -- enclosing package body that will eventually refine the
2266 -- state, record the reference for future checks.
2269 Record_Possible_Body_Reference
2270 (State_Id => Item_Id,
2274 -- Constant related checks
2276 elsif Ekind (Item_Id) = E_Constant then
2278 -- A constant is a read-only item, therefore it cannot act
2281 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2283 ("constant & cannot act as output", Item, Item_Id);
2287 -- Loop parameter related checks
2289 elsif Ekind (Item_Id) = E_Loop_Parameter then
2291 -- A loop parameter is a read-only item, therefore it cannot
2292 -- act as an output.
2294 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2296 ("loop parameter & cannot act as output",
2301 -- Variable related checks. These are only relevant when
2302 -- SPARK_Mode is on as they are not standard Ada legality
2305 elsif SPARK_Mode = On
2306 and then Ekind (Item_Id) = E_Variable
2307 and then Is_Effectively_Volatile (Item_Id)
2309 -- An effectively volatile object cannot appear as a global
2310 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2312 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2313 and then not Is_Volatile_Function (Spec_Id)
2316 ("volatile object & cannot act as global item of a "
2317 & "function", Item, Item_Id);
2320 -- An effectively volatile object with external property
2321 -- Effective_Reads set to True must have mode Output or
2322 -- In_Out (SPARK RM 7.1.3(10)).
2324 elsif Effective_Reads_Enabled (Item_Id)
2325 and then Global_Mode = Name_Input
2328 ("volatile object & with property Effective_Reads must "
2329 & "have mode In_Out or Output", Item, Item_Id);
2334 -- When the item renames an entire object, replace the item
2335 -- with a reference to the object.
2337 if Entity (Item) /= Item_Id then
2338 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2342 -- Some form of illegal construct masquerading as a name
2343 -- (SPARK RM 6.1.4(4)).
2347 ("global item must denote object, state or current instance "
2348 & "of concurrent type", Item);
2352 -- Verify that an output does not appear as an input in an
2353 -- enclosing subprogram.
2355 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2356 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2359 -- The same entity might be referenced through various way.
2360 -- Check the entity of the item rather than the item itself
2361 -- (SPARK RM 6.1.4(10)).
2363 if Contains (Seen, Item_Id) then
2364 SPARK_Msg_N ("duplicate global item", Item);
2366 -- Add the entity of the current item to the list of processed
2370 Append_New_Elmt (Item_Id, Seen);
2372 if Ekind (Item_Id) = E_Abstract_State then
2373 Append_New_Elmt (Item_Id, States_Seen);
2375 -- The variable may eventually become a constituent of a single
2376 -- protected/task type. Record the reference now and verify its
2377 -- legality when analyzing the contract of the variable
2380 elsif Ekind (Item_Id) = E_Variable then
2381 Record_Possible_Part_Of_Reference
2386 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2387 and then Present (Encapsulating_State (Item_Id))
2389 Append_New_Elmt (Item_Id, Constits_Seen);
2392 end Analyze_Global_Item;
2394 --------------------------
2395 -- Check_Duplicate_Mode --
2396 --------------------------
2398 procedure Check_Duplicate_Mode
2400 Status : in out Boolean)
2404 SPARK_Msg_N ("duplicate global mode", Mode);
2408 end Check_Duplicate_Mode;
2410 -------------------------------------------------
2411 -- Check_Mode_Restriction_In_Enclosing_Context --
2412 -------------------------------------------------
2414 procedure Check_Mode_Restriction_In_Enclosing_Context
2416 Item_Id : Entity_Id)
2418 Context : Entity_Id;
2420 Inputs : Elist_Id := No_Elist;
2421 Outputs : Elist_Id := No_Elist;
2424 -- Traverse the scope stack looking for enclosing subprograms
2425 -- subject to pragma [Refined_]Global.
2427 Context := Scope (Subp_Id);
2428 while Present (Context) and then Context /= Standard_Standard loop
2429 if Is_Subprogram (Context)
2431 (Present (Get_Pragma (Context, Pragma_Global))
2433 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2435 Collect_Subprogram_Inputs_Outputs
2436 (Subp_Id => Context,
2437 Subp_Inputs => Inputs,
2438 Subp_Outputs => Outputs,
2439 Global_Seen => Dummy);
2441 -- The item is classified as In_Out or Output but appears as
2442 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2444 if Appears_In (Inputs, Item_Id)
2445 and then not Appears_In (Outputs, Item_Id)
2448 ("global item & cannot have mode In_Out or Output",
2452 (Fix_Msg (Subp_Id, "\item already appears as input of "
2453 & "subprogram &"), Item, Context);
2455 -- Stop the traversal once an error has been detected
2461 Context := Scope (Context);
2463 end Check_Mode_Restriction_In_Enclosing_Context;
2465 ----------------------------------------
2466 -- Check_Mode_Restriction_In_Function --
2467 ----------------------------------------
2469 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2471 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2473 ("global mode & is not applicable to functions", Mode);
2475 end Check_Mode_Restriction_In_Function;
2483 -- Start of processing for Analyze_Global_List
2486 if Nkind (List) = N_Null then
2487 Set_Analyzed (List);
2489 -- Single global item declaration
2491 elsif Nkind_In (List, N_Expanded_Name,
2493 N_Selected_Component)
2495 Analyze_Global_Item (List, Global_Mode);
2497 -- Simple global list or moded global list declaration
2499 elsif Nkind (List) = N_Aggregate then
2500 Set_Analyzed (List);
2502 -- The declaration of a simple global list appear as a collection
2505 if Present (Expressions (List)) then
2506 if Present (Component_Associations (List)) then
2508 ("cannot mix moded and non-moded global lists", List);
2511 Item := First (Expressions (List));
2512 while Present (Item) loop
2513 Analyze_Global_Item (Item, Global_Mode);
2517 -- The declaration of a moded global list appears as a collection
2518 -- of component associations where individual choices denote
2521 elsif Present (Component_Associations (List)) then
2522 if Present (Expressions (List)) then
2524 ("cannot mix moded and non-moded global lists", List);
2527 Assoc := First (Component_Associations (List));
2528 while Present (Assoc) loop
2529 Mode := First (Choices (Assoc));
2531 if Nkind (Mode) = N_Identifier then
2532 if Chars (Mode) = Name_In_Out then
2533 Check_Duplicate_Mode (Mode, In_Out_Seen);
2534 Check_Mode_Restriction_In_Function (Mode);
2536 elsif Chars (Mode) = Name_Input then
2537 Check_Duplicate_Mode (Mode, Input_Seen);
2539 elsif Chars (Mode) = Name_Output then
2540 Check_Duplicate_Mode (Mode, Output_Seen);
2541 Check_Mode_Restriction_In_Function (Mode);
2543 elsif Chars (Mode) = Name_Proof_In then
2544 Check_Duplicate_Mode (Mode, Proof_Seen);
2547 SPARK_Msg_N ("invalid mode selector", Mode);
2551 SPARK_Msg_N ("invalid mode selector", Mode);
2554 -- Items in a moded list appear as a collection of
2555 -- expressions. Reuse the existing machinery to analyze
2559 (List => Expression (Assoc),
2560 Global_Mode => Chars (Mode));
2568 raise Program_Error;
2571 -- Any other attempt to declare a global item is illegal. This is a
2572 -- syntax error, always report.
2575 Error_Msg_N ("malformed global list", List);
2577 end Analyze_Global_List;
2581 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2583 Restore_Scope : Boolean := False;
2585 -- Start of processing for Analyze_Global_In_Decl_Part
2588 -- Do not analyze the pragma multiple times
2590 if Is_Analyzed_Pragma (N) then
2594 -- There is nothing to be done for a null global list
2596 if Nkind (Items) = N_Null then
2597 Set_Analyzed (Items);
2599 -- Analyze the various forms of global lists and items. Note that some
2600 -- of these may be malformed in which case the analysis emits error
2604 -- When pragma [Refined_]Global appears on a single concurrent type,
2605 -- it is relocated to the anonymous object.
2607 if Is_Single_Concurrent_Object (Spec_Id) then
2610 -- Ensure that the formal parameters are visible when processing an
2611 -- item. This falls out of the general rule of aspects pertaining to
2612 -- subprogram declarations.
2614 elsif not In_Open_Scopes (Spec_Id) then
2615 Restore_Scope := True;
2616 Push_Scope (Spec_Id);
2618 if Ekind (Spec_Id) = E_Task_Type then
2619 if Has_Discriminants (Spec_Id) then
2620 Install_Discriminants (Spec_Id);
2623 elsif Is_Generic_Subprogram (Spec_Id) then
2624 Install_Generic_Formals (Spec_Id);
2627 Install_Formals (Spec_Id);
2631 Analyze_Global_List (Items);
2633 if Restore_Scope then
2638 -- Ensure that a state and a corresponding constituent do not appear
2639 -- together in pragma [Refined_]Global.
2641 Check_State_And_Constituent_Use
2642 (States => States_Seen,
2643 Constits => Constits_Seen,
2646 Set_Is_Analyzed_Pragma (N);
2647 end Analyze_Global_In_Decl_Part;
2649 --------------------------------------------
2650 -- Analyze_Initial_Condition_In_Decl_Part --
2651 --------------------------------------------
2653 -- WARNING: This routine manages Ghost regions. Return statements must be
2654 -- replaced by gotos which jump to the end of the routine and restore the
2657 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2658 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2659 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2660 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2662 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2663 -- Save the Ghost mode to restore on exit
2666 -- Do not analyze the pragma multiple times
2668 if Is_Analyzed_Pragma (N) then
2672 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2673 -- analysis of the pragma, the Ghost mode at point of declaration and
2674 -- point of analysis may not necessarily be the same. Use the mode in
2675 -- effect at the point of declaration.
2679 -- The expression is preanalyzed because it has not been moved to its
2680 -- final place yet. A direct analysis may generate side effects and this
2681 -- is not desired at this point.
2683 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2684 Set_Is_Analyzed_Pragma (N);
2686 Restore_Ghost_Mode (Saved_GM);
2687 end Analyze_Initial_Condition_In_Decl_Part;
2689 --------------------------------------
2690 -- Analyze_Initializes_In_Decl_Part --
2691 --------------------------------------
2693 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2694 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2695 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2697 Constits_Seen : Elist_Id := No_Elist;
2698 -- A list containing the entities of all constituents processed so far.
2699 -- It aids in detecting illegal usage of a state and a corresponding
2700 -- constituent in pragma Initializes.
2702 Items_Seen : Elist_Id := No_Elist;
2703 -- A list of all initialization items processed so far. This list is
2704 -- used to detect duplicate items.
2706 Non_Null_Seen : Boolean := False;
2707 Null_Seen : Boolean := False;
2708 -- Flags used to check the legality of a null initialization list
2710 States_And_Objs : Elist_Id := No_Elist;
2711 -- A list of all abstract states and objects declared in the visible
2712 -- declarations of the related package. This list is used to detect the
2713 -- legality of initialization items.
2715 States_Seen : Elist_Id := No_Elist;
2716 -- A list containing the entities of all states processed so far. It
2717 -- helps in detecting illegal usage of a state and a corresponding
2718 -- constituent in pragma Initializes.
2720 procedure Analyze_Initialization_Item (Item : Node_Id);
2721 -- Verify the legality of a single initialization item
2723 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2724 -- Verify the legality of a single initialization item followed by a
2725 -- list of input items.
2727 procedure Collect_States_And_Objects;
2728 -- Inspect the visible declarations of the related package and gather
2729 -- the entities of all abstract states and objects in States_And_Objs.
2731 ---------------------------------
2732 -- Analyze_Initialization_Item --
2733 ---------------------------------
2735 procedure Analyze_Initialization_Item (Item : Node_Id) is
2736 Item_Id : Entity_Id;
2739 -- Null initialization list
2741 if Nkind (Item) = N_Null then
2743 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2745 elsif Non_Null_Seen then
2747 ("cannot mix null and non-null initialization items", Item);
2752 -- Initialization item
2755 Non_Null_Seen := True;
2759 ("cannot mix null and non-null initialization items", Item);
2763 Resolve_State (Item);
2765 if Is_Entity_Name (Item) then
2766 Item_Id := Entity_Of (Item);
2768 if Ekind_In (Item_Id, E_Abstract_State,
2772 -- The state or variable must be declared in the visible
2773 -- declarations of the package (SPARK RM 7.1.5(7)).
2775 if not Contains (States_And_Objs, Item_Id) then
2776 Error_Msg_Name_1 := Chars (Pack_Id);
2778 ("initialization item & must appear in the visible "
2779 & "declarations of package %", Item, Item_Id);
2781 -- Detect a duplicate use of the same initialization item
2782 -- (SPARK RM 7.1.5(5)).
2784 elsif Contains (Items_Seen, Item_Id) then
2785 SPARK_Msg_N ("duplicate initialization item", Item);
2787 -- The item is legal, add it to the list of processed states
2791 Append_New_Elmt (Item_Id, Items_Seen);
2793 if Ekind (Item_Id) = E_Abstract_State then
2794 Append_New_Elmt (Item_Id, States_Seen);
2797 if Present (Encapsulating_State (Item_Id)) then
2798 Append_New_Elmt (Item_Id, Constits_Seen);
2802 -- The item references something that is not a state or object
2803 -- (SPARK RM 7.1.5(3)).
2807 ("initialization item must denote object or state", Item);
2810 -- Some form of illegal construct masquerading as a name
2811 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2815 ("initialization item must denote object or state", Item);
2818 end Analyze_Initialization_Item;
2820 ---------------------------------------------
2821 -- Analyze_Initialization_Item_With_Inputs --
2822 ---------------------------------------------
2824 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2825 Inputs_Seen : Elist_Id := No_Elist;
2826 -- A list of all inputs processed so far. This list is used to detect
2827 -- duplicate uses of an input.
2829 Non_Null_Seen : Boolean := False;
2830 Null_Seen : Boolean := False;
2831 -- Flags used to check the legality of an input list
2833 procedure Analyze_Input_Item (Input : Node_Id);
2834 -- Verify the legality of a single input item
2836 ------------------------
2837 -- Analyze_Input_Item --
2838 ------------------------
2840 procedure Analyze_Input_Item (Input : Node_Id) is
2841 Input_Id : Entity_Id;
2842 Input_OK : Boolean := True;
2847 if Nkind (Input) = N_Null then
2850 ("multiple null initializations not allowed", Item);
2852 elsif Non_Null_Seen then
2854 ("cannot mix null and non-null initialization item", Item);
2862 Non_Null_Seen := True;
2866 ("cannot mix null and non-null initialization item", Item);
2870 Resolve_State (Input);
2872 if Is_Entity_Name (Input) then
2873 Input_Id := Entity_Of (Input);
2875 if Ekind_In (Input_Id, E_Abstract_State,
2877 E_Generic_In_Out_Parameter,
2878 E_Generic_In_Parameter,
2884 -- The input cannot denote states or objects declared
2885 -- within the related package (SPARK RM 7.1.5(4)).
2887 if Within_Scope (Input_Id, Current_Scope) then
2889 -- Do not consider generic formal parameters or their
2890 -- respective mappings to generic formals. Even though
2891 -- the formals appear within the scope of the package,
2892 -- it is allowed for an initialization item to depend
2893 -- on an input item.
2895 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2896 E_Generic_In_Parameter)
2900 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2901 and then Present (Corresponding_Generic_Association
2902 (Declaration_Node (Input_Id)))
2908 Error_Msg_Name_1 := Chars (Pack_Id);
2910 ("input item & cannot denote a visible object or "
2911 & "state of package %", Input, Input_Id);
2915 -- Detect a duplicate use of the same input item
2916 -- (SPARK RM 7.1.5(5)).
2918 if Contains (Inputs_Seen, Input_Id) then
2920 SPARK_Msg_N ("duplicate input item", Input);
2923 -- Input is legal, add it to the list of processed inputs
2926 Append_New_Elmt (Input_Id, Inputs_Seen);
2928 if Ekind (Input_Id) = E_Abstract_State then
2929 Append_New_Elmt (Input_Id, States_Seen);
2932 if Ekind_In (Input_Id, E_Abstract_State,
2935 and then Present (Encapsulating_State (Input_Id))
2937 Append_New_Elmt (Input_Id, Constits_Seen);
2941 -- The input references something that is not a state or an
2942 -- object (SPARK RM 7.1.5(3)).
2946 ("input item must denote object or state", Input);
2949 -- Some form of illegal construct masquerading as a name
2950 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2954 ("input item must denote object or state", Input);
2957 end Analyze_Input_Item;
2961 Inputs : constant Node_Id := Expression (Item);
2965 Name_Seen : Boolean := False;
2966 -- A flag used to detect multiple item names
2968 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2971 -- Inspect the name of an item with inputs
2973 Elmt := First (Choices (Item));
2974 while Present (Elmt) loop
2976 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2979 Analyze_Initialization_Item (Elmt);
2985 -- Multiple input items appear as an aggregate
2987 if Nkind (Inputs) = N_Aggregate then
2988 if Present (Expressions (Inputs)) then
2989 Input := First (Expressions (Inputs));
2990 while Present (Input) loop
2991 Analyze_Input_Item (Input);
2996 if Present (Component_Associations (Inputs)) then
2998 ("inputs must appear in named association form", Inputs);
3001 -- Single input item
3004 Analyze_Input_Item (Inputs);
3006 end Analyze_Initialization_Item_With_Inputs;
3008 --------------------------------
3009 -- Collect_States_And_Objects --
3010 --------------------------------
3012 procedure Collect_States_And_Objects is
3013 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3017 -- Collect the abstract states defined in the package (if any)
3019 if Present (Abstract_States (Pack_Id)) then
3020 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3023 -- Collect all objects the appear in the visible declarations of the
3026 if Present (Visible_Declarations (Pack_Spec)) then
3027 Decl := First (Visible_Declarations (Pack_Spec));
3028 while Present (Decl) loop
3029 if Comes_From_Source (Decl)
3030 and then Nkind (Decl) = N_Object_Declaration
3032 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3038 end Collect_States_And_Objects;
3042 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3045 -- Start of processing for Analyze_Initializes_In_Decl_Part
3048 -- Do not analyze the pragma multiple times
3050 if Is_Analyzed_Pragma (N) then
3054 -- Nothing to do when the initialization list is empty
3056 if Nkind (Inits) = N_Null then
3060 -- Single and multiple initialization clauses appear as an aggregate. If
3061 -- this is not the case, then either the parser or the analysis of the
3062 -- pragma failed to produce an aggregate.
3064 pragma Assert (Nkind (Inits) = N_Aggregate);
3066 -- Initialize the various lists used during analysis
3068 Collect_States_And_Objects;
3070 if Present (Expressions (Inits)) then
3071 Init := First (Expressions (Inits));
3072 while Present (Init) loop
3073 Analyze_Initialization_Item (Init);
3078 if Present (Component_Associations (Inits)) then
3079 Init := First (Component_Associations (Inits));
3080 while Present (Init) loop
3081 Analyze_Initialization_Item_With_Inputs (Init);
3086 -- Ensure that a state and a corresponding constituent do not appear
3087 -- together in pragma Initializes.
3089 Check_State_And_Constituent_Use
3090 (States => States_Seen,
3091 Constits => Constits_Seen,
3094 Set_Is_Analyzed_Pragma (N);
3095 end Analyze_Initializes_In_Decl_Part;
3097 ---------------------
3098 -- Analyze_Part_Of --
3099 ---------------------
3101 procedure Analyze_Part_Of
3103 Item_Id : Entity_Id;
3105 Encap_Id : out Entity_Id;
3106 Legal : out Boolean)
3108 Encap_Typ : Entity_Id;
3109 Item_Decl : Node_Id;
3110 Pack_Id : Entity_Id;
3111 Placement : State_Space_Kind;
3112 Parent_Unit : Entity_Id;
3115 -- Assume that the indicator is illegal
3120 if Nkind_In (Encap, N_Expanded_Name,
3122 N_Selected_Component)
3125 Resolve_State (Encap);
3127 Encap_Id := Entity (Encap);
3129 -- The encapsulator is an abstract state
3131 if Ekind (Encap_Id) = E_Abstract_State then
3134 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3136 elsif Is_Single_Concurrent_Object (Encap_Id) then
3139 -- Otherwise the encapsulator is not a legal choice
3143 ("indicator Part_Of must denote abstract state, single "
3144 & "protected type or single task type", Encap);
3148 -- This is a syntax error, always report
3152 ("indicator Part_Of must denote abstract state, single protected "
3153 & "type or single task type", Encap);
3157 -- Catch a case where indicator Part_Of denotes the abstract view of a
3158 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3160 if From_Limited_With (Encap_Id)
3161 and then Present (Non_Limited_View (Encap_Id))
3162 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3164 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3165 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3169 -- The encapsulator is an abstract state
3171 if Ekind (Encap_Id) = E_Abstract_State then
3173 -- Determine where the object, package instantiation or state lives
3174 -- with respect to the enclosing packages or package bodies.
3176 Find_Placement_In_State_Space
3177 (Item_Id => Item_Id,
3178 Placement => Placement,
3179 Pack_Id => Pack_Id);
3181 -- The item appears in a non-package construct with a declarative
3182 -- part (subprogram, block, etc). As such, the item is not allowed
3183 -- to be a part of an encapsulating state because the item is not
3186 if Placement = Not_In_Package then
3188 ("indicator Part_Of cannot appear in this context "
3189 & "(SPARK RM 7.2.6(5))", Indic);
3190 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3192 ("\& is not part of the hidden state of package %",
3195 -- The item appears in the visible state space of some package. In
3196 -- general this scenario does not warrant Part_Of except when the
3197 -- package is a private child unit and the encapsulating state is
3198 -- declared in a parent unit or a public descendant of that parent
3201 elsif Placement = Visible_State_Space then
3202 if Is_Child_Unit (Pack_Id)
3203 and then Is_Private_Descendant (Pack_Id)
3205 -- A variable or state abstraction which is part of the visible
3206 -- state of a private child unit (or one of its public
3207 -- descendants) must have its Part_Of indicator specified. The
3208 -- Part_Of indicator must denote a state abstraction declared
3209 -- by either the parent unit of the private unit or by a public
3210 -- descendant of that parent unit.
3212 -- Find nearest private ancestor (which can be the current unit
3215 Parent_Unit := Pack_Id;
3216 while Present (Parent_Unit) loop
3219 (Parent (Unit_Declaration_Node (Parent_Unit)));
3220 Parent_Unit := Scope (Parent_Unit);
3223 Parent_Unit := Scope (Parent_Unit);
3225 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3227 ("indicator Part_Of must denote abstract state or public "
3228 & "descendant of & (SPARK RM 7.2.6(3))",
3229 Indic, Parent_Unit);
3231 elsif Scope (Encap_Id) = Parent_Unit
3233 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3234 and then not Is_Private_Descendant (Scope (Encap_Id)))
3240 ("indicator Part_Of must denote abstract state or public "
3241 & "descendant of & (SPARK RM 7.2.6(3))",
3242 Indic, Parent_Unit);
3245 -- Indicator Part_Of is not needed when the related package is not
3246 -- a private child unit or a public descendant thereof.
3250 ("indicator Part_Of cannot appear in this context "
3251 & "(SPARK RM 7.2.6(5))", Indic);
3252 Error_Msg_Name_1 := Chars (Pack_Id);
3254 ("\& is declared in the visible part of package %",
3258 -- When the item appears in the private state space of a package, the
3259 -- encapsulating state must be declared in the same package.
3261 elsif Placement = Private_State_Space then
3262 if Scope (Encap_Id) /= Pack_Id then
3264 ("indicator Part_Of must designate an abstract state of "
3265 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3266 Error_Msg_Name_1 := Chars (Pack_Id);
3268 ("\& is declared in the private part of package %",
3272 -- Items declared in the body state space of a package do not need
3273 -- Part_Of indicators as the refinement has already been seen.
3277 ("indicator Part_Of cannot appear in this context "
3278 & "(SPARK RM 7.2.6(5))", Indic);
3280 if Scope (Encap_Id) = Pack_Id then
3281 Error_Msg_Name_1 := Chars (Pack_Id);
3283 ("\& is declared in the body of package %", Indic, Item_Id);
3287 -- The encapsulator is a single concurrent type
3290 Encap_Typ := Etype (Encap_Id);
3292 -- Only abstract states and variables can act as constituents of an
3293 -- encapsulating single concurrent type.
3295 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3298 -- The constituent is a constant
3300 elsif Ekind (Item_Id) = E_Constant then
3301 Error_Msg_Name_1 := Chars (Encap_Id);
3303 (Fix_Msg (Encap_Typ, "constant & cannot act as constituent of "
3304 & "single protected type %"), Indic, Item_Id);
3306 -- The constituent is a package instantiation
3309 Error_Msg_Name_1 := Chars (Encap_Id);
3311 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3312 & "constituent of single protected type %"), Indic, Item_Id);
3315 -- When the item denotes an abstract state of a nested package, use
3316 -- the declaration of the package to detect proper placement.
3321 -- with Abstract_State => (State with Part_Of => T)
3323 if Ekind (Item_Id) = E_Abstract_State then
3324 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3326 Item_Decl := Declaration_Node (Item_Id);
3329 -- Both the item and its encapsulating single concurrent type must
3330 -- appear in the same declarative region (SPARK RM 9.3). Note that
3331 -- privacy is ignored.
3333 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3334 Error_Msg_Name_1 := Chars (Encap_Id);
3336 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3337 & "immediately within the same region as single protected "
3338 & "type %"), Indic, Item_Id);
3343 end Analyze_Part_Of;
3345 ----------------------------------
3346 -- Analyze_Part_Of_In_Decl_Part --
3347 ----------------------------------
3349 procedure Analyze_Part_Of_In_Decl_Part
3351 Freeze_Id : Entity_Id := Empty)
3353 Encap : constant Node_Id :=
3354 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3355 Errors : constant Nat := Serious_Errors_Detected;
3356 Var_Decl : constant Node_Id := Find_Related_Context (N);
3357 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3358 Constits : Elist_Id;
3359 Encap_Id : Entity_Id;
3363 -- Detect any discrepancies between the placement of the variable with
3364 -- respect to general state space and the encapsulating state or single
3371 Encap_Id => Encap_Id,
3374 -- The Part_Of indicator turns the variable into a constituent of the
3375 -- encapsulating state or single concurrent type.
3378 pragma Assert (Present (Encap_Id));
3379 Constits := Part_Of_Constituents (Encap_Id);
3381 if No (Constits) then
3382 Constits := New_Elmt_List;
3383 Set_Part_Of_Constituents (Encap_Id, Constits);
3386 Append_Elmt (Var_Id, Constits);
3387 Set_Encapsulating_State (Var_Id, Encap_Id);
3389 -- A Part_Of constituent partially refines an abstract state. This
3390 -- property does not apply to protected or task units.
3392 if Ekind (Encap_Id) = E_Abstract_State then
3393 Set_Has_Partial_Visible_Refinement (Encap_Id);
3397 -- Emit a clarification message when the encapsulator is undefined,
3398 -- possibly due to contract "freezing".
3400 if Errors /= Serious_Errors_Detected
3401 and then Present (Freeze_Id)
3402 and then Has_Undefined_Reference (Encap)
3404 Contract_Freeze_Error (Var_Id, Freeze_Id);
3406 end Analyze_Part_Of_In_Decl_Part;
3408 --------------------
3409 -- Analyze_Pragma --
3410 --------------------
3412 procedure Analyze_Pragma (N : Node_Id) is
3413 Loc : constant Source_Ptr := Sloc (N);
3415 Pname : Name_Id := Pragma_Name (N);
3416 -- Name of the source pragma, or name of the corresponding aspect for
3417 -- pragmas which originate in a source aspect. In the latter case, the
3418 -- name may be different from the pragma name.
3420 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3422 Pragma_Exit : exception;
3423 -- This exception is used to exit pragma processing completely. It
3424 -- is used when an error is detected, and no further processing is
3425 -- required. It is also used if an earlier error has left the tree in
3426 -- a state where the pragma should not be processed.
3429 -- Number of pragma argument associations
3435 -- First four pragma arguments (pragma argument association nodes, or
3436 -- Empty if the corresponding argument does not exist).
3438 type Name_List is array (Natural range <>) of Name_Id;
3439 type Args_List is array (Natural range <>) of Node_Id;
3440 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3442 -----------------------
3443 -- Local Subprograms --
3444 -----------------------
3446 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3447 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3448 -- get the given string argument, and place it in Name_Buffer, adding
3449 -- leading and trailing asterisks if they are not already present. The
3450 -- caller has already checked that Arg is a static string expression.
3452 procedure Ada_2005_Pragma;
3453 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3454 -- Ada 95 mode, these are implementation defined pragmas, so should be
3455 -- caught by the No_Implementation_Pragmas restriction.
3457 procedure Ada_2012_Pragma;
3458 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3459 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3460 -- should be caught by the No_Implementation_Pragmas restriction.
3462 procedure Analyze_Depends_Global
3463 (Spec_Id : out Entity_Id;
3464 Subp_Decl : out Node_Id;
3465 Legal : out Boolean);
3466 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3467 -- legality of the placement and related context of the pragma. Spec_Id
3468 -- is the entity of the related subprogram. Subp_Decl is the declaration
3469 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3471 procedure Analyze_If_Present (Id : Pragma_Id);
3472 -- Inspect the remainder of the list containing pragma N and look for
3473 -- a pragma that matches Id. If found, analyze the pragma.
3475 procedure Analyze_Pre_Post_Condition;
3476 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3478 procedure Analyze_Refined_Depends_Global_Post
3479 (Spec_Id : out Entity_Id;
3480 Body_Id : out Entity_Id;
3481 Legal : out Boolean);
3482 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3483 -- Refined_Global and Refined_Post. Verify the legality of the placement
3484 -- and related context of the pragma. Spec_Id is the entity of the
3485 -- related subprogram. Body_Id is the entity of the subprogram body.
3486 -- Flag Legal is set when the pragma is legal.
3488 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3489 -- Perform full analysis of pragma Unmodified and the write aspect of
3490 -- pragma Unused. Flag Is_Unused should be set when verifying the
3491 -- semantics of pragma Unused.
3493 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3494 -- Perform full analysis of pragma Unreferenced and the read aspect of
3495 -- pragma Unused. Flag Is_Unused should be set when verifying the
3496 -- semantics of pragma Unused.
3498 procedure Check_Ada_83_Warning;
3499 -- Issues a warning message for the current pragma if operating in Ada
3500 -- 83 mode (used for language pragmas that are not a standard part of
3501 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3504 procedure Check_Arg_Count (Required : Nat);
3505 -- Check argument count for pragma is equal to given parameter. If not,
3506 -- then issue an error message and raise Pragma_Exit.
3508 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3509 -- Arg which can either be a pragma argument association, in which case
3510 -- the check is applied to the expression of the association or an
3511 -- expression directly.
3513 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3514 -- Check that an argument has the right form for an EXTERNAL_NAME
3515 -- parameter of an extended import/export pragma. The rule is that the
3516 -- name must be an identifier or string literal (in Ada 83 mode) or a
3517 -- static string expression (in Ada 95 mode).
3519 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3520 -- Check the specified argument Arg to make sure that it is an
3521 -- identifier. If not give error and raise Pragma_Exit.
3523 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3524 -- Check the specified argument Arg to make sure that it is an integer
3525 -- literal. If not give error and raise Pragma_Exit.
3527 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3528 -- Check the specified argument Arg to make sure that it has the proper
3529 -- syntactic form for a local name and meets the semantic requirements
3530 -- for a local name. The local name is analyzed as part of the
3531 -- processing for this call. In addition, the local name is required
3532 -- to represent an entity at the library level.
3534 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3535 -- Check the specified argument Arg to make sure that it has the proper
3536 -- syntactic form for a local name and meets the semantic requirements
3537 -- for a local name. The local name is analyzed as part of the
3538 -- processing for this call.
3540 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3541 -- Check the specified argument Arg to make sure that it is a valid
3542 -- locking policy name. If not give error and raise Pragma_Exit.
3544 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3545 -- Check the specified argument Arg to make sure that it is a valid
3546 -- elaboration policy name. If not give error and raise Pragma_Exit.
3548 procedure Check_Arg_Is_One_Of
3551 procedure Check_Arg_Is_One_Of
3553 N1, N2, N3 : Name_Id);
3554 procedure Check_Arg_Is_One_Of
3556 N1, N2, N3, N4 : Name_Id);
3557 procedure Check_Arg_Is_One_Of
3559 N1, N2, N3, N4, N5 : Name_Id);
3560 -- Check the specified argument Arg to make sure that it is an
3561 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3562 -- present). If not then give error and raise Pragma_Exit.
3564 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3565 -- Check the specified argument Arg to make sure that it is a valid
3566 -- queuing policy name. If not give error and raise Pragma_Exit.
3568 procedure Check_Arg_Is_OK_Static_Expression
3570 Typ : Entity_Id := Empty);
3571 -- Check the specified argument Arg to make sure that it is a static
3572 -- expression of the given type (i.e. it will be analyzed and resolved
3573 -- using this type, which can be any valid argument to Resolve, e.g.
3574 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3575 -- Typ is left Empty, then any static expression is allowed. Includes
3576 -- checking that the argument does not raise Constraint_Error.
3578 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3579 -- Check the specified argument Arg to make sure that it is a valid task
3580 -- dispatching policy name. If not give error and raise Pragma_Exit.
3582 procedure Check_Arg_Order (Names : Name_List);
3583 -- Checks for an instance of two arguments with identifiers for the
3584 -- current pragma which are not in the sequence indicated by Names,
3585 -- and if so, generates a fatal message about bad order of arguments.
3587 procedure Check_At_Least_N_Arguments (N : Nat);
3588 -- Check there are at least N arguments present
3590 procedure Check_At_Most_N_Arguments (N : Nat);
3591 -- Check there are no more than N arguments present
3593 procedure Check_Component
3596 In_Variant_Part : Boolean := False);
3597 -- Examine an Unchecked_Union component for correct use of per-object
3598 -- constrained subtypes, and for restrictions on finalizable components.
3599 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3600 -- should be set when Comp comes from a record variant.
3602 procedure Check_Duplicate_Pragma (E : Entity_Id);
3603 -- Check if a rep item of the same name as the current pragma is already
3604 -- chained as a rep pragma to the given entity. If so give a message
3605 -- about the duplicate, and then raise Pragma_Exit so does not return.
3606 -- Note that if E is a type, then this routine avoids flagging a pragma
3607 -- which applies to a parent type from which E is derived.
3609 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3610 -- Nam is an N_String_Literal node containing the external name set by
3611 -- an Import or Export pragma (or extended Import or Export pragma).
3612 -- This procedure checks for possible duplications if this is the export
3613 -- case, and if found, issues an appropriate error message.
3615 procedure Check_Expr_Is_OK_Static_Expression
3617 Typ : Entity_Id := Empty);
3618 -- Check the specified expression Expr to make sure that it is a static
3619 -- expression of the given type (i.e. it will be analyzed and resolved
3620 -- using this type, which can be any valid argument to Resolve, e.g.
3621 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3622 -- Typ is left Empty, then any static expression is allowed. Includes
3623 -- checking that the expression does not raise Constraint_Error.
3625 procedure Check_First_Subtype (Arg : Node_Id);
3626 -- Checks that Arg, whose expression is an entity name, references a
3629 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3630 -- Checks that the given argument has an identifier, and if so, requires
3631 -- it to match the given identifier name. If there is no identifier, or
3632 -- a non-matching identifier, then an error message is given and
3633 -- Pragma_Exit is raised.
3635 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3636 -- Checks that the given argument has an identifier, and if so, requires
3637 -- it to match one of the given identifier names. If there is no
3638 -- identifier, or a non-matching identifier, then an error message is
3639 -- given and Pragma_Exit is raised.
3641 procedure Check_In_Main_Program;
3642 -- Common checks for pragmas that appear within a main program
3643 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3645 procedure Check_Interrupt_Or_Attach_Handler;
3646 -- Common processing for first argument of pragma Interrupt_Handler or
3647 -- pragma Attach_Handler.
3649 procedure Check_Loop_Pragma_Placement;
3650 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3651 -- appear immediately within a construct restricted to loops, and that
3652 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3654 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3655 -- Check that pragma appears in a declarative part, or in a package
3656 -- specification, i.e. that it does not occur in a statement sequence
3659 procedure Check_No_Identifier (Arg : Node_Id);
3660 -- Checks that the given argument does not have an identifier. If
3661 -- an identifier is present, then an error message is issued, and
3662 -- Pragma_Exit is raised.
3664 procedure Check_No_Identifiers;
3665 -- Checks that none of the arguments to the pragma has an identifier.
3666 -- If any argument has an identifier, then an error message is issued,
3667 -- and Pragma_Exit is raised.
3669 procedure Check_No_Link_Name;
3670 -- Checks that no link name is specified
3672 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3673 -- Checks if the given argument has an identifier, and if so, requires
3674 -- it to match the given identifier name. If there is a non-matching
3675 -- identifier, then an error message is given and Pragma_Exit is raised.
3677 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3678 -- Checks if the given argument has an identifier, and if so, requires
3679 -- it to match the given identifier name. If there is a non-matching
3680 -- identifier, then an error message is given and Pragma_Exit is raised.
3681 -- In this version of the procedure, the identifier name is given as
3682 -- a string with lower case letters.
3684 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3685 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3686 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3687 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3688 -- is an OK static boolean expression. Emit an error if this is not the
3691 procedure Check_Static_Constraint (Constr : Node_Id);
3692 -- Constr is a constraint from an N_Subtype_Indication node from a
3693 -- component constraint in an Unchecked_Union type. This routine checks
3694 -- that the constraint is static as required by the restrictions for
3697 procedure Check_Valid_Configuration_Pragma;
3698 -- Legality checks for placement of a configuration pragma
3700 procedure Check_Valid_Library_Unit_Pragma;
3701 -- Legality checks for library unit pragmas. A special case arises for
3702 -- pragmas in generic instances that come from copies of the original
3703 -- library unit pragmas in the generic templates. In the case of other
3704 -- than library level instantiations these can appear in contexts which
3705 -- would normally be invalid (they only apply to the original template
3706 -- and to library level instantiations), and they are simply ignored,
3707 -- which is implemented by rewriting them as null statements.
3709 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3710 -- Check an Unchecked_Union variant for lack of nested variants and
3711 -- presence of at least one component. UU_Typ is the related Unchecked_
3714 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3715 -- Subsidiary routine to the processing of pragmas Abstract_State,
3716 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3717 -- Refined_Global and Refined_State. Transform argument Arg into
3718 -- an aggregate if not one already. N_Null is never transformed.
3719 -- Arg may denote an aspect specification or a pragma argument
3722 procedure Error_Pragma (Msg : String);
3723 pragma No_Return (Error_Pragma);
3724 -- Outputs error message for current pragma. The message contains a %
3725 -- that will be replaced with the pragma name, and the flag is placed
3726 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3727 -- calls Fix_Error (see spec of that procedure for details).
3729 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3730 pragma No_Return (Error_Pragma_Arg);
3731 -- Outputs error message for current pragma. The message may contain
3732 -- a % that will be replaced with the pragma name. The parameter Arg
3733 -- may either be a pragma argument association, in which case the flag
3734 -- is placed on the expression of this association, or an expression,
3735 -- in which case the flag is placed directly on the expression. The
3736 -- message is placed using Error_Msg_N, so the message may also contain
3737 -- an & insertion character which will reference the given Arg value.
3738 -- After placing the message, Pragma_Exit is raised. Note: this routine
3739 -- calls Fix_Error (see spec of that procedure for details).
3741 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3742 pragma No_Return (Error_Pragma_Arg);
3743 -- Similar to above form of Error_Pragma_Arg except that two messages
3744 -- are provided, the second is a continuation comment starting with \.
3746 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3747 pragma No_Return (Error_Pragma_Arg_Ident);
3748 -- Outputs error message for current pragma. The message may contain a %
3749 -- that will be replaced with the pragma name. The parameter Arg must be
3750 -- a pragma argument association with a non-empty identifier (i.e. its
3751 -- Chars field must be set), and the error message is placed on the
3752 -- identifier. The message is placed using Error_Msg_N so the message
3753 -- may also contain an & insertion character which will reference
3754 -- the identifier. After placing the message, Pragma_Exit is raised.
3755 -- Note: this routine calls Fix_Error (see spec of that procedure for
3758 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3759 pragma No_Return (Error_Pragma_Ref);
3760 -- Outputs error message for current pragma. The message may contain
3761 -- a % that will be replaced with the pragma name. The parameter Ref
3762 -- must be an entity whose name can be referenced by & and sloc by #.
3763 -- After placing the message, Pragma_Exit is raised. Note: this routine
3764 -- calls Fix_Error (see spec of that procedure for details).
3766 function Find_Lib_Unit_Name return Entity_Id;
3767 -- Used for a library unit pragma to find the entity to which the
3768 -- library unit pragma applies, returns the entity found.
3770 procedure Find_Program_Unit_Name (Id : Node_Id);
3771 -- If the pragma is a compilation unit pragma, the id must denote the
3772 -- compilation unit in the same compilation, and the pragma must appear
3773 -- in the list of preceding or trailing pragmas. If it is a program
3774 -- unit pragma that is not a compilation unit pragma, then the
3775 -- identifier must be visible.
3777 function Find_Unique_Parameterless_Procedure
3779 Arg : Node_Id) return Entity_Id;
3780 -- Used for a procedure pragma to find the unique parameterless
3781 -- procedure identified by Name, returns it if it exists, otherwise
3782 -- errors out and uses Arg as the pragma argument for the message.
3784 function Fix_Error (Msg : String) return String;
3785 -- This is called prior to issuing an error message. Msg is the normal
3786 -- error message issued in the pragma case. This routine checks for the
3787 -- case of a pragma coming from an aspect in the source, and returns a
3788 -- message suitable for the aspect case as follows:
3790 -- Each substring "pragma" is replaced by "aspect"
3792 -- If "argument of" is at the start of the error message text, it is
3793 -- replaced by "entity for".
3795 -- If "argument" is at the start of the error message text, it is
3796 -- replaced by "entity".
3798 -- So for example, "argument of pragma X must be discrete type"
3799 -- returns "entity for aspect X must be a discrete type".
3801 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3802 -- be different from the pragma name). If the current pragma results
3803 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3804 -- original pragma name.
3806 procedure Gather_Associations
3808 Args : out Args_List);
3809 -- This procedure is used to gather the arguments for a pragma that
3810 -- permits arbitrary ordering of parameters using the normal rules
3811 -- for named and positional parameters. The Names argument is a list
3812 -- of Name_Id values that corresponds to the allowed pragma argument
3813 -- association identifiers in order. The result returned in Args is
3814 -- a list of corresponding expressions that are the pragma arguments.
3815 -- Note that this is a list of expressions, not of pragma argument
3816 -- associations (Gather_Associations has completely checked all the
3817 -- optional identifiers when it returns). An entry in Args is Empty
3818 -- on return if the corresponding argument is not present.
3820 procedure GNAT_Pragma;
3821 -- Called for all GNAT defined pragmas to check the relevant restriction
3822 -- (No_Implementation_Pragmas).
3824 function Is_Before_First_Decl
3825 (Pragma_Node : Node_Id;
3826 Decls : List_Id) return Boolean;
3827 -- Return True if Pragma_Node is before the first declarative item in
3828 -- Decls where Decls is the list of declarative items.
3830 function Is_Configuration_Pragma return Boolean;
3831 -- Determines if the placement of the current pragma is appropriate
3832 -- for a configuration pragma.
3834 function Is_In_Context_Clause return Boolean;
3835 -- Returns True if pragma appears within the context clause of a unit,
3836 -- and False for any other placement (does not generate any messages).
3838 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3839 -- Analyzes the argument, and determines if it is a static string
3840 -- expression, returns True if so, False if non-static or not String.
3841 -- A special case is that a string literal returns True in Ada 83 mode
3842 -- (which has no such thing as static string expressions). Note that
3843 -- the call analyzes its argument, so this cannot be used for the case
3844 -- where an identifier might not be declared.
3846 procedure Pragma_Misplaced;
3847 pragma No_Return (Pragma_Misplaced);
3848 -- Issue fatal error message for misplaced pragma
3850 procedure Process_Atomic_Independent_Shared_Volatile;
3851 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3852 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3853 -- and treated as being identical in effect to pragma Atomic.
3855 procedure Process_Compile_Time_Warning_Or_Error;
3856 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3858 procedure Process_Convention
3859 (C : out Convention_Id;
3860 Ent : out Entity_Id);
3861 -- Common processing for Convention, Interface, Import and Export.
3862 -- Checks first two arguments of pragma, and sets the appropriate
3863 -- convention value in the specified entity or entities. On return
3864 -- C is the convention, Ent is the referenced entity.
3866 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3867 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3868 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3870 procedure Process_Extended_Import_Export_Object_Pragma
3871 (Arg_Internal : Node_Id;
3872 Arg_External : Node_Id;
3873 Arg_Size : Node_Id);
3874 -- Common processing for the pragmas Import/Export_Object. The three
3875 -- arguments correspond to the three named parameters of the pragmas. An
3876 -- argument is empty if the corresponding parameter is not present in
3879 procedure Process_Extended_Import_Export_Internal_Arg
3880 (Arg_Internal : Node_Id := Empty);
3881 -- Common processing for all extended Import and Export pragmas. The
3882 -- argument is the pragma parameter for the Internal argument. If
3883 -- Arg_Internal is empty or inappropriate, an error message is posted.
3884 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3885 -- set to identify the referenced entity.
3887 procedure Process_Extended_Import_Export_Subprogram_Pragma
3888 (Arg_Internal : Node_Id;
3889 Arg_External : Node_Id;
3890 Arg_Parameter_Types : Node_Id;
3891 Arg_Result_Type : Node_Id := Empty;
3892 Arg_Mechanism : Node_Id;
3893 Arg_Result_Mechanism : Node_Id := Empty);
3894 -- Common processing for all extended Import and Export pragmas applying
3895 -- to subprograms. The caller omits any arguments that do not apply to
3896 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3897 -- only in the Import_Function and Export_Function cases). The argument
3898 -- names correspond to the allowed pragma association identifiers.
3900 procedure Process_Generic_List;
3901 -- Common processing for Share_Generic and Inline_Generic
3903 procedure Process_Import_Or_Interface;
3904 -- Common processing for Import or Interface
3906 procedure Process_Import_Predefined_Type;
3907 -- Processing for completing a type with pragma Import. This is used
3908 -- to declare types that match predefined C types, especially for cases
3909 -- without corresponding Ada predefined type.
3911 type Inline_Status is (Suppressed, Disabled, Enabled);
3912 -- Inline status of a subprogram, indicated as follows:
3913 -- Suppressed: inlining is suppressed for the subprogram
3914 -- Disabled: no inlining is requested for the subprogram
3915 -- Enabled: inlining is requested/required for the subprogram
3917 procedure Process_Inline (Status : Inline_Status);
3918 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3919 -- indicates the inline status specified by the pragma.
3921 procedure Process_Interface_Name
3922 (Subprogram_Def : Entity_Id;
3926 -- Given the last two arguments of pragma Import, pragma Export, or
3927 -- pragma Interface_Name, performs validity checks and sets the
3928 -- Interface_Name field of the given subprogram entity to the
3929 -- appropriate external or link name, depending on the arguments given.
3930 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3931 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3932 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3933 -- nor Link_Arg is present, the interface name is set to the default
3934 -- from the subprogram name. In addition, the pragma itself is passed
3935 -- to analyze any expressions in the case the pragma came from an aspect
3938 procedure Process_Interrupt_Or_Attach_Handler;
3939 -- Common processing for Interrupt and Attach_Handler pragmas
3941 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3942 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3943 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3944 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3945 -- is not set in the Restrictions case.
3947 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3948 -- Common processing for Suppress and Unsuppress. The boolean parameter
3949 -- Suppress_Case is True for the Suppress case, and False for the
3952 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3953 -- Subsidiary to the analysis of pragmas Independent[_Components].
3954 -- Record such a pragma N applied to entity E for future checks.
3956 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3957 -- This procedure sets the Is_Exported flag for the given entity,
3958 -- checking that the entity was not previously imported. Arg is
3959 -- the argument that specified the entity. A check is also made
3960 -- for exporting inappropriate entities.
3962 procedure Set_Extended_Import_Export_External_Name
3963 (Internal_Ent : Entity_Id;
3964 Arg_External : Node_Id);
3965 -- Common processing for all extended import export pragmas. The first
3966 -- argument, Internal_Ent, is the internal entity, which has already
3967 -- been checked for validity by the caller. Arg_External is from the
3968 -- Import or Export pragma, and may be null if no External parameter
3969 -- was present. If Arg_External is present and is a non-null string
3970 -- (a null string is treated as the default), then the Interface_Name
3971 -- field of Internal_Ent is set appropriately.
3973 procedure Set_Imported (E : Entity_Id);
3974 -- This procedure sets the Is_Imported flag for the given entity,
3975 -- checking that it is not previously exported or imported.
3977 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3978 -- Mech is a parameter passing mechanism (see Import_Function syntax
3979 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3980 -- has the right form, and if not issues an error message. If the
3981 -- argument has the right form then the Mechanism field of Ent is
3982 -- set appropriately.
3984 procedure Set_Rational_Profile;
3985 -- Activate the set of configuration pragmas and permissions that make
3986 -- up the Rational profile.
3988 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
3989 -- Activate the set of configuration pragmas and restrictions that make
3990 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
3991 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
3992 -- which is used for error messages on any constructs violating the
3995 ----------------------------------
3996 -- Acquire_Warning_Match_String --
3997 ----------------------------------
3999 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4001 String_To_Name_Buffer
4002 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4004 -- Add asterisk at start if not already there
4006 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4007 Name_Buffer (2 .. Name_Len + 1) :=
4008 Name_Buffer (1 .. Name_Len);
4009 Name_Buffer (1) := '*';
4010 Name_Len := Name_Len + 1;
4013 -- Add asterisk at end if not already there
4015 if Name_Buffer (Name_Len) /= '*' then
4016 Name_Len := Name_Len + 1;
4017 Name_Buffer (Name_Len) := '*';
4019 end Acquire_Warning_Match_String;
4021 ---------------------
4022 -- Ada_2005_Pragma --
4023 ---------------------
4025 procedure Ada_2005_Pragma is
4027 if Ada_Version <= Ada_95 then
4028 Check_Restriction (No_Implementation_Pragmas, N);
4030 end Ada_2005_Pragma;
4032 ---------------------
4033 -- Ada_2012_Pragma --
4034 ---------------------
4036 procedure Ada_2012_Pragma is
4038 if Ada_Version <= Ada_2005 then
4039 Check_Restriction (No_Implementation_Pragmas, N);
4041 end Ada_2012_Pragma;
4043 ----------------------------
4044 -- Analyze_Depends_Global --
4045 ----------------------------
4047 procedure Analyze_Depends_Global
4048 (Spec_Id : out Entity_Id;
4049 Subp_Decl : out Node_Id;
4050 Legal : out Boolean)
4053 -- Assume that the pragma is illegal
4060 Check_Arg_Count (1);
4062 -- Ensure the proper placement of the pragma. Depends/Global must be
4063 -- associated with a subprogram declaration or a body that acts as a
4066 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4070 if Nkind (Subp_Decl) = N_Entry_Declaration then
4073 -- Generic subprogram
4075 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4078 -- Object declaration of a single concurrent type
4080 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4085 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4088 -- Subprogram body acts as spec
4090 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4091 and then No (Corresponding_Spec (Subp_Decl))
4095 -- Subprogram body stub acts as spec
4097 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4098 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4102 -- Subprogram declaration
4104 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4109 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4117 -- If we get here, then the pragma is legal
4120 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4122 -- When the related context is an entry, the entry must belong to a
4123 -- protected unit (SPARK RM 6.1.4(6)).
4125 if Is_Entry_Declaration (Spec_Id)
4126 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4131 -- When the related context is an anonymous object created for a
4132 -- simple concurrent type, the type must be a task
4133 -- (SPARK RM 6.1.4(6)).
4135 elsif Is_Single_Concurrent_Object (Spec_Id)
4136 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4142 -- A pragma that applies to a Ghost entity becomes Ghost for the
4143 -- purposes of legality checks and removal of ignored Ghost code.
4145 Mark_Ghost_Pragma (N, Spec_Id);
4146 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4147 end Analyze_Depends_Global;
4149 ------------------------
4150 -- Analyze_If_Present --
4151 ------------------------
4153 procedure Analyze_If_Present (Id : Pragma_Id) is
4157 pragma Assert (Is_List_Member (N));
4159 -- Inspect the declarations or statements following pragma N looking
4160 -- for another pragma whose Id matches the caller's request. If it is
4161 -- available, analyze it.
4164 while Present (Stmt) loop
4165 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4166 Analyze_Pragma (Stmt);
4169 -- The first source declaration or statement immediately following
4170 -- N ends the region where a pragma may appear.
4172 elsif Comes_From_Source (Stmt) then
4178 end Analyze_If_Present;
4180 --------------------------------
4181 -- Analyze_Pre_Post_Condition --
4182 --------------------------------
4184 procedure Analyze_Pre_Post_Condition is
4185 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4186 Subp_Decl : Node_Id;
4187 Subp_Id : Entity_Id;
4189 Duplicates_OK : Boolean := False;
4190 -- Flag set when a pre/postcondition allows multiple pragmas of the
4193 In_Body_OK : Boolean := False;
4194 -- Flag set when a pre/postcondition is allowed to appear on a body
4195 -- even though the subprogram may have a spec.
4197 Is_Pre_Post : Boolean := False;
4198 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4201 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4202 -- Implement rules in AI12-0131: an overriding operation can have
4203 -- a class-wide precondition only if one of its ancestors has an
4204 -- explicit class-wide precondition.
4206 -----------------------------
4207 -- Inherits_Class_Wide_Pre --
4208 -----------------------------
4210 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4211 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4214 Prev : Entity_Id := Overridden_Operation (E);
4217 -- Check ancestors on the overriding operation to examine the
4218 -- preconditions that may apply to them.
4220 while Present (Prev) loop
4221 Cont := Contract (Prev);
4222 if Present (Cont) then
4223 Prag := Pre_Post_Conditions (Cont);
4224 while Present (Prag) loop
4225 if Class_Present (Prag) then
4229 Prag := Next_Pragma (Prag);
4233 -- For a type derived from a generic formal type, the operation
4234 -- inheriting the condition is a renaming, not an overriding of
4235 -- the operation of the formal.
4237 if Is_Generic_Type (Find_Dispatching_Type (Prev)) then
4238 Prev := Alias (Prev);
4240 Prev := Overridden_Operation (Prev);
4244 -- If the controlling type of the subprogram has progenitors, an
4245 -- interface operation implemented by the current operation may
4246 -- have a class-wide precondition.
4248 if Has_Interfaces (Typ) then
4253 Prim_Elmt : Elmt_Id;
4254 Prim_List : Elist_Id;
4257 Collect_Interfaces (Typ, Ints);
4258 Elmt := First_Elmt (Ints);
4260 -- Iterate over the primitive operations of each interface
4262 while Present (Elmt) loop
4263 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4264 Prim_Elmt := First_Elmt (Prim_List);
4265 while Present (Prim_Elmt) loop
4266 Prim := Node (Prim_Elmt);
4267 if Chars (Prim) = Chars (E)
4268 and then Present (Contract (Prim))
4269 and then Class_Present
4270 (Pre_Post_Conditions (Contract (Prim)))
4275 Next_Elmt (Prim_Elmt);
4284 end Inherits_Class_Wide_Pre;
4286 -- Start of processing for Analyze_Pre_Post_Condition
4289 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4290 -- offer uniformity among the various kinds of pre/postconditions by
4291 -- rewriting the pragma identifier. This allows the retrieval of the
4292 -- original pragma name by routine Original_Aspect_Pragma_Name.
4294 if Comes_From_Source (N) then
4295 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4296 Is_Pre_Post := True;
4297 Set_Class_Present (N, Pname = Name_Pre_Class);
4298 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4300 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4301 Is_Pre_Post := True;
4302 Set_Class_Present (N, Pname = Name_Post_Class);
4303 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4307 -- Determine the semantics with respect to duplicates and placement
4308 -- in a body. Pragmas Precondition and Postcondition were introduced
4309 -- before aspects and are not subject to the same aspect-like rules.
4311 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4312 Duplicates_OK := True;
4318 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4319 -- argument without an identifier.
4322 Check_Arg_Count (1);
4323 Check_No_Identifiers;
4325 -- Pragmas Precondition and Postcondition have complex argument
4329 Check_At_Least_N_Arguments (1);
4330 Check_At_Most_N_Arguments (2);
4331 Check_Optional_Identifier (Arg1, Name_Check);
4333 if Present (Arg2) then
4334 Check_Optional_Identifier (Arg2, Name_Message);
4335 Preanalyze_Spec_Expression
4336 (Get_Pragma_Arg (Arg2), Standard_String);
4340 -- For a pragma PPC in the extended main source unit, record enabled
4342 -- ??? nothing checks that the pragma is in the main source unit
4344 if Is_Checked (N) and then not Split_PPC (N) then
4345 Set_SCO_Pragma_Enabled (Loc);
4348 -- Ensure the proper placement of the pragma
4351 Find_Related_Declaration_Or_Body
4352 (N, Do_Checks => not Duplicates_OK);
4354 -- When a pre/postcondition pragma applies to an abstract subprogram,
4355 -- its original form must be an aspect with 'Class.
4357 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4358 if not From_Aspect_Specification (N) then
4360 ("pragma % cannot be applied to abstract subprogram");
4362 elsif not Class_Present (N) then
4364 ("aspect % requires ''Class for abstract subprogram");
4367 -- Entry declaration
4369 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4372 -- Generic subprogram declaration
4374 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4379 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4380 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4384 -- Subprogram body stub
4386 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4387 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4391 -- Subprogram declaration
4393 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4395 -- AI05-0230: When a pre/postcondition pragma applies to a null
4396 -- procedure, its original form must be an aspect with 'Class.
4398 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4399 and then Null_Present (Specification (Subp_Decl))
4400 and then From_Aspect_Specification (N)
4401 and then not Class_Present (N)
4403 Error_Pragma ("aspect % requires ''Class for null procedure");
4406 -- Implement the legality checks mandated by AI12-0131:
4407 -- Pre'Class shall not be specified for an overriding primitive
4408 -- subprogram of a tagged type T unless the Pre'Class aspect is
4409 -- specified for the corresponding primitive subprogram of some
4413 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4416 if Class_Present (N)
4417 and then Pragma_Name (N) = Name_Precondition
4418 and then Present (Overridden_Operation (E))
4419 and then not Inherits_Class_Wide_Pre (E)
4422 ("illegal class-wide precondition on overriding operation",
4423 Corresponding_Aspect (N));
4427 -- Otherwise the placement is illegal
4434 Subp_Id := Defining_Entity (Subp_Decl);
4436 -- A pragma that applies to a Ghost entity becomes Ghost for the
4437 -- purposes of legality checks and removal of ignored Ghost code.
4439 Mark_Ghost_Pragma (N, Subp_Id);
4441 -- Chain the pragma on the contract for further processing by
4442 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4444 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4446 -- Fully analyze the pragma when it appears inside an entry or
4447 -- subprogram body because it cannot benefit from forward references.
4449 if Nkind_In (Subp_Decl, N_Entry_Body,
4451 N_Subprogram_Body_Stub)
4453 -- The legality checks of pragmas Precondition and Postcondition
4454 -- are affected by the SPARK mode in effect and the volatility of
4455 -- the context. Analyze all pragmas in a specific order.
4457 Analyze_If_Present (Pragma_SPARK_Mode);
4458 Analyze_If_Present (Pragma_Volatile_Function);
4459 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4461 end Analyze_Pre_Post_Condition;
4463 -----------------------------------------
4464 -- Analyze_Refined_Depends_Global_Post --
4465 -----------------------------------------
4467 procedure Analyze_Refined_Depends_Global_Post
4468 (Spec_Id : out Entity_Id;
4469 Body_Id : out Entity_Id;
4470 Legal : out Boolean)
4472 Body_Decl : Node_Id;
4473 Spec_Decl : Node_Id;
4476 -- Assume that the pragma is illegal
4483 Check_Arg_Count (1);
4484 Check_No_Identifiers;
4486 -- Verify the placement of the pragma and check for duplicates. The
4487 -- pragma must apply to a subprogram body [stub].
4489 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4493 if Nkind (Body_Decl) = N_Entry_Body then
4498 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4501 -- Subprogram body stub
4503 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4508 elsif Nkind (Body_Decl) = N_Task_Body then
4516 Body_Id := Defining_Entity (Body_Decl);
4517 Spec_Id := Unique_Defining_Entity (Body_Decl);
4519 -- The pragma must apply to the second declaration of a subprogram.
4520 -- In other words, the body [stub] cannot acts as a spec.
4522 if No (Spec_Id) then
4523 Error_Pragma ("pragma % cannot apply to a stand alone body");
4526 -- Catch the case where the subprogram body is a subunit and acts as
4527 -- the third declaration of the subprogram.
4529 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4530 Error_Pragma ("pragma % cannot apply to a subunit");
4534 -- A refined pragma can only apply to the body [stub] of a subprogram
4535 -- declared in the visible part of a package. Retrieve the context of
4536 -- the subprogram declaration.
4538 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4540 -- When dealing with protected entries or protected subprograms, use
4541 -- the enclosing protected type as the proper context.
4543 if Ekind_In (Spec_Id, E_Entry,
4547 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4549 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4552 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4554 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4555 & "subprogram declared in a package specification"));
4559 -- If we get here, then the pragma is legal
4563 -- A pragma that applies to a Ghost entity becomes Ghost for the
4564 -- purposes of legality checks and removal of ignored Ghost code.
4566 Mark_Ghost_Pragma (N, Spec_Id);
4568 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4569 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4571 end Analyze_Refined_Depends_Global_Post;
4573 ----------------------------------
4574 -- Analyze_Unmodified_Or_Unused --
4575 ----------------------------------
4577 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4582 Ghost_Error_Posted : Boolean := False;
4583 -- Flag set when an error concerning the illegal mix of Ghost and
4584 -- non-Ghost variables is emitted.
4586 Ghost_Id : Entity_Id := Empty;
4587 -- The entity of the first Ghost variable encountered while
4588 -- processing the arguments of the pragma.
4592 Check_At_Least_N_Arguments (1);
4594 -- Loop through arguments
4597 while Present (Arg) loop
4598 Check_No_Identifier (Arg);
4600 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4601 -- in fact generate reference, so that the entity will have a
4602 -- reference, which will inhibit any warnings about it not
4603 -- being referenced, and also properly show up in the ali file
4604 -- as a reference. But this reference is recorded before the
4605 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4606 -- generated for this reference.
4608 Check_Arg_Is_Local_Name (Arg);
4609 Arg_Expr := Get_Pragma_Arg (Arg);
4611 if Is_Entity_Name (Arg_Expr) then
4612 Arg_Id := Entity (Arg_Expr);
4614 -- Skip processing the argument if already flagged
4616 if Is_Assignable (Arg_Id)
4617 and then not Has_Pragma_Unmodified (Arg_Id)
4618 and then not Has_Pragma_Unused (Arg_Id)
4620 Set_Has_Pragma_Unmodified (Arg_Id);
4623 Set_Has_Pragma_Unused (Arg_Id);
4626 -- A pragma that applies to a Ghost entity becomes Ghost for
4627 -- the purposes of legality checks and removal of ignored
4630 Mark_Ghost_Pragma (N, Arg_Id);
4632 -- Capture the entity of the first Ghost variable being
4633 -- processed for error detection purposes.
4635 if Is_Ghost_Entity (Arg_Id) then
4636 if No (Ghost_Id) then
4640 -- Otherwise the variable is non-Ghost. It is illegal to mix
4641 -- references to Ghost and non-Ghost entities
4644 elsif Present (Ghost_Id)
4645 and then not Ghost_Error_Posted
4647 Ghost_Error_Posted := True;
4649 Error_Msg_Name_1 := Pname;
4651 ("pragma % cannot mention ghost and non-ghost "
4654 Error_Msg_Sloc := Sloc (Ghost_Id);
4655 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4657 Error_Msg_Sloc := Sloc (Arg_Id);
4658 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4661 -- Warn if already flagged as Unused or Unmodified
4663 elsif Has_Pragma_Unmodified (Arg_Id) then
4664 if Has_Pragma_Unused (Arg_Id) then
4666 ("??pragma Unused already given for &!", Arg_Expr,
4670 ("??pragma Unmodified already given for &!", Arg_Expr,
4674 -- Otherwise the pragma referenced an illegal entity
4678 ("pragma% can only be applied to a variable", Arg_Expr);
4684 end Analyze_Unmodified_Or_Unused;
4686 -----------------------------------
4687 -- Analyze_Unreference_Or_Unused --
4688 -----------------------------------
4690 procedure Analyze_Unreferenced_Or_Unused
4691 (Is_Unused : Boolean := False)
4698 Ghost_Error_Posted : Boolean := False;
4699 -- Flag set when an error concerning the illegal mix of Ghost and
4700 -- non-Ghost names is emitted.
4702 Ghost_Id : Entity_Id := Empty;
4703 -- The entity of the first Ghost name encountered while processing
4704 -- the arguments of the pragma.
4708 Check_At_Least_N_Arguments (1);
4710 -- Check case of appearing within context clause
4712 if not Is_Unused and then Is_In_Context_Clause then
4714 -- The arguments must all be units mentioned in a with clause in
4715 -- the same context clause. Note that Par.Prag already checked
4716 -- that the arguments are either identifiers or selected
4720 while Present (Arg) loop
4721 Citem := First (List_Containing (N));
4722 while Citem /= N loop
4723 Arg_Expr := Get_Pragma_Arg (Arg);
4725 if Nkind (Citem) = N_With_Clause
4726 and then Same_Name (Name (Citem), Arg_Expr)
4728 Set_Has_Pragma_Unreferenced
4731 (Library_Unit (Citem))));
4732 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4741 ("argument of pragma% is not withed unit", Arg);
4747 -- Case of not in list of context items
4751 while Present (Arg) loop
4752 Check_No_Identifier (Arg);
4754 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4755 -- in fact generate reference, so that the entity will have a
4756 -- reference, which will inhibit any warnings about it not
4757 -- being referenced, and also properly show up in the ali file
4758 -- as a reference. But this reference is recorded before the
4759 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4760 -- generated for this reference.
4762 Check_Arg_Is_Local_Name (Arg);
4763 Arg_Expr := Get_Pragma_Arg (Arg);
4765 if Is_Entity_Name (Arg_Expr) then
4766 Arg_Id := Entity (Arg_Expr);
4768 -- Warn if already flagged as Unused or Unreferenced and
4769 -- skip processing the argument.
4771 if Has_Pragma_Unreferenced (Arg_Id) then
4772 if Has_Pragma_Unused (Arg_Id) then
4774 ("??pragma Unused already given for &!", Arg_Expr,
4778 ("??pragma Unreferenced already given for &!",
4782 -- Apply Unreferenced to the entity
4785 -- If the entity is overloaded, the pragma applies to the
4786 -- most recent overloading, as documented. In this case,
4787 -- name resolution does not generate a reference, so it
4788 -- must be done here explicitly.
4790 if Is_Overloaded (Arg_Expr) then
4791 Generate_Reference (Arg_Id, N);
4794 Set_Has_Pragma_Unreferenced (Arg_Id);
4797 Set_Has_Pragma_Unused (Arg_Id);
4800 -- A pragma that applies to a Ghost entity becomes Ghost
4801 -- for the purposes of legality checks and removal of
4802 -- ignored Ghost code.
4804 Mark_Ghost_Pragma (N, Arg_Id);
4806 -- Capture the entity of the first Ghost name being
4807 -- processed for error detection purposes.
4809 if Is_Ghost_Entity (Arg_Id) then
4810 if No (Ghost_Id) then
4814 -- Otherwise the name is non-Ghost. It is illegal to mix
4815 -- references to Ghost and non-Ghost entities
4818 elsif Present (Ghost_Id)
4819 and then not Ghost_Error_Posted
4821 Ghost_Error_Posted := True;
4823 Error_Msg_Name_1 := Pname;
4825 ("pragma % cannot mention ghost and non-ghost "
4828 Error_Msg_Sloc := Sloc (Ghost_Id);
4830 ("\& # declared as ghost", N, Ghost_Id);
4832 Error_Msg_Sloc := Sloc (Arg_Id);
4834 ("\& # declared as non-ghost", N, Arg_Id);
4842 end Analyze_Unreferenced_Or_Unused;
4844 --------------------------
4845 -- Check_Ada_83_Warning --
4846 --------------------------
4848 procedure Check_Ada_83_Warning is
4850 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4851 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4853 end Check_Ada_83_Warning;
4855 ---------------------
4856 -- Check_Arg_Count --
4857 ---------------------
4859 procedure Check_Arg_Count (Required : Nat) is
4861 if Arg_Count /= Required then
4862 Error_Pragma ("wrong number of arguments for pragma%");
4864 end Check_Arg_Count;
4866 --------------------------------
4867 -- Check_Arg_Is_External_Name --
4868 --------------------------------
4870 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4871 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4874 if Nkind (Argx) = N_Identifier then
4878 Analyze_And_Resolve (Argx, Standard_String);
4880 if Is_OK_Static_Expression (Argx) then
4883 elsif Etype (Argx) = Any_Type then
4886 -- An interesting special case, if we have a string literal and
4887 -- we are in Ada 83 mode, then we allow it even though it will
4888 -- not be flagged as static. This allows expected Ada 83 mode
4889 -- use of external names which are string literals, even though
4890 -- technically these are not static in Ada 83.
4892 elsif Ada_Version = Ada_83
4893 and then Nkind (Argx) = N_String_Literal
4897 -- Static expression that raises Constraint_Error. This has
4898 -- already been flagged, so just exit from pragma processing.
4900 elsif Is_OK_Static_Expression (Argx) then
4903 -- Here we have a real error (non-static expression)
4906 Error_Msg_Name_1 := Pname;
4909 Msg : constant String :=
4910 "argument for pragma% must be a identifier or "
4911 & "static string expression!";
4913 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4918 end Check_Arg_Is_External_Name;
4920 -----------------------------
4921 -- Check_Arg_Is_Identifier --
4922 -----------------------------
4924 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4925 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4927 if Nkind (Argx) /= N_Identifier then
4929 ("argument for pragma% must be identifier", Argx);
4931 end Check_Arg_Is_Identifier;
4933 ----------------------------------
4934 -- Check_Arg_Is_Integer_Literal --
4935 ----------------------------------
4937 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4938 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4940 if Nkind (Argx) /= N_Integer_Literal then
4942 ("argument for pragma% must be integer literal", Argx);
4944 end Check_Arg_Is_Integer_Literal;
4946 -------------------------------------------
4947 -- Check_Arg_Is_Library_Level_Local_Name --
4948 -------------------------------------------
4952 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4953 -- | library_unit_NAME
4955 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4957 Check_Arg_Is_Local_Name (Arg);
4959 -- If it came from an aspect, we want to give the error just as if it
4960 -- came from source.
4962 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4963 and then (Comes_From_Source (N)
4964 or else Present (Corresponding_Aspect (Parent (Arg))))
4967 ("argument for pragma% must be library level entity", Arg);
4969 end Check_Arg_Is_Library_Level_Local_Name;
4971 -----------------------------
4972 -- Check_Arg_Is_Local_Name --
4973 -----------------------------
4977 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4978 -- | library_unit_NAME
4980 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4981 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4984 -- If this pragma came from an aspect specification, we don't want to
4985 -- check for this error, because that would cause spurious errors, in
4986 -- case a type is frozen in a scope more nested than the type. The
4987 -- aspect itself of course can't be anywhere but on the declaration
4990 if Nkind (Arg) = N_Pragma_Argument_Association then
4991 if From_Aspect_Specification (Parent (Arg)) then
4995 -- Arg is the Expression of an N_Pragma_Argument_Association
4998 if From_Aspect_Specification (Parent (Parent (Arg))) then
5005 if Nkind (Argx) not in N_Direct_Name
5006 and then (Nkind (Argx) /= N_Attribute_Reference
5007 or else Present (Expressions (Argx))
5008 or else Nkind (Prefix (Argx)) /= N_Identifier)
5009 and then (not Is_Entity_Name (Argx)
5010 or else not Is_Compilation_Unit (Entity (Argx)))
5012 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5015 -- No further check required if not an entity name
5017 if not Is_Entity_Name (Argx) then
5023 Ent : constant Entity_Id := Entity (Argx);
5024 Scop : constant Entity_Id := Scope (Ent);
5027 -- Case of a pragma applied to a compilation unit: pragma must
5028 -- occur immediately after the program unit in the compilation.
5030 if Is_Compilation_Unit (Ent) then
5032 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5035 -- Case of pragma placed immediately after spec
5037 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5040 -- Case of pragma placed immediately after body
5042 elsif Nkind (Decl) = N_Subprogram_Declaration
5043 and then Present (Corresponding_Body (Decl))
5047 (Parent (Unit_Declaration_Node
5048 (Corresponding_Body (Decl))));
5050 -- All other cases are illegal
5057 -- Special restricted placement rule from 10.2.1(11.8/2)
5059 elsif Is_Generic_Formal (Ent)
5060 and then Prag_Id = Pragma_Preelaborable_Initialization
5062 OK := List_Containing (N) =
5063 Generic_Formal_Declarations
5064 (Unit_Declaration_Node (Scop));
5066 -- If this is an aspect applied to a subprogram body, the
5067 -- pragma is inserted in its declarative part.
5069 elsif From_Aspect_Specification (N)
5070 and then Ent = Current_Scope
5072 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5076 -- If the aspect is a predicate (possibly others ???) and the
5077 -- context is a record type, this is a discriminant expression
5078 -- within a type declaration, that freezes the predicated
5081 elsif From_Aspect_Specification (N)
5082 and then Prag_Id = Pragma_Predicate
5083 and then Ekind (Current_Scope) = E_Record_Type
5084 and then Scop = Scope (Current_Scope)
5088 -- Default case, just check that the pragma occurs in the scope
5089 -- of the entity denoted by the name.
5092 OK := Current_Scope = Scop;
5097 ("pragma% argument must be in same declarative part", Arg);
5101 end Check_Arg_Is_Local_Name;
5103 ---------------------------------
5104 -- Check_Arg_Is_Locking_Policy --
5105 ---------------------------------
5107 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5108 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5111 Check_Arg_Is_Identifier (Argx);
5113 if not Is_Locking_Policy_Name (Chars (Argx)) then
5114 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5116 end Check_Arg_Is_Locking_Policy;
5118 -----------------------------------------------
5119 -- Check_Arg_Is_Partition_Elaboration_Policy --
5120 -----------------------------------------------
5122 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5123 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5126 Check_Arg_Is_Identifier (Argx);
5128 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5130 ("& is not a valid partition elaboration policy name", Argx);
5132 end Check_Arg_Is_Partition_Elaboration_Policy;
5134 -------------------------
5135 -- Check_Arg_Is_One_Of --
5136 -------------------------
5138 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5139 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5142 Check_Arg_Is_Identifier (Argx);
5144 if not Nam_In (Chars (Argx), N1, N2) then
5145 Error_Msg_Name_2 := N1;
5146 Error_Msg_Name_3 := N2;
5147 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5149 end Check_Arg_Is_One_Of;
5151 procedure Check_Arg_Is_One_Of
5153 N1, N2, N3 : Name_Id)
5155 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5158 Check_Arg_Is_Identifier (Argx);
5160 if not Nam_In (Chars (Argx), N1, N2, N3) then
5161 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5163 end Check_Arg_Is_One_Of;
5165 procedure Check_Arg_Is_One_Of
5167 N1, N2, N3, N4 : Name_Id)
5169 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5172 Check_Arg_Is_Identifier (Argx);
5174 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5175 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5177 end Check_Arg_Is_One_Of;
5179 procedure Check_Arg_Is_One_Of
5181 N1, N2, N3, N4, N5 : Name_Id)
5183 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5186 Check_Arg_Is_Identifier (Argx);
5188 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5189 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5191 end Check_Arg_Is_One_Of;
5193 ---------------------------------
5194 -- Check_Arg_Is_Queuing_Policy --
5195 ---------------------------------
5197 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5198 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5201 Check_Arg_Is_Identifier (Argx);
5203 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5204 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5206 end Check_Arg_Is_Queuing_Policy;
5208 ---------------------------------------
5209 -- Check_Arg_Is_OK_Static_Expression --
5210 ---------------------------------------
5212 procedure Check_Arg_Is_OK_Static_Expression
5214 Typ : Entity_Id := Empty)
5217 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5218 end Check_Arg_Is_OK_Static_Expression;
5220 ------------------------------------------
5221 -- Check_Arg_Is_Task_Dispatching_Policy --
5222 ------------------------------------------
5224 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5225 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5228 Check_Arg_Is_Identifier (Argx);
5230 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5232 ("& is not an allowed task dispatching policy name", Argx);
5234 end Check_Arg_Is_Task_Dispatching_Policy;
5236 ---------------------
5237 -- Check_Arg_Order --
5238 ---------------------
5240 procedure Check_Arg_Order (Names : Name_List) is
5243 Highest_So_Far : Natural := 0;
5244 -- Highest index in Names seen do far
5248 for J in 1 .. Arg_Count loop
5249 if Chars (Arg) /= No_Name then
5250 for K in Names'Range loop
5251 if Chars (Arg) = Names (K) then
5252 if K < Highest_So_Far then
5253 Error_Msg_Name_1 := Pname;
5255 ("parameters out of order for pragma%", Arg);
5256 Error_Msg_Name_1 := Names (K);
5257 Error_Msg_Name_2 := Names (Highest_So_Far);
5258 Error_Msg_N ("\% must appear before %", Arg);
5262 Highest_So_Far := K;
5270 end Check_Arg_Order;
5272 --------------------------------
5273 -- Check_At_Least_N_Arguments --
5274 --------------------------------
5276 procedure Check_At_Least_N_Arguments (N : Nat) is
5278 if Arg_Count < N then
5279 Error_Pragma ("too few arguments for pragma%");
5281 end Check_At_Least_N_Arguments;
5283 -------------------------------
5284 -- Check_At_Most_N_Arguments --
5285 -------------------------------
5287 procedure Check_At_Most_N_Arguments (N : Nat) is
5290 if Arg_Count > N then
5292 for J in 1 .. N loop
5294 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5297 end Check_At_Most_N_Arguments;
5299 ---------------------
5300 -- Check_Component --
5301 ---------------------
5303 procedure Check_Component
5306 In_Variant_Part : Boolean := False)
5308 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5309 Sindic : constant Node_Id :=
5310 Subtype_Indication (Component_Definition (Comp));
5311 Typ : constant Entity_Id := Etype (Comp_Id);
5314 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5315 -- object constraint, then the component type shall be an Unchecked_
5318 if Nkind (Sindic) = N_Subtype_Indication
5319 and then Has_Per_Object_Constraint (Comp_Id)
5320 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5323 ("component subtype subject to per-object constraint "
5324 & "must be an Unchecked_Union", Comp);
5326 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5327 -- the body of a generic unit, or within the body of any of its
5328 -- descendant library units, no part of the type of a component
5329 -- declared in a variant_part of the unchecked union type shall be of
5330 -- a formal private type or formal private extension declared within
5331 -- the formal part of the generic unit.
5333 elsif Ada_Version >= Ada_2012
5334 and then In_Generic_Body (UU_Typ)
5335 and then In_Variant_Part
5336 and then Is_Private_Type (Typ)
5337 and then Is_Generic_Type (Typ)
5340 ("component of unchecked union cannot be of generic type", Comp);
5342 elsif Needs_Finalization (Typ) then
5344 ("component of unchecked union cannot be controlled", Comp);
5346 elsif Has_Task (Typ) then
5348 ("component of unchecked union cannot have tasks", Comp);
5350 end Check_Component;
5352 ----------------------------
5353 -- Check_Duplicate_Pragma --
5354 ----------------------------
5356 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5357 Id : Entity_Id := E;
5361 -- Nothing to do if this pragma comes from an aspect specification,
5362 -- since we could not be duplicating a pragma, and we dealt with the
5363 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5365 if From_Aspect_Specification (N) then
5369 -- Otherwise current pragma may duplicate previous pragma or a
5370 -- previously given aspect specification or attribute definition
5371 -- clause for the same pragma.
5373 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5377 -- If the entity is a type, then we have to make sure that the
5378 -- ostensible duplicate is not for a parent type from which this
5382 if Nkind (P) = N_Pragma then
5384 Args : constant List_Id :=
5385 Pragma_Argument_Associations (P);
5388 and then Is_Entity_Name (Expression (First (Args)))
5389 and then Is_Type (Entity (Expression (First (Args))))
5390 and then Entity (Expression (First (Args))) /= E
5396 elsif Nkind (P) = N_Aspect_Specification
5397 and then Is_Type (Entity (P))
5398 and then Entity (P) /= E
5404 -- Here we have a definite duplicate
5406 Error_Msg_Name_1 := Pragma_Name (N);
5407 Error_Msg_Sloc := Sloc (P);
5409 -- For a single protected or a single task object, the error is
5410 -- issued on the original entity.
5412 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5413 Id := Defining_Identifier (Original_Node (Parent (Id)));
5416 if Nkind (P) = N_Aspect_Specification
5417 or else From_Aspect_Specification (P)
5419 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5421 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5426 end Check_Duplicate_Pragma;
5428 ----------------------------------
5429 -- Check_Duplicated_Export_Name --
5430 ----------------------------------
5432 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5433 String_Val : constant String_Id := Strval (Nam);
5436 -- We are only interested in the export case, and in the case of
5437 -- generics, it is the instance, not the template, that is the
5438 -- problem (the template will generate a warning in any case).
5440 if not Inside_A_Generic
5441 and then (Prag_Id = Pragma_Export
5443 Prag_Id = Pragma_Export_Procedure
5445 Prag_Id = Pragma_Export_Valued_Procedure
5447 Prag_Id = Pragma_Export_Function)
5449 for J in Externals.First .. Externals.Last loop
5450 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5451 Error_Msg_Sloc := Sloc (Externals.Table (J));
5452 Error_Msg_N ("external name duplicates name given#", Nam);
5457 Externals.Append (Nam);
5459 end Check_Duplicated_Export_Name;
5461 ----------------------------------------
5462 -- Check_Expr_Is_OK_Static_Expression --
5463 ----------------------------------------
5465 procedure Check_Expr_Is_OK_Static_Expression
5467 Typ : Entity_Id := Empty)
5470 if Present (Typ) then
5471 Analyze_And_Resolve (Expr, Typ);
5473 Analyze_And_Resolve (Expr);
5476 -- An expression cannot be considered static if its resolution failed
5477 -- or if it's erroneous. Stop the analysis of the related pragma.
5479 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5482 elsif Is_OK_Static_Expression (Expr) then
5485 -- An interesting special case, if we have a string literal and we
5486 -- are in Ada 83 mode, then we allow it even though it will not be
5487 -- flagged as static. This allows the use of Ada 95 pragmas like
5488 -- Import in Ada 83 mode. They will of course be flagged with
5489 -- warnings as usual, but will not cause errors.
5491 elsif Ada_Version = Ada_83
5492 and then Nkind (Expr) = N_String_Literal
5496 -- Finally, we have a real error
5499 Error_Msg_Name_1 := Pname;
5500 Flag_Non_Static_Expr
5501 (Fix_Error ("argument for pragma% must be a static expression!"),
5505 end Check_Expr_Is_OK_Static_Expression;
5507 -------------------------
5508 -- Check_First_Subtype --
5509 -------------------------
5511 procedure Check_First_Subtype (Arg : Node_Id) is
5512 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5513 Ent : constant Entity_Id := Entity (Argx);
5516 if Is_First_Subtype (Ent) then
5519 elsif Is_Type (Ent) then
5521 ("pragma% cannot apply to subtype", Argx);
5523 elsif Is_Object (Ent) then
5525 ("pragma% cannot apply to object, requires a type", Argx);
5529 ("pragma% cannot apply to&, requires a type", Argx);
5531 end Check_First_Subtype;
5533 ----------------------
5534 -- Check_Identifier --
5535 ----------------------
5537 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5540 and then Nkind (Arg) = N_Pragma_Argument_Association
5542 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5543 Error_Msg_Name_1 := Pname;
5544 Error_Msg_Name_2 := Id;
5545 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5549 end Check_Identifier;
5551 --------------------------------
5552 -- Check_Identifier_Is_One_Of --
5553 --------------------------------
5555 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5558 and then Nkind (Arg) = N_Pragma_Argument_Association
5560 if Chars (Arg) = No_Name then
5561 Error_Msg_Name_1 := Pname;
5562 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5565 elsif Chars (Arg) /= N1
5566 and then Chars (Arg) /= N2
5568 Error_Msg_Name_1 := Pname;
5569 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5573 end Check_Identifier_Is_One_Of;
5575 ---------------------------
5576 -- Check_In_Main_Program --
5577 ---------------------------
5579 procedure Check_In_Main_Program is
5580 P : constant Node_Id := Parent (N);
5583 -- Must be in subprogram body
5585 if Nkind (P) /= N_Subprogram_Body then
5586 Error_Pragma ("% pragma allowed only in subprogram");
5588 -- Otherwise warn if obviously not main program
5590 elsif Present (Parameter_Specifications (Specification (P)))
5591 or else not Is_Compilation_Unit (Defining_Entity (P))
5593 Error_Msg_Name_1 := Pname;
5595 ("??pragma% is only effective in main program", N);
5597 end Check_In_Main_Program;
5599 ---------------------------------------
5600 -- Check_Interrupt_Or_Attach_Handler --
5601 ---------------------------------------
5603 procedure Check_Interrupt_Or_Attach_Handler is
5604 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5605 Handler_Proc, Proc_Scope : Entity_Id;
5610 if Prag_Id = Pragma_Interrupt_Handler then
5611 Check_Restriction (No_Dynamic_Attachment, N);
5614 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5615 Proc_Scope := Scope (Handler_Proc);
5617 if Ekind (Proc_Scope) /= E_Protected_Type then
5619 ("argument of pragma% must be protected procedure", Arg1);
5622 -- For pragma case (as opposed to access case), check placement.
5623 -- We don't need to do that for aspects, because we have the
5624 -- check that they aspect applies an appropriate procedure.
5626 if not From_Aspect_Specification (N)
5627 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5629 Error_Pragma ("pragma% must be in protected definition");
5632 if not Is_Library_Level_Entity (Proc_Scope) then
5634 ("argument for pragma% must be library level entity", Arg1);
5637 -- AI05-0033: A pragma cannot appear within a generic body, because
5638 -- instance can be in a nested scope. The check that protected type
5639 -- is itself a library-level declaration is done elsewhere.
5641 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5642 -- handle code prior to AI-0033. Analysis tools typically are not
5643 -- interested in this pragma in any case, so no need to worry too
5644 -- much about its placement.
5646 if Inside_A_Generic then
5647 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5648 and then In_Package_Body (Scope (Current_Scope))
5649 and then not Relaxed_RM_Semantics
5651 Error_Pragma ("pragma% cannot be used inside a generic");
5654 end Check_Interrupt_Or_Attach_Handler;
5656 ---------------------------------
5657 -- Check_Loop_Pragma_Placement --
5658 ---------------------------------
5660 procedure Check_Loop_Pragma_Placement is
5661 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5662 -- Verify whether the current pragma is properly grouped with other
5663 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5664 -- related loop where the pragma appears.
5666 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5667 -- Determine whether an arbitrary statement Stmt denotes pragma
5668 -- Loop_Invariant or Loop_Variant.
5670 procedure Placement_Error (Constr : Node_Id);
5671 pragma No_Return (Placement_Error);
5672 -- Node Constr denotes the last loop restricted construct before we
5673 -- encountered an illegal relation between enclosing constructs. Emit
5674 -- an error depending on what Constr was.
5676 --------------------------------
5677 -- Check_Loop_Pragma_Grouping --
5678 --------------------------------
5680 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5681 Stop_Search : exception;
5682 -- This exception is used to terminate the recursive descent of
5683 -- routine Check_Grouping.
5685 procedure Check_Grouping (L : List_Id);
5686 -- Find the first group of pragmas in list L and if successful,
5687 -- ensure that the current pragma is part of that group. The
5688 -- routine raises Stop_Search once such a check is performed to
5689 -- halt the recursive descent.
5691 procedure Grouping_Error (Prag : Node_Id);
5692 pragma No_Return (Grouping_Error);
5693 -- Emit an error concerning the current pragma indicating that it
5694 -- should be placed after pragma Prag.
5696 --------------------
5697 -- Check_Grouping --
5698 --------------------
5700 procedure Check_Grouping (L : List_Id) is
5706 -- Inspect the list of declarations or statements looking for
5707 -- the first grouping of pragmas:
5710 -- pragma Loop_Invariant ...;
5711 -- pragma Loop_Variant ...;
5713 -- pragma Loop_Variant ...; -- current pragma
5715 -- If the current pragma is not in the grouping, then it must
5716 -- either appear in a different declarative or statement list
5717 -- or the construct at (1) is separating the pragma from the
5721 while Present (Stmt) loop
5723 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5724 -- inside a loop or a block housed inside a loop. Inspect
5725 -- the declarations and statements of the block as they may
5726 -- contain the first grouping.
5728 if Nkind (Stmt) = N_Block_Statement then
5729 HSS := Handled_Statement_Sequence (Stmt);
5731 Check_Grouping (Declarations (Stmt));
5733 if Present (HSS) then
5734 Check_Grouping (Statements (HSS));
5737 -- First pragma of the first topmost grouping has been found
5739 elsif Is_Loop_Pragma (Stmt) then
5741 -- The group and the current pragma are not in the same
5742 -- declarative or statement list.
5744 if List_Containing (Stmt) /= List_Containing (N) then
5745 Grouping_Error (Stmt);
5747 -- Try to reach the current pragma from the first pragma
5748 -- of the grouping while skipping other members:
5750 -- pragma Loop_Invariant ...; -- first pragma
5751 -- pragma Loop_Variant ...; -- member
5753 -- pragma Loop_Variant ...; -- current pragma
5756 while Present (Stmt) loop
5758 -- The current pragma is either the first pragma
5759 -- of the group or is a member of the group. Stop
5760 -- the search as the placement is legal.
5765 -- Skip group members, but keep track of the last
5766 -- pragma in the group.
5768 elsif Is_Loop_Pragma (Stmt) then
5771 -- Skip declarations and statements generated by
5772 -- the compiler during expansion.
5774 elsif not Comes_From_Source (Stmt) then
5777 -- A non-pragma is separating the group from the
5778 -- current pragma, the placement is illegal.
5781 Grouping_Error (Prag);
5787 -- If the traversal did not reach the current pragma,
5788 -- then the list must be malformed.
5790 raise Program_Error;
5798 --------------------
5799 -- Grouping_Error --
5800 --------------------
5802 procedure Grouping_Error (Prag : Node_Id) is
5804 Error_Msg_Sloc := Sloc (Prag);
5805 Error_Pragma ("pragma% must appear next to pragma#");
5808 -- Start of processing for Check_Loop_Pragma_Grouping
5811 -- Inspect the statements of the loop or nested blocks housed
5812 -- within to determine whether the current pragma is part of the
5813 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5815 Check_Grouping (Statements (Loop_Stmt));
5818 when Stop_Search => null;
5819 end Check_Loop_Pragma_Grouping;
5821 --------------------
5822 -- Is_Loop_Pragma --
5823 --------------------
5825 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5827 -- Inspect the original node as Loop_Invariant and Loop_Variant
5828 -- pragmas are rewritten to null when assertions are disabled.
5830 if Nkind (Original_Node (Stmt)) = N_Pragma then
5832 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
5833 Name_Loop_Invariant,
5840 ---------------------
5841 -- Placement_Error --
5842 ---------------------
5844 procedure Placement_Error (Constr : Node_Id) is
5845 LA : constant String := " with Loop_Entry";
5848 if Prag_Id = Pragma_Assert then
5849 Error_Msg_String (1 .. LA'Length) := LA;
5850 Error_Msg_Strlen := LA'Length;
5852 Error_Msg_Strlen := 0;
5855 if Nkind (Constr) = N_Pragma then
5857 ("pragma %~ must appear immediately within the statements "
5861 ("block containing pragma %~ must appear immediately within "
5862 & "the statements of a loop", Constr);
5864 end Placement_Error;
5866 -- Local declarations
5871 -- Start of processing for Check_Loop_Pragma_Placement
5874 -- Check that pragma appears immediately within a loop statement,
5875 -- ignoring intervening block statements.
5879 while Present (Stmt) loop
5881 -- The pragma or previous block must appear immediately within the
5882 -- current block's declarative or statement part.
5884 if Nkind (Stmt) = N_Block_Statement then
5885 if (No (Declarations (Stmt))
5886 or else List_Containing (Prev) /= Declarations (Stmt))
5888 List_Containing (Prev) /=
5889 Statements (Handled_Statement_Sequence (Stmt))
5891 Placement_Error (Prev);
5894 -- Keep inspecting the parents because we are now within a
5895 -- chain of nested blocks.
5899 Stmt := Parent (Stmt);
5902 -- The pragma or previous block must appear immediately within the
5903 -- statements of the loop.
5905 elsif Nkind (Stmt) = N_Loop_Statement then
5906 if List_Containing (Prev) /= Statements (Stmt) then
5907 Placement_Error (Prev);
5910 -- Stop the traversal because we reached the innermost loop
5911 -- regardless of whether we encountered an error or not.
5915 -- Ignore a handled statement sequence. Note that this node may
5916 -- be related to a subprogram body in which case we will emit an
5917 -- error on the next iteration of the search.
5919 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5920 Stmt := Parent (Stmt);
5922 -- Any other statement breaks the chain from the pragma to the
5926 Placement_Error (Prev);
5931 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5932 -- grouped together with other such pragmas.
5934 if Is_Loop_Pragma (N) then
5936 -- The previous check should have located the related loop
5938 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5939 Check_Loop_Pragma_Grouping (Stmt);
5941 end Check_Loop_Pragma_Placement;
5943 -------------------------------------------
5944 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5945 -------------------------------------------
5947 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5956 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5959 elsif Nkind_In (P, N_Package_Specification,
5964 -- Note: the following tests seem a little peculiar, because
5965 -- they test for bodies, but if we were in the statement part
5966 -- of the body, we would already have hit the handled statement
5967 -- sequence, so the only way we get here is by being in the
5968 -- declarative part of the body.
5970 elsif Nkind_In (P, N_Subprogram_Body,
5981 Error_Pragma ("pragma% is not in declarative part or package spec");
5982 end Check_Is_In_Decl_Part_Or_Package_Spec;
5984 -------------------------
5985 -- Check_No_Identifier --
5986 -------------------------
5988 procedure Check_No_Identifier (Arg : Node_Id) is
5990 if Nkind (Arg) = N_Pragma_Argument_Association
5991 and then Chars (Arg) /= No_Name
5993 Error_Pragma_Arg_Ident
5994 ("pragma% does not permit identifier& here", Arg);
5996 end Check_No_Identifier;
5998 --------------------------
5999 -- Check_No_Identifiers --
6000 --------------------------
6002 procedure Check_No_Identifiers is
6006 for J in 1 .. Arg_Count loop
6007 Check_No_Identifier (Arg_Node);
6010 end Check_No_Identifiers;
6012 ------------------------
6013 -- Check_No_Link_Name --
6014 ------------------------
6016 procedure Check_No_Link_Name is
6018 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6022 if Present (Arg4) then
6024 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6026 end Check_No_Link_Name;
6028 -------------------------------
6029 -- Check_Optional_Identifier --
6030 -------------------------------
6032 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6035 and then Nkind (Arg) = N_Pragma_Argument_Association
6036 and then Chars (Arg) /= No_Name
6038 if Chars (Arg) /= Id then
6039 Error_Msg_Name_1 := Pname;
6040 Error_Msg_Name_2 := Id;
6041 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6045 end Check_Optional_Identifier;
6047 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6049 Check_Optional_Identifier (Arg, Name_Find (Id));
6050 end Check_Optional_Identifier;
6052 -------------------------------------
6053 -- Check_Static_Boolean_Expression --
6054 -------------------------------------
6056 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6058 if Present (Expr) then
6059 Analyze_And_Resolve (Expr, Standard_Boolean);
6061 if not Is_OK_Static_Expression (Expr) then
6063 ("expression of pragma % must be static", Expr);
6066 end Check_Static_Boolean_Expression;
6068 -----------------------------
6069 -- Check_Static_Constraint --
6070 -----------------------------
6072 -- Note: for convenience in writing this procedure, in addition to
6073 -- the officially (i.e. by spec) allowed argument which is always a
6074 -- constraint, it also allows ranges and discriminant associations.
6075 -- Above is not clear ???
6077 procedure Check_Static_Constraint (Constr : Node_Id) is
6079 procedure Require_Static (E : Node_Id);
6080 -- Require given expression to be static expression
6082 --------------------
6083 -- Require_Static --
6084 --------------------
6086 procedure Require_Static (E : Node_Id) is
6088 if not Is_OK_Static_Expression (E) then
6089 Flag_Non_Static_Expr
6090 ("non-static constraint not allowed in Unchecked_Union!", E);
6095 -- Start of processing for Check_Static_Constraint
6098 case Nkind (Constr) is
6099 when N_Discriminant_Association =>
6100 Require_Static (Expression (Constr));
6103 Require_Static (Low_Bound (Constr));
6104 Require_Static (High_Bound (Constr));
6106 when N_Attribute_Reference =>
6107 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6108 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6110 when N_Range_Constraint =>
6111 Check_Static_Constraint (Range_Expression (Constr));
6113 when N_Index_Or_Discriminant_Constraint =>
6117 IDC := First (Constraints (Constr));
6118 while Present (IDC) loop
6119 Check_Static_Constraint (IDC);
6127 end Check_Static_Constraint;
6129 --------------------------------------
6130 -- Check_Valid_Configuration_Pragma --
6131 --------------------------------------
6133 -- A configuration pragma must appear in the context clause of a
6134 -- compilation unit, and only other pragmas may precede it. Note that
6135 -- the test also allows use in a configuration pragma file.
6137 procedure Check_Valid_Configuration_Pragma is
6139 if not Is_Configuration_Pragma then
6140 Error_Pragma ("incorrect placement for configuration pragma%");
6142 end Check_Valid_Configuration_Pragma;
6144 -------------------------------------
6145 -- Check_Valid_Library_Unit_Pragma --
6146 -------------------------------------
6148 procedure Check_Valid_Library_Unit_Pragma is
6150 Parent_Node : Node_Id;
6151 Unit_Name : Entity_Id;
6152 Unit_Kind : Node_Kind;
6153 Unit_Node : Node_Id;
6154 Sindex : Source_File_Index;
6157 if not Is_List_Member (N) then
6161 Plist := List_Containing (N);
6162 Parent_Node := Parent (Plist);
6164 if Parent_Node = Empty then
6167 -- Case of pragma appearing after a compilation unit. In this case
6168 -- it must have an argument with the corresponding name and must
6169 -- be part of the following pragmas of its parent.
6171 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6172 if Plist /= Pragmas_After (Parent_Node) then
6175 elsif Arg_Count = 0 then
6177 ("argument required if outside compilation unit");
6180 Check_No_Identifiers;
6181 Check_Arg_Count (1);
6182 Unit_Node := Unit (Parent (Parent_Node));
6183 Unit_Kind := Nkind (Unit_Node);
6185 Analyze (Get_Pragma_Arg (Arg1));
6187 if Unit_Kind = N_Generic_Subprogram_Declaration
6188 or else Unit_Kind = N_Subprogram_Declaration
6190 Unit_Name := Defining_Entity (Unit_Node);
6192 elsif Unit_Kind in N_Generic_Instantiation then
6193 Unit_Name := Defining_Entity (Unit_Node);
6196 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6199 if Chars (Unit_Name) /=
6200 Chars (Entity (Get_Pragma_Arg (Arg1)))
6203 ("pragma% argument is not current unit name", Arg1);
6206 if Ekind (Unit_Name) = E_Package
6207 and then Present (Renamed_Entity (Unit_Name))
6209 Error_Pragma ("pragma% not allowed for renamed package");
6213 -- Pragma appears other than after a compilation unit
6216 -- Here we check for the generic instantiation case and also
6217 -- for the case of processing a generic formal package. We
6218 -- detect these cases by noting that the Sloc on the node
6219 -- does not belong to the current compilation unit.
6221 Sindex := Source_Index (Current_Sem_Unit);
6223 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6224 Rewrite (N, Make_Null_Statement (Loc));
6227 -- If before first declaration, the pragma applies to the
6228 -- enclosing unit, and the name if present must be this name.
6230 elsif Is_Before_First_Decl (N, Plist) then
6231 Unit_Node := Unit_Declaration_Node (Current_Scope);
6232 Unit_Kind := Nkind (Unit_Node);
6234 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6237 elsif Unit_Kind = N_Subprogram_Body
6238 and then not Acts_As_Spec (Unit_Node)
6242 elsif Nkind (Parent_Node) = N_Package_Body then
6245 elsif Nkind (Parent_Node) = N_Package_Specification
6246 and then Plist = Private_Declarations (Parent_Node)
6250 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6251 or else Nkind (Parent_Node) =
6252 N_Generic_Subprogram_Declaration)
6253 and then Plist = Generic_Formal_Declarations (Parent_Node)
6257 elsif Arg_Count > 0 then
6258 Analyze (Get_Pragma_Arg (Arg1));
6260 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6262 ("name in pragma% must be enclosing unit", Arg1);
6265 -- It is legal to have no argument in this context
6271 -- Error if not before first declaration. This is because a
6272 -- library unit pragma argument must be the name of a library
6273 -- unit (RM 10.1.5(7)), but the only names permitted in this
6274 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6275 -- generic subprogram declarations or generic instantiations.
6279 ("pragma% misplaced, must be before first declaration");
6283 end Check_Valid_Library_Unit_Pragma;
6289 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6290 Clist : constant Node_Id := Component_List (Variant);
6294 Comp := First (Component_Items (Clist));
6295 while Present (Comp) loop
6296 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6301 ---------------------------
6302 -- Ensure_Aggregate_Form --
6303 ---------------------------
6305 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6306 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6307 Expr : constant Node_Id := Expression (Arg);
6308 Loc : constant Source_Ptr := Sloc (Expr);
6309 Comps : List_Id := No_List;
6310 Exprs : List_Id := No_List;
6311 Nam : Name_Id := No_Name;
6312 Nam_Loc : Source_Ptr;
6315 -- The pragma argument is in positional form:
6317 -- pragma Depends (Nam => ...)
6321 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6322 -- argument association.
6324 if Nkind (Arg) = N_Pragma_Argument_Association then
6326 Nam_Loc := Sloc (Arg);
6328 -- Remove the pragma argument name as this will be captured in the
6331 Set_Chars (Arg, No_Name);
6334 -- The argument is already in aggregate form, but the presence of a
6335 -- name causes this to be interpreted as named association which in
6336 -- turn must be converted into an aggregate.
6338 -- pragma Global (In_Out => (A, B, C))
6342 -- pragma Global ((In_Out => (A, B, C)))
6344 -- aggregate aggregate
6346 if Nkind (Expr) = N_Aggregate then
6347 if Nam = No_Name then
6351 -- Do not transform a null argument into an aggregate as N_Null has
6352 -- special meaning in formal verification pragmas.
6354 elsif Nkind (Expr) = N_Null then
6358 -- Everything comes from source if the original comes from source
6360 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6362 -- Positional argument is transformed into an aggregate with an
6363 -- Expressions list.
6365 if Nam = No_Name then
6366 Exprs := New_List (Relocate_Node (Expr));
6368 -- An associative argument is transformed into an aggregate with
6369 -- Component_Associations.
6373 Make_Component_Association (Loc,
6374 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6375 Expression => Relocate_Node (Expr)));
6378 Set_Expression (Arg,
6379 Make_Aggregate (Loc,
6380 Component_Associations => Comps,
6381 Expressions => Exprs));
6383 -- Restore Comes_From_Source default
6385 Set_Comes_From_Source_Default (CFSD);
6386 end Ensure_Aggregate_Form;
6392 procedure Error_Pragma (Msg : String) is
6394 Error_Msg_Name_1 := Pname;
6395 Error_Msg_N (Fix_Error (Msg), N);
6399 ----------------------
6400 -- Error_Pragma_Arg --
6401 ----------------------
6403 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6405 Error_Msg_Name_1 := Pname;
6406 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6408 end Error_Pragma_Arg;
6410 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6412 Error_Msg_Name_1 := Pname;
6413 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6414 Error_Pragma_Arg (Msg2, Arg);
6415 end Error_Pragma_Arg;
6417 ----------------------------
6418 -- Error_Pragma_Arg_Ident --
6419 ----------------------------
6421 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6423 Error_Msg_Name_1 := Pname;
6424 Error_Msg_N (Fix_Error (Msg), Arg);
6426 end Error_Pragma_Arg_Ident;
6428 ----------------------
6429 -- Error_Pragma_Ref --
6430 ----------------------
6432 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6434 Error_Msg_Name_1 := Pname;
6435 Error_Msg_Sloc := Sloc (Ref);
6436 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6438 end Error_Pragma_Ref;
6440 ------------------------
6441 -- Find_Lib_Unit_Name --
6442 ------------------------
6444 function Find_Lib_Unit_Name return Entity_Id is
6446 -- Return inner compilation unit entity, for case of nested
6447 -- categorization pragmas. This happens in generic unit.
6449 if Nkind (Parent (N)) = N_Package_Specification
6450 and then Defining_Entity (Parent (N)) /= Current_Scope
6452 return Defining_Entity (Parent (N));
6454 return Current_Scope;
6456 end Find_Lib_Unit_Name;
6458 ----------------------------
6459 -- Find_Program_Unit_Name --
6460 ----------------------------
6462 procedure Find_Program_Unit_Name (Id : Node_Id) is
6463 Unit_Name : Entity_Id;
6464 Unit_Kind : Node_Kind;
6465 P : constant Node_Id := Parent (N);
6468 if Nkind (P) = N_Compilation_Unit then
6469 Unit_Kind := Nkind (Unit (P));
6471 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6472 N_Package_Declaration)
6473 or else Unit_Kind in N_Generic_Declaration
6475 Unit_Name := Defining_Entity (Unit (P));
6477 if Chars (Id) = Chars (Unit_Name) then
6478 Set_Entity (Id, Unit_Name);
6479 Set_Etype (Id, Etype (Unit_Name));
6481 Set_Etype (Id, Any_Type);
6483 ("cannot find program unit referenced by pragma%");
6487 Set_Etype (Id, Any_Type);
6488 Error_Pragma ("pragma% inapplicable to this unit");
6494 end Find_Program_Unit_Name;
6496 -----------------------------------------
6497 -- Find_Unique_Parameterless_Procedure --
6498 -----------------------------------------
6500 function Find_Unique_Parameterless_Procedure
6502 Arg : Node_Id) return Entity_Id
6504 Proc : Entity_Id := Empty;
6507 -- The body of this procedure needs some comments ???
6509 if not Is_Entity_Name (Name) then
6511 ("argument of pragma% must be entity name", Arg);
6513 elsif not Is_Overloaded (Name) then
6514 Proc := Entity (Name);
6516 if Ekind (Proc) /= E_Procedure
6517 or else Present (First_Formal (Proc))
6520 ("argument of pragma% must be parameterless procedure", Arg);
6525 Found : Boolean := False;
6527 Index : Interp_Index;
6530 Get_First_Interp (Name, Index, It);
6531 while Present (It.Nam) loop
6534 if Ekind (Proc) = E_Procedure
6535 and then No (First_Formal (Proc))
6539 Set_Entity (Name, Proc);
6540 Set_Is_Overloaded (Name, False);
6543 ("ambiguous handler name for pragma% ", Arg);
6547 Get_Next_Interp (Index, It);
6552 ("argument of pragma% must be parameterless procedure",
6555 Proc := Entity (Name);
6561 end Find_Unique_Parameterless_Procedure;
6567 function Fix_Error (Msg : String) return String is
6568 Res : String (Msg'Range) := Msg;
6569 Res_Last : Natural := Msg'Last;
6573 -- If we have a rewriting of another pragma, go to that pragma
6575 if Is_Rewrite_Substitution (N)
6576 and then Nkind (Original_Node (N)) = N_Pragma
6578 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6581 -- Case where pragma comes from an aspect specification
6583 if From_Aspect_Specification (N) then
6585 -- Change appearence of "pragma" in message to "aspect"
6588 while J <= Res_Last - 5 loop
6589 if Res (J .. J + 5) = "pragma" then
6590 Res (J .. J + 5) := "aspect";
6598 -- Change "argument of" at start of message to "entity for"
6601 and then Res (Res'First .. Res'First + 10) = "argument of"
6603 Res (Res'First .. Res'First + 9) := "entity for";
6604 Res (Res'First + 10 .. Res_Last - 1) :=
6605 Res (Res'First + 11 .. Res_Last);
6606 Res_Last := Res_Last - 1;
6609 -- Change "argument" at start of message to "entity"
6612 and then Res (Res'First .. Res'First + 7) = "argument"
6614 Res (Res'First .. Res'First + 5) := "entity";
6615 Res (Res'First + 6 .. Res_Last - 2) :=
6616 Res (Res'First + 8 .. Res_Last);
6617 Res_Last := Res_Last - 2;
6620 -- Get name from corresponding aspect
6622 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6625 -- Return possibly modified message
6627 return Res (Res'First .. Res_Last);
6630 -------------------------
6631 -- Gather_Associations --
6632 -------------------------
6634 procedure Gather_Associations
6636 Args : out Args_List)
6641 -- Initialize all parameters to Empty
6643 for J in Args'Range loop
6647 -- That's all we have to do if there are no argument associations
6649 if No (Pragma_Argument_Associations (N)) then
6653 -- Otherwise first deal with any positional parameters present
6655 Arg := First (Pragma_Argument_Associations (N));
6656 for Index in Args'Range loop
6657 exit when No (Arg) or else Chars (Arg) /= No_Name;
6658 Args (Index) := Get_Pragma_Arg (Arg);
6662 -- Positional parameters all processed, if any left, then we
6663 -- have too many positional parameters.
6665 if Present (Arg) and then Chars (Arg) = No_Name then
6667 ("too many positional associations for pragma%", Arg);
6670 -- Process named parameters if any are present
6672 while Present (Arg) loop
6673 if Chars (Arg) = No_Name then
6675 ("positional association cannot follow named association",
6679 for Index in Names'Range loop
6680 if Names (Index) = Chars (Arg) then
6681 if Present (Args (Index)) then
6683 ("duplicate argument association for pragma%", Arg);
6685 Args (Index) := Get_Pragma_Arg (Arg);
6690 if Index = Names'Last then
6691 Error_Msg_Name_1 := Pname;
6692 Error_Msg_N ("pragma% does not allow & argument", Arg);
6694 -- Check for possible misspelling
6696 for Index1 in Names'Range loop
6697 if Is_Bad_Spelling_Of
6698 (Chars (Arg), Names (Index1))
6700 Error_Msg_Name_1 := Names (Index1);
6701 Error_Msg_N -- CODEFIX
6702 ("\possible misspelling of%", Arg);
6714 end Gather_Associations;
6720 procedure GNAT_Pragma is
6722 -- We need to check the No_Implementation_Pragmas restriction for
6723 -- the case of a pragma from source. Note that the case of aspects
6724 -- generating corresponding pragmas marks these pragmas as not being
6725 -- from source, so this test also catches that case.
6727 if Comes_From_Source (N) then
6728 Check_Restriction (No_Implementation_Pragmas, N);
6732 --------------------------
6733 -- Is_Before_First_Decl --
6734 --------------------------
6736 function Is_Before_First_Decl
6737 (Pragma_Node : Node_Id;
6738 Decls : List_Id) return Boolean
6740 Item : Node_Id := First (Decls);
6743 -- Only other pragmas can come before this pragma
6746 if No (Item) or else Nkind (Item) /= N_Pragma then
6749 elsif Item = Pragma_Node then
6755 end Is_Before_First_Decl;
6757 -----------------------------
6758 -- Is_Configuration_Pragma --
6759 -----------------------------
6761 -- A configuration pragma must appear in the context clause of a
6762 -- compilation unit, and only other pragmas may precede it. Note that
6763 -- the test below also permits use in a configuration pragma file.
6765 function Is_Configuration_Pragma return Boolean is
6766 Lis : constant List_Id := List_Containing (N);
6767 Par : constant Node_Id := Parent (N);
6771 -- If no parent, then we are in the configuration pragma file,
6772 -- so the placement is definitely appropriate.
6777 -- Otherwise we must be in the context clause of a compilation unit
6778 -- and the only thing allowed before us in the context list is more
6779 -- configuration pragmas.
6781 elsif Nkind (Par) = N_Compilation_Unit
6782 and then Context_Items (Par) = Lis
6789 elsif Nkind (Prg) /= N_Pragma then
6799 end Is_Configuration_Pragma;
6801 --------------------------
6802 -- Is_In_Context_Clause --
6803 --------------------------
6805 function Is_In_Context_Clause return Boolean is
6807 Parent_Node : Node_Id;
6810 if not Is_List_Member (N) then
6814 Plist := List_Containing (N);
6815 Parent_Node := Parent (Plist);
6817 if Parent_Node = Empty
6818 or else Nkind (Parent_Node) /= N_Compilation_Unit
6819 or else Context_Items (Parent_Node) /= Plist
6826 end Is_In_Context_Clause;
6828 ---------------------------------
6829 -- Is_Static_String_Expression --
6830 ---------------------------------
6832 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6833 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6834 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6837 Analyze_And_Resolve (Argx);
6839 -- Special case Ada 83, where the expression will never be static,
6840 -- but we will return true if we had a string literal to start with.
6842 if Ada_Version = Ada_83 then
6845 -- Normal case, true only if we end up with a string literal that
6846 -- is marked as being the result of evaluating a static expression.
6849 return Is_OK_Static_Expression (Argx)
6850 and then Nkind (Argx) = N_String_Literal;
6853 end Is_Static_String_Expression;
6855 ----------------------
6856 -- Pragma_Misplaced --
6857 ----------------------
6859 procedure Pragma_Misplaced is
6861 Error_Pragma ("incorrect placement of pragma%");
6862 end Pragma_Misplaced;
6864 ------------------------------------------------
6865 -- Process_Atomic_Independent_Shared_Volatile --
6866 ------------------------------------------------
6868 procedure Process_Atomic_Independent_Shared_Volatile is
6869 procedure Set_Atomic_VFA (E : Entity_Id);
6870 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6871 -- no explicit alignment was given, set alignment to unknown, since
6872 -- back end knows what the alignment requirements are for atomic and
6873 -- full access arrays. Note: this is necessary for derived types.
6875 --------------------
6876 -- Set_Atomic_VFA --
6877 --------------------
6879 procedure Set_Atomic_VFA (E : Entity_Id) is
6881 if Prag_Id = Pragma_Volatile_Full_Access then
6882 Set_Is_Volatile_Full_Access (E);
6887 if not Has_Alignment_Clause (E) then
6888 Set_Alignment (E, Uint_0);
6898 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6901 Check_Ada_83_Warning;
6902 Check_No_Identifiers;
6903 Check_Arg_Count (1);
6904 Check_Arg_Is_Local_Name (Arg1);
6905 E_Arg := Get_Pragma_Arg (Arg1);
6907 if Etype (E_Arg) = Any_Type then
6911 E := Entity (E_Arg);
6913 -- A pragma that applies to a Ghost entity becomes Ghost for the
6914 -- purposes of legality checks and removal of ignored Ghost code.
6916 Mark_Ghost_Pragma (N, E);
6918 -- Check duplicate before we chain ourselves
6920 Check_Duplicate_Pragma (E);
6922 -- Check Atomic and VFA used together
6924 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6925 or else (Is_Volatile_Full_Access (E)
6926 and then (Prag_Id = Pragma_Atomic
6928 Prag_Id = Pragma_Shared))
6931 ("cannot have Volatile_Full_Access and Atomic for same entity");
6934 -- Check for applying VFA to an entity which has aliased component
6936 if Prag_Id = Pragma_Volatile_Full_Access then
6939 Aliased_Comp : Boolean := False;
6940 -- Set True if aliased component present
6943 if Is_Array_Type (Etype (E)) then
6944 Aliased_Comp := Has_Aliased_Components (Etype (E));
6946 -- Record case, too bad Has_Aliased_Components is not also
6947 -- set for records, should it be ???
6949 elsif Is_Record_Type (Etype (E)) then
6950 Comp := First_Component_Or_Discriminant (Etype (E));
6951 while Present (Comp) loop
6952 if Is_Aliased (Comp)
6953 or else Is_Aliased (Etype (Comp))
6955 Aliased_Comp := True;
6959 Next_Component_Or_Discriminant (Comp);
6963 if Aliased_Comp then
6965 ("cannot apply Volatile_Full_Access (aliased component "
6971 -- Now check appropriateness of the entity
6973 Decl := Declaration_Node (E);
6976 if Rep_Item_Too_Early (E, N)
6978 Rep_Item_Too_Late (E, N)
6982 Check_First_Subtype (Arg1);
6985 -- Attribute belongs on the base type. If the view of the type is
6986 -- currently private, it also belongs on the underlying type.
6988 if Prag_Id = Pragma_Atomic
6990 Prag_Id = Pragma_Shared
6992 Prag_Id = Pragma_Volatile_Full_Access
6995 Set_Atomic_VFA (Base_Type (E));
6996 Set_Atomic_VFA (Underlying_Type (E));
6999 -- Atomic/Shared/Volatile_Full_Access imply Independent
7001 if Prag_Id /= Pragma_Volatile then
7002 Set_Is_Independent (E);
7003 Set_Is_Independent (Base_Type (E));
7004 Set_Is_Independent (Underlying_Type (E));
7006 if Prag_Id = Pragma_Independent then
7007 Record_Independence_Check (N, Base_Type (E));
7011 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7013 if Prag_Id /= Pragma_Independent then
7014 Set_Is_Volatile (E);
7015 Set_Is_Volatile (Base_Type (E));
7016 Set_Is_Volatile (Underlying_Type (E));
7018 Set_Treat_As_Volatile (E);
7019 Set_Treat_As_Volatile (Underlying_Type (E));
7022 elsif Nkind (Decl) = N_Object_Declaration
7023 or else (Nkind (Decl) = N_Component_Declaration
7024 and then Original_Record_Component (E) = E)
7026 if Rep_Item_Too_Late (E, N) then
7030 if Prag_Id = Pragma_Atomic
7032 Prag_Id = Pragma_Shared
7034 Prag_Id = Pragma_Volatile_Full_Access
7036 if Prag_Id = Pragma_Volatile_Full_Access then
7037 Set_Is_Volatile_Full_Access (E);
7042 -- If the object declaration has an explicit initialization, a
7043 -- temporary may have to be created to hold the expression, to
7044 -- ensure that access to the object remain atomic.
7046 if Nkind (Parent (E)) = N_Object_Declaration
7047 and then Present (Expression (Parent (E)))
7049 Set_Has_Delayed_Freeze (E);
7053 -- Atomic/Shared/Volatile_Full_Access imply Independent
7055 if Prag_Id /= Pragma_Volatile then
7056 Set_Is_Independent (E);
7058 if Prag_Id = Pragma_Independent then
7059 Record_Independence_Check (N, E);
7063 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7065 if Prag_Id /= Pragma_Independent then
7066 Set_Is_Volatile (E);
7067 Set_Treat_As_Volatile (E);
7071 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7074 -- The following check is only relevant when SPARK_Mode is on as
7075 -- this is not a standard Ada legality rule. Pragma Volatile can
7076 -- only apply to a full type declaration or an object declaration
7077 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7078 -- untagged derived types that are rewritten as subtypes of their
7079 -- respective root types.
7082 and then Prag_Id = Pragma_Volatile
7084 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
7085 N_Object_Declaration)
7088 ("argument of pragma % must denote a full type or object "
7089 & "declaration", Arg1);
7091 end Process_Atomic_Independent_Shared_Volatile;
7093 -------------------------------------------
7094 -- Process_Compile_Time_Warning_Or_Error --
7095 -------------------------------------------
7097 procedure Process_Compile_Time_Warning_Or_Error is
7098 Validation_Needed : Boolean := False;
7100 function Check_Node (N : Node_Id) return Traverse_Result;
7101 -- Tree visitor that checks if N is an attribute reference that can
7102 -- be statically computed by the back end. Validation_Needed is set
7103 -- to True if found.
7109 function Check_Node (N : Node_Id) return Traverse_Result is
7111 if Nkind (N) = N_Attribute_Reference
7112 and then Is_Entity_Name (Prefix (N))
7115 Attr_Id : constant Attribute_Id :=
7116 Get_Attribute_Id (Attribute_Name (N));
7118 if Attr_Id = Attribute_Alignment
7119 or else Attr_Id = Attribute_Size
7121 Validation_Needed := True;
7129 procedure Check_Expression is new Traverse_Proc (Check_Node);
7133 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7135 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7138 Check_Arg_Count (2);
7139 Check_No_Identifiers;
7140 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7141 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7143 if Compile_Time_Known_Value (Arg1x) then
7144 Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7146 -- Register the expression for its validation after the back end has
7147 -- been called if it has occurrences of attributes Size or Alignment
7148 -- (because they may be statically computed by the back end and hence
7149 -- the whole expression needs to be reevaluated).
7152 Check_Expression (Arg1x);
7154 if Validation_Needed then
7155 Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
7158 end Process_Compile_Time_Warning_Or_Error;
7160 ------------------------
7161 -- Process_Convention --
7162 ------------------------
7164 procedure Process_Convention
7165 (C : out Convention_Id;
7166 Ent : out Entity_Id)
7170 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7171 -- Called if we have more than one Export/Import/Convention pragma.
7172 -- This is generally illegal, but we have a special case of allowing
7173 -- Import and Interface to coexist if they specify the convention in
7174 -- a consistent manner. We are allowed to do this, since Interface is
7175 -- an implementation defined pragma, and we choose to do it since we
7176 -- know Rational allows this combination. S is the entity id of the
7177 -- subprogram in question. This procedure also sets the special flag
7178 -- Import_Interface_Present in both pragmas in the case where we do
7179 -- have matching Import and Interface pragmas.
7181 procedure Set_Convention_From_Pragma (E : Entity_Id);
7182 -- Set convention in entity E, and also flag that the entity has a
7183 -- convention pragma. If entity is for a private or incomplete type,
7184 -- also set convention and flag on underlying type. This procedure
7185 -- also deals with the special case of C_Pass_By_Copy convention,
7186 -- and error checks for inappropriate convention specification.
7188 -------------------------------
7189 -- Diagnose_Multiple_Pragmas --
7190 -------------------------------
7192 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7193 Pdec : constant Node_Id := Declaration_Node (S);
7197 function Same_Convention (Decl : Node_Id) return Boolean;
7198 -- Decl is a pragma node. This function returns True if this
7199 -- pragma has a first argument that is an identifier with a
7200 -- Chars field corresponding to the Convention_Id C.
7202 function Same_Name (Decl : Node_Id) return Boolean;
7203 -- Decl is a pragma node. This function returns True if this
7204 -- pragma has a second argument that is an identifier with a
7205 -- Chars field that matches the Chars of the current subprogram.
7207 ---------------------
7208 -- Same_Convention --
7209 ---------------------
7211 function Same_Convention (Decl : Node_Id) return Boolean is
7212 Arg1 : constant Node_Id :=
7213 First (Pragma_Argument_Associations (Decl));
7216 if Present (Arg1) then
7218 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7220 if Nkind (Arg) = N_Identifier
7221 and then Is_Convention_Name (Chars (Arg))
7222 and then Get_Convention_Id (Chars (Arg)) = C
7230 end Same_Convention;
7236 function Same_Name (Decl : Node_Id) return Boolean is
7237 Arg1 : constant Node_Id :=
7238 First (Pragma_Argument_Associations (Decl));
7246 Arg2 := Next (Arg1);
7253 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7255 if Nkind (Arg) = N_Identifier
7256 and then Chars (Arg) = Chars (S)
7265 -- Start of processing for Diagnose_Multiple_Pragmas
7270 -- Definitely give message if we have Convention/Export here
7272 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7275 -- If we have an Import or Export, scan back from pragma to
7276 -- find any previous pragma applying to the same procedure.
7277 -- The scan will be terminated by the start of the list, or
7278 -- hitting the subprogram declaration. This won't allow one
7279 -- pragma to appear in the public part and one in the private
7280 -- part, but that seems very unlikely in practice.
7284 while Present (Decl) and then Decl /= Pdec loop
7286 -- Look for pragma with same name as us
7288 if Nkind (Decl) = N_Pragma
7289 and then Same_Name (Decl)
7291 -- Give error if same as our pragma or Export/Convention
7293 if Nam_In (Pragma_Name_Unmapped (Decl),
7296 Pragma_Name_Unmapped (N))
7300 -- Case of Import/Interface or the other way round
7302 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7303 Name_Interface, Name_Import)
7305 -- Here we know that we have Import and Interface. It
7306 -- doesn't matter which way round they are. See if
7307 -- they specify the same convention. If so, all OK,
7308 -- and set special flags to stop other messages
7310 if Same_Convention (Decl) then
7311 Set_Import_Interface_Present (N);
7312 Set_Import_Interface_Present (Decl);
7315 -- If different conventions, special message
7318 Error_Msg_Sloc := Sloc (Decl);
7320 ("convention differs from that given#", Arg1);
7330 -- Give message if needed if we fall through those tests
7331 -- except on Relaxed_RM_Semantics where we let go: either this
7332 -- is a case accepted/ignored by other Ada compilers (e.g.
7333 -- a mix of Convention and Import), or another error will be
7334 -- generated later (e.g. using both Import and Export).
7336 if Err and not Relaxed_RM_Semantics then
7338 ("at most one Convention/Export/Import pragma is allowed",
7341 end Diagnose_Multiple_Pragmas;
7343 --------------------------------
7344 -- Set_Convention_From_Pragma --
7345 --------------------------------
7347 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7349 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7350 -- for an overridden dispatching operation. Technically this is
7351 -- an amendment and should only be done in Ada 2005 mode. However,
7352 -- this is clearly a mistake, since the problem that is addressed
7353 -- by this AI is that there is a clear gap in the RM.
7355 if Is_Dispatching_Operation (E)
7356 and then Present (Overridden_Operation (E))
7357 and then C /= Convention (Overridden_Operation (E))
7360 ("cannot change convention for overridden dispatching "
7361 & "operation", Arg1);
7364 -- Special checks for Convention_Stdcall
7366 if C = Convention_Stdcall then
7368 -- A dispatching call is not allowed. A dispatching subprogram
7369 -- cannot be used to interface to the Win32 API, so in fact
7370 -- this check does not impose any effective restriction.
7372 if Is_Dispatching_Operation (E) then
7373 Error_Msg_Sloc := Sloc (E);
7375 -- Note: make this unconditional so that if there is more
7376 -- than one call to which the pragma applies, we get a
7377 -- message for each call. Also don't use Error_Pragma,
7378 -- so that we get multiple messages.
7381 ("dispatching subprogram# cannot use Stdcall convention!",
7384 -- Several allowed cases
7386 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7390 or else Ekind (E) = E_Variable
7392 -- A component as well. The entity does not have its Ekind
7393 -- set until the enclosing record declaration is fully
7396 or else Nkind (Parent (E)) = N_Component_Declaration
7398 -- An access to subprogram is also allowed
7402 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7404 -- Allow internal call to set convention of subprogram type
7406 or else Ekind (E) = E_Subprogram_Type
7412 ("second argument of pragma% must be subprogram (type)",
7417 -- Set the convention
7419 Set_Convention (E, C);
7420 Set_Has_Convention_Pragma (E);
7422 -- For the case of a record base type, also set the convention of
7423 -- any anonymous access types declared in the record which do not
7424 -- currently have a specified convention.
7426 if Is_Record_Type (E) and then Is_Base_Type (E) then
7431 Comp := First_Component (E);
7432 while Present (Comp) loop
7433 if Present (Etype (Comp))
7434 and then Ekind_In (Etype (Comp),
7435 E_Anonymous_Access_Type,
7436 E_Anonymous_Access_Subprogram_Type)
7437 and then not Has_Convention_Pragma (Comp)
7439 Set_Convention (Comp, C);
7442 Next_Component (Comp);
7447 -- Deal with incomplete/private type case, where underlying type
7448 -- is available, so set convention of that underlying type.
7450 if Is_Incomplete_Or_Private_Type (E)
7451 and then Present (Underlying_Type (E))
7453 Set_Convention (Underlying_Type (E), C);
7454 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7457 -- A class-wide type should inherit the convention of the specific
7458 -- root type (although this isn't specified clearly by the RM).
7460 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7461 Set_Convention (Class_Wide_Type (E), C);
7464 -- If the entity is a record type, then check for special case of
7465 -- C_Pass_By_Copy, which is treated the same as C except that the
7466 -- special record flag is set. This convention is only permitted
7467 -- on record types (see AI95-00131).
7469 if Cname = Name_C_Pass_By_Copy then
7470 if Is_Record_Type (E) then
7471 Set_C_Pass_By_Copy (Base_Type (E));
7472 elsif Is_Incomplete_Or_Private_Type (E)
7473 and then Is_Record_Type (Underlying_Type (E))
7475 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7478 ("C_Pass_By_Copy convention allowed only for record type",
7483 -- If the entity is a derived boolean type, check for the special
7484 -- case of convention C, C++, or Fortran, where we consider any
7485 -- nonzero value to represent true.
7487 if Is_Discrete_Type (E)
7488 and then Root_Type (Etype (E)) = Standard_Boolean
7494 C = Convention_Fortran)
7496 Set_Nonzero_Is_True (Base_Type (E));
7498 end Set_Convention_From_Pragma;
7502 Comp_Unit : Unit_Number_Type;
7507 -- Start of processing for Process_Convention
7510 Check_At_Least_N_Arguments (2);
7511 Check_Optional_Identifier (Arg1, Name_Convention);
7512 Check_Arg_Is_Identifier (Arg1);
7513 Cname := Chars (Get_Pragma_Arg (Arg1));
7515 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7516 -- tested again below to set the critical flag).
7518 if Cname = Name_C_Pass_By_Copy then
7521 -- Otherwise we must have something in the standard convention list
7523 elsif Is_Convention_Name (Cname) then
7524 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7526 -- Otherwise warn on unrecognized convention
7529 if Warn_On_Export_Import then
7531 ("??unrecognized convention name, C assumed",
7532 Get_Pragma_Arg (Arg1));
7538 Check_Optional_Identifier (Arg2, Name_Entity);
7539 Check_Arg_Is_Local_Name (Arg2);
7541 Id := Get_Pragma_Arg (Arg2);
7544 if not Is_Entity_Name (Id) then
7545 Error_Pragma_Arg ("entity name required", Arg2);
7550 -- Set entity to return
7554 -- Ada_Pass_By_Copy special checking
7556 if C = Convention_Ada_Pass_By_Copy then
7557 if not Is_First_Subtype (E) then
7559 ("convention `Ada_Pass_By_Copy` only allowed for types",
7563 if Is_By_Reference_Type (E) then
7565 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7569 -- Ada_Pass_By_Reference special checking
7571 elsif C = Convention_Ada_Pass_By_Reference then
7572 if not Is_First_Subtype (E) then
7574 ("convention `Ada_Pass_By_Reference` only allowed for types",
7578 if Is_By_Copy_Type (E) then
7580 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7585 -- Go to renamed subprogram if present, since convention applies to
7586 -- the actual renamed entity, not to the renaming entity. If the
7587 -- subprogram is inherited, go to parent subprogram.
7589 if Is_Subprogram (E)
7590 and then Present (Alias (E))
7592 if Nkind (Parent (Declaration_Node (E))) =
7593 N_Subprogram_Renaming_Declaration
7595 if Scope (E) /= Scope (Alias (E)) then
7597 ("cannot apply pragma% to non-local entity&#", E);
7602 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7603 N_Private_Extension_Declaration)
7604 and then Scope (E) = Scope (Alias (E))
7608 -- Return the parent subprogram the entity was inherited from
7614 -- Check that we are not applying this to a specless body. Relax this
7615 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7617 if Is_Subprogram (E)
7618 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7619 and then not Relaxed_RM_Semantics
7622 ("pragma% requires separate spec and must come before body");
7625 -- Check that we are not applying this to a named constant
7627 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7628 Error_Msg_Name_1 := Pname;
7630 ("cannot apply pragma% to named constant!",
7631 Get_Pragma_Arg (Arg2));
7633 ("\supply appropriate type for&!", Arg2);
7636 if Ekind (E) = E_Enumeration_Literal then
7637 Error_Pragma ("enumeration literal not allowed for pragma%");
7640 -- Check for rep item appearing too early or too late
7642 if Etype (E) = Any_Type
7643 or else Rep_Item_Too_Early (E, N)
7647 elsif Present (Underlying_Type (E)) then
7648 E := Underlying_Type (E);
7651 if Rep_Item_Too_Late (E, N) then
7655 if Has_Convention_Pragma (E) then
7656 Diagnose_Multiple_Pragmas (E);
7658 elsif Convention (E) = Convention_Protected
7659 or else Ekind (Scope (E)) = E_Protected_Type
7662 ("a protected operation cannot be given a different convention",
7666 -- For Intrinsic, a subprogram is required
7668 if C = Convention_Intrinsic
7669 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7671 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7673 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7675 ("second argument of pragma% must be a subprogram", Arg2);
7679 -- Deal with non-subprogram cases
7681 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7682 Set_Convention_From_Pragma (E);
7686 -- The pragma must apply to a first subtype, but it can also
7687 -- apply to a generic type in a generic formal part, in which
7688 -- case it will also appear in the corresponding instance.
7690 if Is_Generic_Type (E) or else In_Instance then
7693 Check_First_Subtype (Arg2);
7696 Set_Convention_From_Pragma (Base_Type (E));
7698 -- For access subprograms, we must set the convention on the
7699 -- internally generated directly designated type as well.
7701 if Ekind (E) = E_Access_Subprogram_Type then
7702 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7706 -- For the subprogram case, set proper convention for all homonyms
7707 -- in same scope and the same declarative part, i.e. the same
7708 -- compilation unit.
7711 Comp_Unit := Get_Source_Unit (E);
7712 Set_Convention_From_Pragma (E);
7714 -- Treat a pragma Import as an implicit body, and pragma import
7715 -- as implicit reference (for navigation in GPS).
7717 if Prag_Id = Pragma_Import then
7718 Generate_Reference (E, Id, 'b');
7720 -- For exported entities we restrict the generation of references
7721 -- to entities exported to foreign languages since entities
7722 -- exported to Ada do not provide further information to GPS and
7723 -- add undesired references to the output of the gnatxref tool.
7725 elsif Prag_Id = Pragma_Export
7726 and then Convention (E) /= Convention_Ada
7728 Generate_Reference (E, Id, 'i');
7731 -- If the pragma comes from an aspect, it only applies to the
7732 -- given entity, not its homonyms.
7734 if From_Aspect_Specification (N) then
7738 -- Otherwise Loop through the homonyms of the pragma argument's
7739 -- entity, an apply convention to those in the current scope.
7745 exit when No (E1) or else Scope (E1) /= Current_Scope;
7747 -- Ignore entry for which convention is already set
7749 if Has_Convention_Pragma (E1) then
7753 if Is_Subprogram (E1)
7754 and then Nkind (Parent (Declaration_Node (E1))) =
7756 and then not Relaxed_RM_Semantics
7758 Set_Has_Completion (E); -- to prevent cascaded error
7760 ("pragma% requires separate spec and must come before "
7764 -- Do not set the pragma on inherited operations or on formal
7767 if Comes_From_Source (E1)
7768 and then Comp_Unit = Get_Source_Unit (E1)
7769 and then not Is_Formal_Subprogram (E1)
7770 and then Nkind (Original_Node (Parent (E1))) /=
7771 N_Full_Type_Declaration
7773 if Present (Alias (E1))
7774 and then Scope (E1) /= Scope (Alias (E1))
7777 ("cannot apply pragma% to non-local entity& declared#",
7781 Set_Convention_From_Pragma (E1);
7783 if Prag_Id = Pragma_Import then
7784 Generate_Reference (E1, Id, 'b');
7792 end Process_Convention;
7794 ----------------------------------------
7795 -- Process_Disable_Enable_Atomic_Sync --
7796 ----------------------------------------
7798 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7800 Check_No_Identifiers;
7801 Check_At_Most_N_Arguments (1);
7803 -- Modeled internally as
7804 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7809 Pragma_Argument_Associations => New_List (
7810 Make_Pragma_Argument_Association (Loc,
7812 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7814 if Present (Arg1) then
7815 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7819 end Process_Disable_Enable_Atomic_Sync;
7821 -------------------------------------------------
7822 -- Process_Extended_Import_Export_Internal_Arg --
7823 -------------------------------------------------
7825 procedure Process_Extended_Import_Export_Internal_Arg
7826 (Arg_Internal : Node_Id := Empty)
7829 if No (Arg_Internal) then
7830 Error_Pragma ("Internal parameter required for pragma%");
7833 if Nkind (Arg_Internal) = N_Identifier then
7836 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7837 and then (Prag_Id = Pragma_Import_Function
7839 Prag_Id = Pragma_Export_Function)
7845 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7848 Check_Arg_Is_Local_Name (Arg_Internal);
7849 end Process_Extended_Import_Export_Internal_Arg;
7851 --------------------------------------------------
7852 -- Process_Extended_Import_Export_Object_Pragma --
7853 --------------------------------------------------
7855 procedure Process_Extended_Import_Export_Object_Pragma
7856 (Arg_Internal : Node_Id;
7857 Arg_External : Node_Id;
7863 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7864 Def_Id := Entity (Arg_Internal);
7866 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7868 ("pragma% must designate an object", Arg_Internal);
7871 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7873 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7876 ("previous Common/Psect_Object applies, pragma % not permitted",
7880 if Rep_Item_Too_Late (Def_Id, N) then
7884 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7886 if Present (Arg_Size) then
7887 Check_Arg_Is_External_Name (Arg_Size);
7890 -- Export_Object case
7892 if Prag_Id = Pragma_Export_Object then
7893 if not Is_Library_Level_Entity (Def_Id) then
7895 ("argument for pragma% must be library level entity",
7899 if Ekind (Current_Scope) = E_Generic_Package then
7900 Error_Pragma ("pragma& cannot appear in a generic unit");
7903 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7905 ("exported object must have compile time known size",
7909 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7910 Error_Msg_N ("??duplicate Export_Object pragma", N);
7912 Set_Exported (Def_Id, Arg_Internal);
7915 -- Import_Object case
7918 if Is_Concurrent_Type (Etype (Def_Id)) then
7920 ("cannot use pragma% for task/protected object",
7924 if Ekind (Def_Id) = E_Constant then
7926 ("cannot import a constant", Arg_Internal);
7929 if Warn_On_Export_Import
7930 and then Has_Discriminants (Etype (Def_Id))
7933 ("imported value must be initialized??", Arg_Internal);
7936 if Warn_On_Export_Import
7937 and then Is_Access_Type (Etype (Def_Id))
7940 ("cannot import object of an access type??", Arg_Internal);
7943 if Warn_On_Export_Import
7944 and then Is_Imported (Def_Id)
7946 Error_Msg_N ("??duplicate Import_Object pragma", N);
7948 -- Check for explicit initialization present. Note that an
7949 -- initialization generated by the code generator, e.g. for an
7950 -- access type, does not count here.
7952 elsif Present (Expression (Parent (Def_Id)))
7955 (Original_Node (Expression (Parent (Def_Id))))
7957 Error_Msg_Sloc := Sloc (Def_Id);
7959 ("imported entities cannot be initialized (RM B.1(24))",
7960 "\no initialization allowed for & declared#", Arg1);
7962 Set_Imported (Def_Id);
7963 Note_Possible_Modification (Arg_Internal, Sure => False);
7966 end Process_Extended_Import_Export_Object_Pragma;
7968 ------------------------------------------------------
7969 -- Process_Extended_Import_Export_Subprogram_Pragma --
7970 ------------------------------------------------------
7972 procedure Process_Extended_Import_Export_Subprogram_Pragma
7973 (Arg_Internal : Node_Id;
7974 Arg_External : Node_Id;
7975 Arg_Parameter_Types : Node_Id;
7976 Arg_Result_Type : Node_Id := Empty;
7977 Arg_Mechanism : Node_Id;
7978 Arg_Result_Mechanism : Node_Id := Empty)
7984 Ambiguous : Boolean;
7987 function Same_Base_Type
7989 Formal : Entity_Id) return Boolean;
7990 -- Determines if Ptype references the type of Formal. Note that only
7991 -- the base types need to match according to the spec. Ptype here is
7992 -- the argument from the pragma, which is either a type name, or an
7993 -- access attribute.
7995 --------------------
7996 -- Same_Base_Type --
7997 --------------------
7999 function Same_Base_Type
8001 Formal : Entity_Id) return Boolean
8003 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8007 -- Case where pragma argument is typ'Access
8009 if Nkind (Ptype) = N_Attribute_Reference
8010 and then Attribute_Name (Ptype) = Name_Access
8012 Pref := Prefix (Ptype);
8015 if not Is_Entity_Name (Pref)
8016 or else Entity (Pref) = Any_Type
8021 -- We have a match if the corresponding argument is of an
8022 -- anonymous access type, and its designated type matches the
8023 -- type of the prefix of the access attribute
8025 return Ekind (Ftyp) = E_Anonymous_Access_Type
8026 and then Base_Type (Entity (Pref)) =
8027 Base_Type (Etype (Designated_Type (Ftyp)));
8029 -- Case where pragma argument is a type name
8034 if not Is_Entity_Name (Ptype)
8035 or else Entity (Ptype) = Any_Type
8040 -- We have a match if the corresponding argument is of the type
8041 -- given in the pragma (comparing base types)
8043 return Base_Type (Entity (Ptype)) = Ftyp;
8047 -- Start of processing for
8048 -- Process_Extended_Import_Export_Subprogram_Pragma
8051 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8055 -- Loop through homonyms (overloadings) of the entity
8057 Hom_Id := Entity (Arg_Internal);
8058 while Present (Hom_Id) loop
8059 Def_Id := Get_Base_Subprogram (Hom_Id);
8061 -- We need a subprogram in the current scope
8063 if not Is_Subprogram (Def_Id)
8064 or else Scope (Def_Id) /= Current_Scope
8071 -- Pragma cannot apply to subprogram body
8073 if Is_Subprogram (Def_Id)
8074 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8078 ("pragma% requires separate spec and must come before "
8082 -- Test result type if given, note that the result type
8083 -- parameter can only be present for the function cases.
8085 if Present (Arg_Result_Type)
8086 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8090 elsif Etype (Def_Id) /= Standard_Void_Type
8091 and then Nam_In (Pname, Name_Export_Procedure,
8092 Name_Import_Procedure)
8096 -- Test parameter types if given. Note that this parameter has
8097 -- not been analyzed (and must not be, since it is semantic
8098 -- nonsense), so we get it as the parser left it.
8100 elsif Present (Arg_Parameter_Types) then
8101 Check_Matching_Types : declare
8106 Formal := First_Formal (Def_Id);
8108 if Nkind (Arg_Parameter_Types) = N_Null then
8109 if Present (Formal) then
8113 -- A list of one type, e.g. (List) is parsed as a
8114 -- parenthesized expression.
8116 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8117 and then Paren_Count (Arg_Parameter_Types) = 1
8120 or else Present (Next_Formal (Formal))
8125 Same_Base_Type (Arg_Parameter_Types, Formal);
8128 -- A list of more than one type is parsed as a aggregate
8130 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8131 and then Paren_Count (Arg_Parameter_Types) = 0
8133 Ptype := First (Expressions (Arg_Parameter_Types));
8134 while Present (Ptype) or else Present (Formal) loop
8137 or else not Same_Base_Type (Ptype, Formal)
8142 Next_Formal (Formal);
8147 -- Anything else is of the wrong form
8151 ("wrong form for Parameter_Types parameter",
8152 Arg_Parameter_Types);
8154 end Check_Matching_Types;
8157 -- Match is now False if the entry we found did not match
8158 -- either a supplied Parameter_Types or Result_Types argument
8164 -- Ambiguous case, the flag Ambiguous shows if we already
8165 -- detected this and output the initial messages.
8168 if not Ambiguous then
8170 Error_Msg_Name_1 := Pname;
8172 ("pragma% does not uniquely identify subprogram!",
8174 Error_Msg_Sloc := Sloc (Ent);
8175 Error_Msg_N ("matching subprogram #!", N);
8179 Error_Msg_Sloc := Sloc (Def_Id);
8180 Error_Msg_N ("matching subprogram #!", N);
8185 Hom_Id := Homonym (Hom_Id);
8188 -- See if we found an entry
8191 if not Ambiguous then
8192 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8194 ("pragma% cannot be given for generic subprogram");
8197 ("pragma% does not identify local subprogram");
8204 -- Import pragmas must be for imported entities
8206 if Prag_Id = Pragma_Import_Function
8208 Prag_Id = Pragma_Import_Procedure
8210 Prag_Id = Pragma_Import_Valued_Procedure
8212 if not Is_Imported (Ent) then
8214 ("pragma Import or Interface must precede pragma%");
8217 -- Here we have the Export case which can set the entity as exported
8219 -- But does not do so if the specified external name is null, since
8220 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8221 -- compatible) to request no external name.
8223 elsif Nkind (Arg_External) = N_String_Literal
8224 and then String_Length (Strval (Arg_External)) = 0
8228 -- In all other cases, set entity as exported
8231 Set_Exported (Ent, Arg_Internal);
8234 -- Special processing for Valued_Procedure cases
8236 if Prag_Id = Pragma_Import_Valued_Procedure
8238 Prag_Id = Pragma_Export_Valued_Procedure
8240 Formal := First_Formal (Ent);
8243 Error_Pragma ("at least one parameter required for pragma%");
8245 elsif Ekind (Formal) /= E_Out_Parameter then
8246 Error_Pragma ("first parameter must have mode out for pragma%");
8249 Set_Is_Valued_Procedure (Ent);
8253 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8255 -- Process Result_Mechanism argument if present. We have already
8256 -- checked that this is only allowed for the function case.
8258 if Present (Arg_Result_Mechanism) then
8259 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8262 -- Process Mechanism parameter if present. Note that this parameter
8263 -- is not analyzed, and must not be analyzed since it is semantic
8264 -- nonsense, so we get it in exactly as the parser left it.
8266 if Present (Arg_Mechanism) then
8274 -- A single mechanism association without a formal parameter
8275 -- name is parsed as a parenthesized expression. All other
8276 -- cases are parsed as aggregates, so we rewrite the single
8277 -- parameter case as an aggregate for consistency.
8279 if Nkind (Arg_Mechanism) /= N_Aggregate
8280 and then Paren_Count (Arg_Mechanism) = 1
8282 Rewrite (Arg_Mechanism,
8283 Make_Aggregate (Sloc (Arg_Mechanism),
8284 Expressions => New_List (
8285 Relocate_Node (Arg_Mechanism))));
8288 -- Case of only mechanism name given, applies to all formals
8290 if Nkind (Arg_Mechanism) /= N_Aggregate then
8291 Formal := First_Formal (Ent);
8292 while Present (Formal) loop
8293 Set_Mechanism_Value (Formal, Arg_Mechanism);
8294 Next_Formal (Formal);
8297 -- Case of list of mechanism associations given
8300 if Null_Record_Present (Arg_Mechanism) then
8302 ("inappropriate form for Mechanism parameter",
8306 -- Deal with positional ones first
8308 Formal := First_Formal (Ent);
8310 if Present (Expressions (Arg_Mechanism)) then
8311 Mname := First (Expressions (Arg_Mechanism));
8312 while Present (Mname) loop
8315 ("too many mechanism associations", Mname);
8318 Set_Mechanism_Value (Formal, Mname);
8319 Next_Formal (Formal);
8324 -- Deal with named entries
8326 if Present (Component_Associations (Arg_Mechanism)) then
8327 Massoc := First (Component_Associations (Arg_Mechanism));
8328 while Present (Massoc) loop
8329 Choice := First (Choices (Massoc));
8331 if Nkind (Choice) /= N_Identifier
8332 or else Present (Next (Choice))
8335 ("incorrect form for mechanism association",
8339 Formal := First_Formal (Ent);
8343 ("parameter name & not present", Choice);
8346 if Chars (Choice) = Chars (Formal) then
8348 (Formal, Expression (Massoc));
8350 -- Set entity on identifier (needed by ASIS)
8352 Set_Entity (Choice, Formal);
8357 Next_Formal (Formal);
8366 end Process_Extended_Import_Export_Subprogram_Pragma;
8368 --------------------------
8369 -- Process_Generic_List --
8370 --------------------------
8372 procedure Process_Generic_List is
8377 Check_No_Identifiers;
8378 Check_At_Least_N_Arguments (1);
8380 -- Check all arguments are names of generic units or instances
8383 while Present (Arg) loop
8384 Exp := Get_Pragma_Arg (Arg);
8387 if not Is_Entity_Name (Exp)
8389 (not Is_Generic_Instance (Entity (Exp))
8391 not Is_Generic_Unit (Entity (Exp)))
8394 ("pragma% argument must be name of generic unit/instance",
8400 end Process_Generic_List;
8402 ------------------------------------
8403 -- Process_Import_Predefined_Type --
8404 ------------------------------------
8406 procedure Process_Import_Predefined_Type is
8407 Loc : constant Source_Ptr := Sloc (N);
8409 Ftyp : Node_Id := Empty;
8415 Nam := String_To_Name (Strval (Expression (Arg3)));
8417 Elmt := First_Elmt (Predefined_Float_Types);
8418 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8422 Ftyp := Node (Elmt);
8424 if Present (Ftyp) then
8426 -- Don't build a derived type declaration, because predefined C
8427 -- types have no declaration anywhere, so cannot really be named.
8428 -- Instead build a full type declaration, starting with an
8429 -- appropriate type definition is built
8431 if Is_Floating_Point_Type (Ftyp) then
8432 Def := Make_Floating_Point_Definition (Loc,
8433 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8434 Make_Real_Range_Specification (Loc,
8435 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8436 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8438 -- Should never have a predefined type we cannot handle
8441 raise Program_Error;
8444 -- Build and insert a Full_Type_Declaration, which will be
8445 -- analyzed as soon as this list entry has been analyzed.
8447 Decl := Make_Full_Type_Declaration (Loc,
8448 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8449 Type_Definition => Def);
8451 Insert_After (N, Decl);
8452 Mark_Rewrite_Insertion (Decl);
8455 Error_Pragma_Arg ("no matching type found for pragma%",
8458 end Process_Import_Predefined_Type;
8460 ---------------------------------
8461 -- Process_Import_Or_Interface --
8462 ---------------------------------
8464 procedure Process_Import_Or_Interface is
8470 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8471 -- pragma Import (Entity, "external name");
8473 if Relaxed_RM_Semantics
8474 and then Arg_Count = 2
8475 and then Prag_Id = Pragma_Import
8476 and then Nkind (Expression (Arg2)) = N_String_Literal
8479 Def_Id := Get_Pragma_Arg (Arg1);
8482 if not Is_Entity_Name (Def_Id) then
8483 Error_Pragma_Arg ("entity name required", Arg1);
8486 Def_Id := Entity (Def_Id);
8487 Kill_Size_Check_Code (Def_Id);
8488 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8491 Process_Convention (C, Def_Id);
8493 -- A pragma that applies to a Ghost entity becomes Ghost for the
8494 -- purposes of legality checks and removal of ignored Ghost code.
8496 Mark_Ghost_Pragma (N, Def_Id);
8497 Kill_Size_Check_Code (Def_Id);
8498 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8501 -- Various error checks
8503 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8505 -- We do not permit Import to apply to a renaming declaration
8507 if Present (Renamed_Object (Def_Id)) then
8509 ("pragma% not allowed for object renaming", Arg2);
8511 -- User initialization is not allowed for imported object, but
8512 -- the object declaration may contain a default initialization,
8513 -- that will be discarded. Note that an explicit initialization
8514 -- only counts if it comes from source, otherwise it is simply
8515 -- the code generator making an implicit initialization explicit.
8517 elsif Present (Expression (Parent (Def_Id)))
8518 and then Comes_From_Source
8519 (Original_Node (Expression (Parent (Def_Id))))
8521 -- Set imported flag to prevent cascaded errors
8523 Set_Is_Imported (Def_Id);
8525 Error_Msg_Sloc := Sloc (Def_Id);
8527 ("no initialization allowed for declaration of& #",
8528 "\imported entities cannot be initialized (RM B.1(24))",
8532 -- If the pragma comes from an aspect specification the
8533 -- Is_Imported flag has already been set.
8535 if not From_Aspect_Specification (N) then
8536 Set_Imported (Def_Id);
8539 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8541 -- Note that we do not set Is_Public here. That's because we
8542 -- only want to set it if there is no address clause, and we
8543 -- don't know that yet, so we delay that processing till
8546 -- pragma Import completes deferred constants
8548 if Ekind (Def_Id) = E_Constant then
8549 Set_Has_Completion (Def_Id);
8552 -- It is not possible to import a constant of an unconstrained
8553 -- array type (e.g. string) because there is no simple way to
8554 -- write a meaningful subtype for it.
8556 if Is_Array_Type (Etype (Def_Id))
8557 and then not Is_Constrained (Etype (Def_Id))
8560 ("imported constant& must have a constrained subtype",
8565 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8567 -- If the name is overloaded, pragma applies to all of the denoted
8568 -- entities in the same declarative part, unless the pragma comes
8569 -- from an aspect specification or was generated by the compiler
8570 -- (such as for pragma Provide_Shift_Operators).
8573 while Present (Hom_Id) loop
8575 Def_Id := Get_Base_Subprogram (Hom_Id);
8577 -- Ignore inherited subprograms because the pragma will apply
8578 -- to the parent operation, which is the one called.
8580 if Is_Overloadable (Def_Id)
8581 and then Present (Alias (Def_Id))
8585 -- If it is not a subprogram, it must be in an outer scope and
8586 -- pragma does not apply.
8588 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8591 -- The pragma does not apply to primitives of interfaces
8593 elsif Is_Dispatching_Operation (Def_Id)
8594 and then Present (Find_Dispatching_Type (Def_Id))
8595 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8599 -- Verify that the homonym is in the same declarative part (not
8600 -- just the same scope). If the pragma comes from an aspect
8601 -- specification we know that it is part of the declaration.
8603 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8604 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8605 and then not From_Aspect_Specification (N)
8610 -- If the pragma comes from an aspect specification the
8611 -- Is_Imported flag has already been set.
8613 if not From_Aspect_Specification (N) then
8614 Set_Imported (Def_Id);
8617 -- Reject an Import applied to an abstract subprogram
8619 if Is_Subprogram (Def_Id)
8620 and then Is_Abstract_Subprogram (Def_Id)
8622 Error_Msg_Sloc := Sloc (Def_Id);
8624 ("cannot import abstract subprogram& declared#",
8628 -- Special processing for Convention_Intrinsic
8630 if C = Convention_Intrinsic then
8632 -- Link_Name argument not allowed for intrinsic
8636 Set_Is_Intrinsic_Subprogram (Def_Id);
8638 -- If no external name is present, then check that this
8639 -- is a valid intrinsic subprogram. If an external name
8640 -- is present, then this is handled by the back end.
8643 Check_Intrinsic_Subprogram
8644 (Def_Id, Get_Pragma_Arg (Arg2));
8648 -- Verify that the subprogram does not have a completion
8649 -- through a renaming declaration. For other completions the
8650 -- pragma appears as a too late representation.
8653 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8657 and then Nkind (Decl) = N_Subprogram_Declaration
8658 and then Present (Corresponding_Body (Decl))
8659 and then Nkind (Unit_Declaration_Node
8660 (Corresponding_Body (Decl))) =
8661 N_Subprogram_Renaming_Declaration
8663 Error_Msg_Sloc := Sloc (Def_Id);
8665 ("cannot import&, renaming already provided for "
8666 & "declaration #", N, Def_Id);
8670 -- If the pragma comes from an aspect specification, there
8671 -- must be an Import aspect specified as well. In the rare
8672 -- case where Import is set to False, the suprogram needs to
8673 -- have a local completion.
8676 Imp_Aspect : constant Node_Id :=
8677 Find_Aspect (Def_Id, Aspect_Import);
8681 if Present (Imp_Aspect)
8682 and then Present (Expression (Imp_Aspect))
8684 Expr := Expression (Imp_Aspect);
8685 Analyze_And_Resolve (Expr, Standard_Boolean);
8687 if Is_Entity_Name (Expr)
8688 and then Entity (Expr) = Standard_True
8690 Set_Has_Completion (Def_Id);
8693 -- If there is no expression, the default is True, as for
8694 -- all boolean aspects. Same for the older pragma.
8697 Set_Has_Completion (Def_Id);
8701 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8704 if Is_Compilation_Unit (Hom_Id) then
8706 -- Its possible homonyms are not affected by the pragma.
8707 -- Such homonyms might be present in the context of other
8708 -- units being compiled.
8712 elsif From_Aspect_Specification (N) then
8715 -- If the pragma was created by the compiler, then we don't
8716 -- want it to apply to other homonyms. This kind of case can
8717 -- occur when using pragma Provide_Shift_Operators, which
8718 -- generates implicit shift and rotate operators with Import
8719 -- pragmas that might apply to earlier explicit or implicit
8720 -- declarations marked with Import (for example, coming from
8721 -- an earlier pragma Provide_Shift_Operators for another type),
8722 -- and we don't generally want other homonyms being treated
8723 -- as imported or the pragma flagged as an illegal duplicate.
8725 elsif not Comes_From_Source (N) then
8729 Hom_Id := Homonym (Hom_Id);
8733 -- Import a CPP class
8735 elsif C = Convention_CPP
8736 and then (Is_Record_Type (Def_Id)
8737 or else Ekind (Def_Id) = E_Incomplete_Type)
8739 if Ekind (Def_Id) = E_Incomplete_Type then
8740 if Present (Full_View (Def_Id)) then
8741 Def_Id := Full_View (Def_Id);
8745 ("cannot import 'C'P'P type before full declaration seen",
8746 Get_Pragma_Arg (Arg2));
8748 -- Although we have reported the error we decorate it as
8749 -- CPP_Class to avoid reporting spurious errors
8751 Set_Is_CPP_Class (Def_Id);
8756 -- Types treated as CPP classes must be declared limited (note:
8757 -- this used to be a warning but there is no real benefit to it
8758 -- since we did effectively intend to treat the type as limited
8761 if not Is_Limited_Type (Def_Id) then
8763 ("imported 'C'P'P type must be limited",
8764 Get_Pragma_Arg (Arg2));
8767 if Etype (Def_Id) /= Def_Id
8768 and then not Is_CPP_Class (Root_Type (Def_Id))
8770 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8773 Set_Is_CPP_Class (Def_Id);
8775 -- Imported CPP types must not have discriminants (because C++
8776 -- classes do not have discriminants).
8778 if Has_Discriminants (Def_Id) then
8780 ("imported 'C'P'P type cannot have discriminants",
8781 First (Discriminant_Specifications
8782 (Declaration_Node (Def_Id))));
8785 -- Check that components of imported CPP types do not have default
8786 -- expressions. For private types this check is performed when the
8787 -- full view is analyzed (see Process_Full_View).
8789 if not Is_Private_Type (Def_Id) then
8790 Check_CPP_Type_Has_No_Defaults (Def_Id);
8793 -- Import a CPP exception
8795 elsif C = Convention_CPP
8796 and then Ekind (Def_Id) = E_Exception
8800 ("'External_'Name arguments is required for 'Cpp exception",
8803 -- As only a string is allowed, Check_Arg_Is_External_Name
8806 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8809 if Present (Arg4) then
8811 ("Link_Name argument not allowed for imported Cpp exception",
8815 -- Do not call Set_Interface_Name as the name of the exception
8816 -- shouldn't be modified (and in particular it shouldn't be
8817 -- the External_Name). For exceptions, the External_Name is the
8818 -- name of the RTTI structure.
8820 -- ??? Emit an error if pragma Import/Export_Exception is present
8822 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8824 Check_Arg_Count (3);
8825 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8827 Process_Import_Predefined_Type;
8831 ("second argument of pragma% must be object, subprogram "
8832 & "or incomplete type",
8836 -- If this pragma applies to a compilation unit, then the unit, which
8837 -- is a subprogram, does not require (or allow) a body. We also do
8838 -- not need to elaborate imported procedures.
8840 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8842 Cunit : constant Node_Id := Parent (Parent (N));
8844 Set_Body_Required (Cunit, False);
8847 end Process_Import_Or_Interface;
8849 --------------------
8850 -- Process_Inline --
8851 --------------------
8853 procedure Process_Inline (Status : Inline_Status) is
8860 Ghost_Error_Posted : Boolean := False;
8861 -- Flag set when an error concerning the illegal mix of Ghost and
8862 -- non-Ghost subprograms is emitted.
8864 Ghost_Id : Entity_Id := Empty;
8865 -- The entity of the first Ghost subprogram encountered while
8866 -- processing the arguments of the pragma.
8868 procedure Make_Inline (Subp : Entity_Id);
8869 -- Subp is the defining unit name of the subprogram declaration. If
8870 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8871 -- the corresponding body, if there is one present.
8873 procedure Set_Inline_Flags (Subp : Entity_Id);
8874 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8875 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8877 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8878 -- Returns True if it can be determined at this stage that inlining
8879 -- is not possible, for example if the body is available and contains
8880 -- exception handlers, we prevent inlining, since otherwise we can
8881 -- get undefined symbols at link time. This function also emits a
8882 -- warning if the pragma appears too late.
8884 -- ??? is business with link symbols still valid, or does it relate
8885 -- to front end ZCX which is being phased out ???
8887 ---------------------------
8888 -- Inlining_Not_Possible --
8889 ---------------------------
8891 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8892 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8896 if Nkind (Decl) = N_Subprogram_Body then
8897 Stats := Handled_Statement_Sequence (Decl);
8898 return Present (Exception_Handlers (Stats))
8899 or else Present (At_End_Proc (Stats));
8901 elsif Nkind (Decl) = N_Subprogram_Declaration
8902 and then Present (Corresponding_Body (Decl))
8904 if Analyzed (Corresponding_Body (Decl)) then
8905 Error_Msg_N ("pragma appears too late, ignored??", N);
8908 -- If the subprogram is a renaming as body, the body is just a
8909 -- call to the renamed subprogram, and inlining is trivially
8913 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8914 N_Subprogram_Renaming_Declaration
8920 Handled_Statement_Sequence
8921 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8924 Present (Exception_Handlers (Stats))
8925 or else Present (At_End_Proc (Stats));
8929 -- If body is not available, assume the best, the check is
8930 -- performed again when compiling enclosing package bodies.
8934 end Inlining_Not_Possible;
8940 procedure Make_Inline (Subp : Entity_Id) is
8941 Kind : constant Entity_Kind := Ekind (Subp);
8942 Inner_Subp : Entity_Id := Subp;
8945 -- Ignore if bad type, avoid cascaded error
8947 if Etype (Subp) = Any_Type then
8951 -- If inlining is not possible, for now do not treat as an error
8953 elsif Status /= Suppressed
8954 and then Front_End_Inlining
8955 and then Inlining_Not_Possible (Subp)
8960 -- Here we have a candidate for inlining, but we must exclude
8961 -- derived operations. Otherwise we would end up trying to inline
8962 -- a phantom declaration, and the result would be to drag in a
8963 -- body which has no direct inlining associated with it. That
8964 -- would not only be inefficient but would also result in the
8965 -- backend doing cross-unit inlining in cases where it was
8966 -- definitely inappropriate to do so.
8968 -- However, a simple Comes_From_Source test is insufficient, since
8969 -- we do want to allow inlining of generic instances which also do
8970 -- not come from source. We also need to recognize specs generated
8971 -- by the front-end for bodies that carry the pragma. Finally,
8972 -- predefined operators do not come from source but are not
8973 -- inlineable either.
8975 elsif Is_Generic_Instance (Subp)
8976 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8980 elsif not Comes_From_Source (Subp)
8981 and then Scope (Subp) /= Standard_Standard
8987 -- The referenced entity must either be the enclosing entity, or
8988 -- an entity declared within the current open scope.
8990 if Present (Scope (Subp))
8991 and then Scope (Subp) /= Current_Scope
8992 and then Subp /= Current_Scope
8995 ("argument of% must be entity in current scope", Assoc);
8999 -- Processing for procedure, operator or function. If subprogram
9000 -- is aliased (as for an instance) indicate that the renamed
9001 -- entity (if declared in the same unit) is inlined.
9002 -- If this is the anonymous subprogram created for a subprogram
9003 -- instance, the inlining applies to it directly. Otherwise we
9004 -- retrieve it as the alias of the visible subprogram instance.
9006 if Is_Subprogram (Subp) then
9007 if Is_Wrapper_Package (Scope (Subp)) then
9010 Inner_Subp := Ultimate_Alias (Inner_Subp);
9013 if In_Same_Source_Unit (Subp, Inner_Subp) then
9014 Set_Inline_Flags (Inner_Subp);
9016 Decl := Parent (Parent (Inner_Subp));
9018 if Nkind (Decl) = N_Subprogram_Declaration
9019 and then Present (Corresponding_Body (Decl))
9021 Set_Inline_Flags (Corresponding_Body (Decl));
9023 elsif Is_Generic_Instance (Subp)
9024 and then Comes_From_Source (Subp)
9026 -- Indicate that the body needs to be created for
9027 -- inlining subsequent calls. The instantiation node
9028 -- follows the declaration of the wrapper package
9029 -- created for it. The subprogram that requires the
9030 -- body is the anonymous one in the wrapper package.
9032 if Scope (Subp) /= Standard_Standard
9034 Need_Subprogram_Instance_Body
9035 (Next (Unit_Declaration_Node
9036 (Scope (Alias (Subp)))), Subp)
9041 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9042 -- appear in a formal part to apply to a formal subprogram.
9043 -- Do not apply check within an instance or a formal package
9044 -- the test will have been applied to the original generic.
9046 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9047 and then List_Containing (Decl) = List_Containing (N)
9048 and then not In_Instance
9051 ("Inline cannot apply to a formal subprogram", N);
9053 -- If Subp is a renaming, it is the renamed entity that
9054 -- will appear in any call, and be inlined. However, for
9055 -- ASIS uses it is convenient to indicate that the renaming
9056 -- itself is an inlined subprogram, so that some gnatcheck
9057 -- rules can be applied in the absence of expansion.
9059 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9060 Set_Inline_Flags (Subp);
9066 -- For a generic subprogram set flag as well, for use at the point
9067 -- of instantiation, to determine whether the body should be
9070 elsif Is_Generic_Subprogram (Subp) then
9071 Set_Inline_Flags (Subp);
9074 -- Literals are by definition inlined
9076 elsif Kind = E_Enumeration_Literal then
9079 -- Anything else is an error
9083 ("expect subprogram name for pragma%", Assoc);
9087 ----------------------
9088 -- Set_Inline_Flags --
9089 ----------------------
9091 procedure Set_Inline_Flags (Subp : Entity_Id) is
9093 -- First set the Has_Pragma_XXX flags and issue the appropriate
9094 -- errors and warnings for suspicious combinations.
9096 if Prag_Id = Pragma_No_Inline then
9097 if Has_Pragma_Inline_Always (Subp) then
9099 ("Inline_Always and No_Inline are mutually exclusive", N);
9100 elsif Has_Pragma_Inline (Subp) then
9102 ("Inline and No_Inline both specified for& ??",
9103 N, Entity (Subp_Id));
9106 Set_Has_Pragma_No_Inline (Subp);
9108 if Prag_Id = Pragma_Inline_Always then
9109 if Has_Pragma_No_Inline (Subp) then
9111 ("Inline_Always and No_Inline are mutually exclusive",
9115 Set_Has_Pragma_Inline_Always (Subp);
9117 if Has_Pragma_No_Inline (Subp) then
9119 ("Inline and No_Inline both specified for& ??",
9120 N, Entity (Subp_Id));
9124 Set_Has_Pragma_Inline (Subp);
9127 -- Then adjust the Is_Inlined flag. It can never be set if the
9128 -- subprogram is subject to pragma No_Inline.
9132 Set_Is_Inlined (Subp, False);
9138 if not Has_Pragma_No_Inline (Subp) then
9139 Set_Is_Inlined (Subp, True);
9143 -- A pragma that applies to a Ghost entity becomes Ghost for the
9144 -- purposes of legality checks and removal of ignored Ghost code.
9146 Mark_Ghost_Pragma (N, Subp);
9148 -- Capture the entity of the first Ghost subprogram being
9149 -- processed for error detection purposes.
9151 if Is_Ghost_Entity (Subp) then
9152 if No (Ghost_Id) then
9156 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9157 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9159 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9160 Ghost_Error_Posted := True;
9162 Error_Msg_Name_1 := Pname;
9164 ("pragma % cannot mention ghost and non-ghost subprograms",
9167 Error_Msg_Sloc := Sloc (Ghost_Id);
9168 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9170 Error_Msg_Sloc := Sloc (Subp);
9171 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9173 end Set_Inline_Flags;
9175 -- Start of processing for Process_Inline
9178 Check_No_Identifiers;
9179 Check_At_Least_N_Arguments (1);
9181 if Status = Enabled then
9182 Inline_Processing_Required := True;
9186 while Present (Assoc) loop
9187 Subp_Id := Get_Pragma_Arg (Assoc);
9191 if Is_Entity_Name (Subp_Id) then
9192 Subp := Entity (Subp_Id);
9194 if Subp = Any_Id then
9196 -- If previous error, avoid cascaded errors
9198 Check_Error_Detected;
9204 -- For the pragma case, climb homonym chain. This is
9205 -- what implements allowing the pragma in the renaming
9206 -- case, with the result applying to the ancestors, and
9207 -- also allows Inline to apply to all previous homonyms.
9209 if not From_Aspect_Specification (N) then
9210 while Present (Homonym (Subp))
9211 and then Scope (Homonym (Subp)) = Current_Scope
9213 Make_Inline (Homonym (Subp));
9214 Subp := Homonym (Subp);
9221 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9227 -- If the context is a package declaration, the pragma indicates
9228 -- that inlining will require the presence of the corresponding
9229 -- body. (this may be further refined).
9232 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9233 N_Package_Declaration
9235 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9239 ----------------------------
9240 -- Process_Interface_Name --
9241 ----------------------------
9243 procedure Process_Interface_Name
9244 (Subprogram_Def : Entity_Id;
9251 String_Val : String_Id;
9253 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9254 -- SN is a string literal node for an interface name. This routine
9255 -- performs some minimal checks that the name is reasonable. In
9256 -- particular that no spaces or other obviously incorrect characters
9257 -- appear. This is only a warning, since any characters are allowed.
9259 ----------------------------------
9260 -- Check_Form_Of_Interface_Name --
9261 ----------------------------------
9263 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9264 S : constant String_Id := Strval (Expr_Value_S (SN));
9265 SL : constant Nat := String_Length (S);
9270 Error_Msg_N ("interface name cannot be null string", SN);
9273 for J in 1 .. SL loop
9274 C := Get_String_Char (S, J);
9276 -- Look for dubious character and issue unconditional warning.
9277 -- Definitely dubious if not in character range.
9279 if not In_Character_Range (C)
9281 -- Commas, spaces and (back)slashes are dubious
9283 or else Get_Character (C) = ','
9284 or else Get_Character (C) = '\'
9285 or else Get_Character (C) = ' '
9286 or else Get_Character (C) = '/'
9289 ("??interface name contains illegal character",
9290 Sloc (SN) + Source_Ptr (J));
9293 end Check_Form_Of_Interface_Name;
9295 -- Start of processing for Process_Interface_Name
9298 -- If we are looking at a pragma that comes from an aspect then it
9299 -- needs to have its corresponding aspect argument expressions
9300 -- analyzed in addition to the generated pragma so that aspects
9301 -- within generic units get properly resolved.
9303 if Present (Prag) and then From_Aspect_Specification (Prag) then
9305 Asp : constant Node_Id := Corresponding_Aspect (Prag);
9313 -- Obtain all interfacing aspects used to construct the pragma
9315 Get_Interfacing_Aspects
9316 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
9318 -- Analyze the expression of aspect External_Name
9320 if Present (EN) then
9321 Analyze (Expression (EN));
9324 -- Analyze the expressio of aspect Link_Name
9326 if Present (LN) then
9327 Analyze (Expression (LN));
9332 if No (Link_Arg) then
9333 if No (Ext_Arg) then
9336 elsif Chars (Ext_Arg) = Name_Link_Name then
9338 Link_Nam := Expression (Ext_Arg);
9341 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9342 Ext_Nam := Expression (Ext_Arg);
9347 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9348 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9349 Ext_Nam := Expression (Ext_Arg);
9350 Link_Nam := Expression (Link_Arg);
9353 -- Check expressions for external name and link name are static
9355 if Present (Ext_Nam) then
9356 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9357 Check_Form_Of_Interface_Name (Ext_Nam);
9359 -- Verify that external name is not the name of a local entity,
9360 -- which would hide the imported one and could lead to run-time
9361 -- surprises. The problem can only arise for entities declared in
9362 -- a package body (otherwise the external name is fully qualified
9363 -- and will not conflict).
9371 if Prag_Id = Pragma_Import then
9372 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
9373 E := Entity_Id (Get_Name_Table_Int (Nam));
9375 if Nam /= Chars (Subprogram_Def)
9376 and then Present (E)
9377 and then not Is_Overloadable (E)
9378 and then Is_Immediately_Visible (E)
9379 and then not Is_Imported (E)
9380 and then Ekind (Scope (E)) = E_Package
9383 while Present (Par) loop
9384 if Nkind (Par) = N_Package_Body then
9385 Error_Msg_Sloc := Sloc (E);
9387 ("imported entity is hidden by & declared#",
9392 Par := Parent (Par);
9399 if Present (Link_Nam) then
9400 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9401 Check_Form_Of_Interface_Name (Link_Nam);
9404 -- If there is no link name, just set the external name
9406 if No (Link_Nam) then
9407 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9409 -- For the Link_Name case, the given literal is preceded by an
9410 -- asterisk, which indicates to GCC that the given name should be
9411 -- taken literally, and in particular that no prepending of
9412 -- underlines should occur, even in systems where this is the
9417 Store_String_Char (Get_Char_Code ('*'));
9418 String_Val := Strval (Expr_Value_S (Link_Nam));
9419 Store_String_Chars (String_Val);
9421 Make_String_Literal (Sloc (Link_Nam),
9422 Strval => End_String);
9425 -- Set the interface name. If the entity is a generic instance, use
9426 -- its alias, which is the callable entity.
9428 if Is_Generic_Instance (Subprogram_Def) then
9429 Set_Encoded_Interface_Name
9430 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9432 Set_Encoded_Interface_Name
9433 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9436 Check_Duplicated_Export_Name (Link_Nam);
9437 end Process_Interface_Name;
9439 -----------------------------------------
9440 -- Process_Interrupt_Or_Attach_Handler --
9441 -----------------------------------------
9443 procedure Process_Interrupt_Or_Attach_Handler is
9444 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9445 Prot_Typ : constant Entity_Id := Scope (Handler);
9448 -- A pragma that applies to a Ghost entity becomes Ghost for the
9449 -- purposes of legality checks and removal of ignored Ghost code.
9451 Mark_Ghost_Pragma (N, Handler);
9452 Set_Is_Interrupt_Handler (Handler);
9454 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9456 Record_Rep_Item (Prot_Typ, N);
9458 -- Chain the pragma on the contract for completeness
9460 Add_Contract_Item (N, Handler);
9461 end Process_Interrupt_Or_Attach_Handler;
9463 --------------------------------------------------
9464 -- Process_Restrictions_Or_Restriction_Warnings --
9465 --------------------------------------------------
9467 -- Note: some of the simple identifier cases were handled in par-prag,
9468 -- but it is harmless (and more straightforward) to simply handle all
9469 -- cases here, even if it means we repeat a bit of work in some cases.
9471 procedure Process_Restrictions_Or_Restriction_Warnings
9475 R_Id : Restriction_Id;
9481 -- Ignore all Restrictions pragmas in CodePeer mode
9483 if CodePeer_Mode then
9487 Check_Ada_83_Warning;
9488 Check_At_Least_N_Arguments (1);
9489 Check_Valid_Configuration_Pragma;
9492 while Present (Arg) loop
9494 Expr := Get_Pragma_Arg (Arg);
9496 -- Case of no restriction identifier present
9498 if Id = No_Name then
9499 if Nkind (Expr) /= N_Identifier then
9501 ("invalid form for restriction", Arg);
9506 (Process_Restriction_Synonyms (Expr));
9508 if R_Id not in All_Boolean_Restrictions then
9509 Error_Msg_Name_1 := Pname;
9511 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9513 -- Check for possible misspelling
9515 for J in Restriction_Id loop
9517 Rnm : constant String := Restriction_Id'Image (J);
9520 Name_Buffer (1 .. Rnm'Length) := Rnm;
9521 Name_Len := Rnm'Length;
9522 Set_Casing (All_Lower_Case);
9524 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9527 (Source_Index (Current_Sem_Unit)));
9528 Error_Msg_String (1 .. Rnm'Length) :=
9529 Name_Buffer (1 .. Name_Len);
9530 Error_Msg_Strlen := Rnm'Length;
9531 Error_Msg_N -- CODEFIX
9532 ("\possible misspelling of ""~""",
9533 Get_Pragma_Arg (Arg));
9542 if Implementation_Restriction (R_Id) then
9543 Check_Restriction (No_Implementation_Restrictions, Arg);
9546 -- Special processing for No_Elaboration_Code restriction
9548 if R_Id = No_Elaboration_Code then
9550 -- Restriction is only recognized within a configuration
9551 -- pragma file, or within a unit of the main extended
9552 -- program. Note: the test for Main_Unit is needed to
9553 -- properly include the case of configuration pragma files.
9555 if not (Current_Sem_Unit = Main_Unit
9556 or else In_Extended_Main_Source_Unit (N))
9560 -- Don't allow in a subunit unless already specified in
9563 elsif Nkind (Parent (N)) = N_Compilation_Unit
9564 and then Nkind (Unit (Parent (N))) = N_Subunit
9565 and then not Restriction_Active (No_Elaboration_Code)
9568 ("invalid specification of ""No_Elaboration_Code""",
9571 ("\restriction cannot be specified in a subunit", N);
9573 ("\unless also specified in body or spec", N);
9576 -- If we accept a No_Elaboration_Code restriction, then it
9577 -- needs to be added to the configuration restriction set so
9578 -- that we get proper application to other units in the main
9579 -- extended source as required.
9582 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9586 -- If this is a warning, then set the warning unless we already
9587 -- have a real restriction active (we never want a warning to
9588 -- override a real restriction).
9591 if not Restriction_Active (R_Id) then
9592 Set_Restriction (R_Id, N);
9593 Restriction_Warnings (R_Id) := True;
9596 -- If real restriction case, then set it and make sure that the
9597 -- restriction warning flag is off, since a real restriction
9598 -- always overrides a warning.
9601 Set_Restriction (R_Id, N);
9602 Restriction_Warnings (R_Id) := False;
9605 -- Check for obsolescent restrictions in Ada 2005 mode
9608 and then Ada_Version >= Ada_2005
9609 and then (R_Id = No_Asynchronous_Control
9611 R_Id = No_Unchecked_Deallocation
9613 R_Id = No_Unchecked_Conversion)
9615 Check_Restriction (No_Obsolescent_Features, N);
9618 -- A very special case that must be processed here: pragma
9619 -- Restrictions (No_Exceptions) turns off all run-time
9620 -- checking. This is a bit dubious in terms of the formal
9621 -- language definition, but it is what is intended by RM
9622 -- H.4(12). Restriction_Warnings never affects generated code
9623 -- so this is done only in the real restriction case.
9625 -- Atomic_Synchronization is not a real check, so it is not
9626 -- affected by this processing).
9628 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9629 -- run-time checks in CodePeer and GNATprove modes: we want to
9630 -- generate checks for analysis purposes, as set respectively
9631 -- by -gnatC and -gnatd.F
9634 and then not (CodePeer_Mode or GNATprove_Mode)
9635 and then R_Id = No_Exceptions
9637 for J in Scope_Suppress.Suppress'Range loop
9638 if J /= Atomic_Synchronization then
9639 Scope_Suppress.Suppress (J) := True;
9644 -- Case of No_Dependence => unit-name. Note that the parser
9645 -- already made the necessary entry in the No_Dependence table.
9647 elsif Id = Name_No_Dependence then
9648 if not OK_No_Dependence_Unit_Name (Expr) then
9652 -- Case of No_Specification_Of_Aspect => aspect-identifier
9654 elsif Id = Name_No_Specification_Of_Aspect then
9659 if Nkind (Expr) /= N_Identifier then
9662 A_Id := Get_Aspect_Id (Chars (Expr));
9665 if A_Id = No_Aspect then
9666 Error_Pragma_Arg ("invalid restriction name", Arg);
9668 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9672 -- Case of No_Use_Of_Attribute => attribute-identifier
9674 elsif Id = Name_No_Use_Of_Attribute then
9675 if Nkind (Expr) /= N_Identifier
9676 or else not Is_Attribute_Name (Chars (Expr))
9678 Error_Msg_N ("unknown attribute name??", Expr);
9681 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9684 -- Case of No_Use_Of_Entity => fully-qualified-name
9686 elsif Id = Name_No_Use_Of_Entity then
9688 -- Restriction is only recognized within a configuration
9689 -- pragma file, or within a unit of the main extended
9690 -- program. Note: the test for Main_Unit is needed to
9691 -- properly include the case of configuration pragma files.
9693 if Current_Sem_Unit = Main_Unit
9694 or else In_Extended_Main_Source_Unit (N)
9696 if not OK_No_Dependence_Unit_Name (Expr) then
9697 Error_Msg_N ("wrong form for entity name", Expr);
9699 Set_Restriction_No_Use_Of_Entity
9700 (Expr, Warn, No_Profile);
9704 -- Case of No_Use_Of_Pragma => pragma-identifier
9706 elsif Id = Name_No_Use_Of_Pragma then
9707 if Nkind (Expr) /= N_Identifier
9708 or else not Is_Pragma_Name (Chars (Expr))
9710 Error_Msg_N ("unknown pragma name??", Expr);
9712 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9715 -- All other cases of restriction identifier present
9718 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9719 Analyze_And_Resolve (Expr, Any_Integer);
9721 if R_Id not in All_Parameter_Restrictions then
9723 ("invalid restriction parameter identifier", Arg);
9725 elsif not Is_OK_Static_Expression (Expr) then
9726 Flag_Non_Static_Expr
9727 ("value must be static expression!", Expr);
9730 elsif not Is_Integer_Type (Etype (Expr))
9731 or else Expr_Value (Expr) < 0
9734 ("value must be non-negative integer", Arg);
9737 -- Restriction pragma is active
9739 Val := Expr_Value (Expr);
9741 if not UI_Is_In_Int_Range (Val) then
9743 ("pragma ignored, value too large??", Arg);
9746 -- Warning case. If the real restriction is active, then we
9747 -- ignore the request, since warning never overrides a real
9748 -- restriction. Otherwise we set the proper warning. Note that
9749 -- this circuit sets the warning again if it is already set,
9750 -- which is what we want, since the constant may have changed.
9753 if not Restriction_Active (R_Id) then
9755 (R_Id, N, Integer (UI_To_Int (Val)));
9756 Restriction_Warnings (R_Id) := True;
9759 -- Real restriction case, set restriction and make sure warning
9760 -- flag is off since real restriction always overrides warning.
9763 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9764 Restriction_Warnings (R_Id) := False;
9770 end Process_Restrictions_Or_Restriction_Warnings;
9772 ---------------------------------
9773 -- Process_Suppress_Unsuppress --
9774 ---------------------------------
9776 -- Note: this procedure makes entries in the check suppress data
9777 -- structures managed by Sem. See spec of package Sem for full
9778 -- details on how we handle recording of check suppression.
9780 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9785 In_Package_Spec : constant Boolean :=
9786 Is_Package_Or_Generic_Package (Current_Scope)
9787 and then not In_Package_Body (Current_Scope);
9789 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9790 -- Used to suppress a single check on the given entity
9792 --------------------------------
9793 -- Suppress_Unsuppress_Echeck --
9794 --------------------------------
9796 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9798 -- Check for error of trying to set atomic synchronization for
9799 -- a non-atomic variable.
9801 if C = Atomic_Synchronization
9802 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9805 ("pragma & requires atomic type or variable",
9806 Pragma_Identifier (Original_Node (N)));
9809 Set_Checks_May_Be_Suppressed (E);
9811 if In_Package_Spec then
9812 Push_Global_Suppress_Stack_Entry
9815 Suppress => Suppress_Case);
9817 Push_Local_Suppress_Stack_Entry
9820 Suppress => Suppress_Case);
9823 -- If this is a first subtype, and the base type is distinct,
9824 -- then also set the suppress flags on the base type.
9826 if Is_First_Subtype (E) and then Etype (E) /= E then
9827 Suppress_Unsuppress_Echeck (Etype (E), C);
9829 end Suppress_Unsuppress_Echeck;
9831 -- Start of processing for Process_Suppress_Unsuppress
9834 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9835 -- on user code: we want to generate checks for analysis purposes, as
9836 -- set respectively by -gnatC and -gnatd.F
9838 if Comes_From_Source (N)
9839 and then (CodePeer_Mode or GNATprove_Mode)
9844 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9845 -- declarative part or a package spec (RM 11.5(5)).
9847 if not Is_Configuration_Pragma then
9848 Check_Is_In_Decl_Part_Or_Package_Spec;
9851 Check_At_Least_N_Arguments (1);
9852 Check_At_Most_N_Arguments (2);
9853 Check_No_Identifier (Arg1);
9854 Check_Arg_Is_Identifier (Arg1);
9856 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9858 if C = No_Check_Id then
9860 ("argument of pragma% is not valid check name", Arg1);
9863 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9865 if C = Elaboration_Check and then SPARK_Mode = On then
9867 ("Suppress of Elaboration_Check ignored in SPARK??",
9868 "\elaboration checking rules are statically enforced "
9869 & "(SPARK RM 7.7)", Arg1);
9872 -- One-argument case
9874 if Arg_Count = 1 then
9876 -- Make an entry in the local scope suppress table. This is the
9877 -- table that directly shows the current value of the scope
9878 -- suppress check for any check id value.
9880 if C = All_Checks then
9882 -- For All_Checks, we set all specific predefined checks with
9883 -- the exception of Elaboration_Check, which is handled
9884 -- specially because of not wanting All_Checks to have the
9885 -- effect of deactivating static elaboration order processing.
9886 -- Atomic_Synchronization is also not affected, since this is
9887 -- not a real check.
9889 for J in Scope_Suppress.Suppress'Range loop
9890 if J /= Elaboration_Check
9892 J /= Atomic_Synchronization
9894 Scope_Suppress.Suppress (J) := Suppress_Case;
9898 -- If not All_Checks, and predefined check, then set appropriate
9899 -- scope entry. Note that we will set Elaboration_Check if this
9900 -- is explicitly specified. Atomic_Synchronization is allowed
9901 -- only if internally generated and entity is atomic.
9903 elsif C in Predefined_Check_Id
9904 and then (not Comes_From_Source (N)
9905 or else C /= Atomic_Synchronization)
9907 Scope_Suppress.Suppress (C) := Suppress_Case;
9910 -- Also make an entry in the Local_Entity_Suppress table
9912 Push_Local_Suppress_Stack_Entry
9915 Suppress => Suppress_Case);
9917 -- Case of two arguments present, where the check is suppressed for
9918 -- a specified entity (given as the second argument of the pragma)
9921 -- This is obsolescent in Ada 2005 mode
9923 if Ada_Version >= Ada_2005 then
9924 Check_Restriction (No_Obsolescent_Features, Arg2);
9927 Check_Optional_Identifier (Arg2, Name_On);
9928 E_Id := Get_Pragma_Arg (Arg2);
9931 if not Is_Entity_Name (E_Id) then
9933 ("second argument of pragma% must be entity name", Arg2);
9942 -- A pragma that applies to a Ghost entity becomes Ghost for the
9943 -- purposes of legality checks and removal of ignored Ghost code.
9945 Mark_Ghost_Pragma (N, E);
9947 -- Enforce RM 11.5(7) which requires that for a pragma that
9948 -- appears within a package spec, the named entity must be
9949 -- within the package spec. We allow the package name itself
9950 -- to be mentioned since that makes sense, although it is not
9951 -- strictly allowed by 11.5(7).
9954 and then E /= Current_Scope
9955 and then Scope (E) /= Current_Scope
9958 ("entity in pragma% is not in package spec (RM 11.5(7))",
9962 -- Loop through homonyms. As noted below, in the case of a package
9963 -- spec, only homonyms within the package spec are considered.
9966 Suppress_Unsuppress_Echeck (E, C);
9968 if Is_Generic_Instance (E)
9969 and then Is_Subprogram (E)
9970 and then Present (Alias (E))
9972 Suppress_Unsuppress_Echeck (Alias (E), C);
9975 -- Move to next homonym if not aspect spec case
9977 exit when From_Aspect_Specification (N);
9981 -- If we are within a package specification, the pragma only
9982 -- applies to homonyms in the same scope.
9984 exit when In_Package_Spec
9985 and then Scope (E) /= Current_Scope;
9988 end Process_Suppress_Unsuppress;
9990 -------------------------------
9991 -- Record_Independence_Check --
9992 -------------------------------
9994 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9996 -- For GCC back ends the validation is done a priori
9998 if not AAMP_On_Target then
10002 Independence_Checks.Append ((N, E));
10003 end Record_Independence_Check;
10009 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10011 if Is_Imported (E) then
10013 ("cannot export entity& that was previously imported", Arg);
10015 elsif Present (Address_Clause (E))
10016 and then not Relaxed_RM_Semantics
10019 ("cannot export entity& that has an address clause", Arg);
10022 Set_Is_Exported (E);
10024 -- Generate a reference for entity explicitly, because the
10025 -- identifier may be overloaded and name resolution will not
10028 Generate_Reference (E, Arg);
10030 -- Deal with exporting non-library level entity
10032 if not Is_Library_Level_Entity (E) then
10034 -- Not allowed at all for subprograms
10036 if Is_Subprogram (E) then
10037 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10039 -- Otherwise set public and statically allocated
10043 Set_Is_Statically_Allocated (E);
10045 -- Warn if the corresponding W flag is set
10047 if Warn_On_Export_Import
10049 -- Only do this for something that was in the source. Not
10050 -- clear if this can be False now (there used for sure to be
10051 -- cases on some systems where it was False), but anyway the
10052 -- test is harmless if not needed, so it is retained.
10054 and then Comes_From_Source (Arg)
10057 ("?x?& has been made static as a result of Export",
10060 ("\?x?this usage is non-standard and non-portable",
10066 if Warn_On_Export_Import and then Is_Type (E) then
10067 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10070 if Warn_On_Export_Import and Inside_A_Generic then
10072 ("all instances of& will have the same external name?x?",
10077 ----------------------------------------------
10078 -- Set_Extended_Import_Export_External_Name --
10079 ----------------------------------------------
10081 procedure Set_Extended_Import_Export_External_Name
10082 (Internal_Ent : Entity_Id;
10083 Arg_External : Node_Id)
10085 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10086 New_Name : Node_Id;
10089 if No (Arg_External) then
10093 Check_Arg_Is_External_Name (Arg_External);
10095 if Nkind (Arg_External) = N_String_Literal then
10096 if String_Length (Strval (Arg_External)) = 0 then
10099 New_Name := Adjust_External_Name_Case (Arg_External);
10102 elsif Nkind (Arg_External) = N_Identifier then
10103 New_Name := Get_Default_External_Name (Arg_External);
10105 -- Check_Arg_Is_External_Name should let through only identifiers and
10106 -- string literals or static string expressions (which are folded to
10107 -- string literals).
10110 raise Program_Error;
10113 -- If we already have an external name set (by a prior normal Import
10114 -- or Export pragma), then the external names must match
10116 if Present (Interface_Name (Internal_Ent)) then
10118 -- Ignore mismatching names in CodePeer mode, to support some
10119 -- old compilers which would export the same procedure under
10120 -- different names, e.g:
10122 -- pragma Export_Procedure (P, "a");
10123 -- pragma Export_Procedure (P, "b");
10125 if CodePeer_Mode then
10129 Check_Matching_Internal_Names : declare
10130 S1 : constant String_Id := Strval (Old_Name);
10131 S2 : constant String_Id := Strval (New_Name);
10133 procedure Mismatch;
10134 pragma No_Return (Mismatch);
10135 -- Called if names do not match
10141 procedure Mismatch is
10143 Error_Msg_Sloc := Sloc (Old_Name);
10145 ("external name does not match that given #",
10149 -- Start of processing for Check_Matching_Internal_Names
10152 if String_Length (S1) /= String_Length (S2) then
10156 for J in 1 .. String_Length (S1) loop
10157 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10162 end Check_Matching_Internal_Names;
10164 -- Otherwise set the given name
10167 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10168 Check_Duplicated_Export_Name (New_Name);
10170 end Set_Extended_Import_Export_External_Name;
10176 procedure Set_Imported (E : Entity_Id) is
10178 -- Error message if already imported or exported
10180 if Is_Exported (E) or else Is_Imported (E) then
10182 -- Error if being set Exported twice
10184 if Is_Exported (E) then
10185 Error_Msg_NE ("entity& was previously exported", N, E);
10187 -- Ignore error in CodePeer mode where we treat all imported
10188 -- subprograms as unknown.
10190 elsif CodePeer_Mode then
10193 -- OK if Import/Interface case
10195 elsif Import_Interface_Present (N) then
10198 -- Error if being set Imported twice
10201 Error_Msg_NE ("entity& was previously imported", N, E);
10204 Error_Msg_Name_1 := Pname;
10206 ("\(pragma% applies to all previous entities)", N);
10208 Error_Msg_Sloc := Sloc (E);
10209 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10211 -- Here if not previously imported or exported, OK to import
10214 Set_Is_Imported (E);
10216 -- For subprogram, set Import_Pragma field
10218 if Is_Subprogram (E) then
10219 Set_Import_Pragma (E, N);
10222 -- If the entity is an object that is not at the library level,
10223 -- then it is statically allocated. We do not worry about objects
10224 -- with address clauses in this context since they are not really
10225 -- imported in the linker sense.
10228 and then not Is_Library_Level_Entity (E)
10229 and then No (Address_Clause (E))
10231 Set_Is_Statically_Allocated (E);
10238 -------------------------
10239 -- Set_Mechanism_Value --
10240 -------------------------
10242 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10243 -- analyzed, since it is semantic nonsense), so we get it in the exact
10244 -- form created by the parser.
10246 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10247 procedure Bad_Mechanism;
10248 pragma No_Return (Bad_Mechanism);
10249 -- Signal bad mechanism name
10251 -------------------------
10252 -- Bad_Mechanism_Value --
10253 -------------------------
10255 procedure Bad_Mechanism is
10257 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10260 -- Start of processing for Set_Mechanism_Value
10263 if Mechanism (Ent) /= Default_Mechanism then
10265 ("mechanism for & has already been set", Mech_Name, Ent);
10268 -- MECHANISM_NAME ::= value | reference
10270 if Nkind (Mech_Name) = N_Identifier then
10271 if Chars (Mech_Name) = Name_Value then
10272 Set_Mechanism (Ent, By_Copy);
10275 elsif Chars (Mech_Name) = Name_Reference then
10276 Set_Mechanism (Ent, By_Reference);
10279 elsif Chars (Mech_Name) = Name_Copy then
10281 ("bad mechanism name, Value assumed", Mech_Name);
10290 end Set_Mechanism_Value;
10292 --------------------------
10293 -- Set_Rational_Profile --
10294 --------------------------
10296 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10297 -- extension to the semantics of renaming declarations.
10299 procedure Set_Rational_Profile is
10301 Implicit_Packing := True;
10302 Overriding_Renamings := True;
10303 Use_VADS_Size := True;
10304 end Set_Rational_Profile;
10306 ---------------------------
10307 -- Set_Ravenscar_Profile --
10308 ---------------------------
10310 -- The tasks to be done here are
10312 -- Set required policies
10314 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10315 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10316 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10317 -- (For GNAT_Ravenscar_EDF profile)
10318 -- pragma Locking_Policy (Ceiling_Locking)
10320 -- Set Detect_Blocking mode
10322 -- Set required restrictions (see System.Rident for detailed list)
10324 -- Set the No_Dependence rules
10325 -- No_Dependence => Ada.Asynchronous_Task_Control
10326 -- No_Dependence => Ada.Calendar
10327 -- No_Dependence => Ada.Execution_Time.Group_Budget
10328 -- No_Dependence => Ada.Execution_Time.Timers
10329 -- No_Dependence => Ada.Task_Attributes
10330 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10332 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10333 procedure Set_Error_Msg_To_Profile_Name;
10334 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10337 -----------------------------------
10338 -- Set_Error_Msg_To_Profile_Name --
10339 -----------------------------------
10341 procedure Set_Error_Msg_To_Profile_Name is
10342 Prof_Nam : constant Node_Id :=
10344 (First (Pragma_Argument_Associations (N)));
10347 Get_Name_String (Chars (Prof_Nam));
10348 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10349 Error_Msg_Strlen := Name_Len;
10350 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10351 end Set_Error_Msg_To_Profile_Name;
10360 Profile_Dispatching_Policy : Character;
10362 -- Start of processing for Set_Ravenscar_Profile
10365 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10367 if Profile = GNAT_Ravenscar_EDF then
10368 Profile_Dispatching_Policy := 'E';
10370 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10373 Profile_Dispatching_Policy := 'F';
10376 if Task_Dispatching_Policy /= ' '
10377 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
10379 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10380 Set_Error_Msg_To_Profile_Name;
10381 Error_Pragma ("Profile (~) incompatible with policy#");
10383 -- Set the FIFO_Within_Priorities policy, but always preserve
10384 -- System_Location since we like the error message with the run time
10388 Task_Dispatching_Policy := Profile_Dispatching_Policy;
10390 if Task_Dispatching_Policy_Sloc /= System_Location then
10391 Task_Dispatching_Policy_Sloc := Loc;
10395 -- pragma Locking_Policy (Ceiling_Locking)
10397 if Locking_Policy /= ' '
10398 and then Locking_Policy /= 'C'
10400 Error_Msg_Sloc := Locking_Policy_Sloc;
10401 Set_Error_Msg_To_Profile_Name;
10402 Error_Pragma ("Profile (~) incompatible with policy#");
10404 -- Set the Ceiling_Locking policy, but preserve System_Location since
10405 -- we like the error message with the run time name.
10408 Locking_Policy := 'C';
10410 if Locking_Policy_Sloc /= System_Location then
10411 Locking_Policy_Sloc := Loc;
10415 -- pragma Detect_Blocking
10417 Detect_Blocking := True;
10419 -- Set the corresponding restrictions
10421 Set_Profile_Restrictions
10422 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10424 -- Set the No_Dependence restrictions
10426 -- The following No_Dependence restrictions:
10427 -- No_Dependence => Ada.Asynchronous_Task_Control
10428 -- No_Dependence => Ada.Calendar
10429 -- No_Dependence => Ada.Task_Attributes
10430 -- are already set by previous call to Set_Profile_Restrictions.
10432 -- Set the following restrictions which were added to Ada 2005:
10433 -- No_Dependence => Ada.Execution_Time.Group_Budget
10434 -- No_Dependence => Ada.Execution_Time.Timers
10436 if Ada_Version >= Ada_2005 then
10437 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
10438 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
10441 Make_Selected_Component
10444 Selector_Name => Sel_Id);
10446 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
10449 Make_Selected_Component
10452 Selector_Name => Sel_Id);
10454 Set_Restriction_No_Dependence
10456 Warn => Treat_Restrictions_As_Warnings,
10457 Profile => Ravenscar);
10459 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
10462 Make_Selected_Component
10465 Selector_Name => Sel_Id);
10467 Set_Restriction_No_Dependence
10469 Warn => Treat_Restrictions_As_Warnings,
10470 Profile => Ravenscar);
10473 -- Set the following restriction which was added to Ada 2012 (see
10475 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10477 if Ada_Version >= Ada_2012 then
10478 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
10479 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
10482 Make_Selected_Component
10485 Selector_Name => Sel_Id);
10487 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
10490 Make_Selected_Component
10493 Selector_Name => Sel_Id);
10495 Set_Restriction_No_Dependence
10497 Warn => Treat_Restrictions_As_Warnings,
10498 Profile => Ravenscar);
10500 end Set_Ravenscar_Profile;
10502 -- Start of processing for Analyze_Pragma
10505 -- The following code is a defense against recursion. Not clear that
10506 -- this can happen legitimately, but perhaps some error situations can
10507 -- cause it, and we did see this recursion during testing.
10509 if Analyzed (N) then
10515 Check_Restriction_No_Use_Of_Pragma (N);
10517 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10518 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10520 if Should_Ignore_Pragma_Sem (N)
10521 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
10522 and then Ignore_Rep_Clauses)
10527 -- Deal with unrecognized pragma
10529 if not Is_Pragma_Name (Pname) then
10530 if Warn_On_Unrecognized_Pragma then
10531 Error_Msg_Name_1 := Pname;
10532 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10534 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10535 if Is_Bad_Spelling_Of (Pname, PN) then
10536 Error_Msg_Name_1 := PN;
10537 Error_Msg_N -- CODEFIX
10538 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10547 -- Here to start processing for recognized pragma
10549 Pname := Original_Aspect_Pragma_Name (N);
10551 -- Capture setting of Opt.Uneval_Old
10553 case Opt.Uneval_Old is
10555 Set_Uneval_Old_Accept (N);
10561 Set_Uneval_Old_Warn (N);
10564 raise Program_Error;
10567 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10568 -- is already set, indicating that we have already checked the policy
10569 -- at the right point. This happens for example in the case of a pragma
10570 -- that is derived from an Aspect.
10572 if Is_Ignored (N) or else Is_Checked (N) then
10575 -- For a pragma that is a rewriting of another pragma, copy the
10576 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10578 elsif Is_Rewrite_Substitution (N)
10579 and then Nkind (Original_Node (N)) = N_Pragma
10580 and then Original_Node (N) /= N
10582 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10583 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10585 -- Otherwise query the applicable policy at this point
10588 Check_Applicable_Policy (N);
10590 -- If pragma is disabled, rewrite as NULL and skip analysis
10592 if Is_Disabled (N) then
10593 Rewrite (N, Make_Null_Statement (Loc));
10599 -- Preset arguments
10607 if Present (Pragma_Argument_Associations (N)) then
10608 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10609 Arg1 := First (Pragma_Argument_Associations (N));
10611 if Present (Arg1) then
10612 Arg2 := Next (Arg1);
10614 if Present (Arg2) then
10615 Arg3 := Next (Arg2);
10617 if Present (Arg3) then
10618 Arg4 := Next (Arg3);
10624 -- An enumeration type defines the pragmas that are supported by the
10625 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10626 -- into the corresponding enumeration value for the following case.
10634 -- pragma Abort_Defer;
10636 when Pragma_Abort_Defer =>
10638 Check_Arg_Count (0);
10640 -- The only required semantic processing is to check the
10641 -- placement. This pragma must appear at the start of the
10642 -- statement sequence of a handled sequence of statements.
10644 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10645 or else N /= First (Statements (Parent (N)))
10650 --------------------
10651 -- Abstract_State --
10652 --------------------
10654 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10656 -- ABSTRACT_STATE_LIST ::=
10658 -- | STATE_NAME_WITH_OPTIONS
10659 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10661 -- STATE_NAME_WITH_OPTIONS ::=
10663 -- | (STATE_NAME with OPTION_LIST)
10665 -- OPTION_LIST ::= OPTION {, OPTION}
10669 -- | NAME_VALUE_OPTION
10671 -- SIMPLE_OPTION ::= Ghost | Synchronous
10673 -- NAME_VALUE_OPTION ::=
10674 -- Part_Of => ABSTRACT_STATE
10675 -- | External [=> EXTERNAL_PROPERTY_LIST]
10677 -- EXTERNAL_PROPERTY_LIST ::=
10678 -- EXTERNAL_PROPERTY
10679 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10681 -- EXTERNAL_PROPERTY ::=
10682 -- Async_Readers [=> boolean_EXPRESSION]
10683 -- | Async_Writers [=> boolean_EXPRESSION]
10684 -- | Effective_Reads [=> boolean_EXPRESSION]
10685 -- | Effective_Writes [=> boolean_EXPRESSION]
10686 -- others => boolean_EXPRESSION
10688 -- STATE_NAME ::= defining_identifier
10690 -- ABSTRACT_STATE ::= name
10692 -- Characteristics:
10694 -- * Analysis - The annotation is fully analyzed immediately upon
10695 -- elaboration as it cannot forward reference entities.
10697 -- * Expansion - None.
10699 -- * Template - The annotation utilizes the generic template of the
10700 -- related package declaration.
10702 -- * Globals - The annotation cannot reference global entities.
10704 -- * Instance - The annotation is instantiated automatically when
10705 -- the related generic package is instantiated.
10707 when Pragma_Abstract_State => Abstract_State : declare
10708 Missing_Parentheses : Boolean := False;
10709 -- Flag set when a state declaration with options is not properly
10712 -- Flags used to verify the consistency of states
10714 Non_Null_Seen : Boolean := False;
10715 Null_Seen : Boolean := False;
10717 procedure Analyze_Abstract_State
10719 Pack_Id : Entity_Id);
10720 -- Verify the legality of a single state declaration. Create and
10721 -- decorate a state abstraction entity and introduce it into the
10722 -- visibility chain. Pack_Id denotes the entity or the related
10723 -- package where pragma Abstract_State appears.
10725 procedure Malformed_State_Error (State : Node_Id);
10726 -- Emit an error concerning the illegal declaration of abstract
10727 -- state State. This routine diagnoses syntax errors that lead to
10728 -- a different parse tree. The error is issued regardless of the
10729 -- SPARK mode in effect.
10731 ----------------------------
10732 -- Analyze_Abstract_State --
10733 ----------------------------
10735 procedure Analyze_Abstract_State
10737 Pack_Id : Entity_Id)
10739 -- Flags used to verify the consistency of options
10741 AR_Seen : Boolean := False;
10742 AW_Seen : Boolean := False;
10743 ER_Seen : Boolean := False;
10744 EW_Seen : Boolean := False;
10745 External_Seen : Boolean := False;
10746 Ghost_Seen : Boolean := False;
10747 Others_Seen : Boolean := False;
10748 Part_Of_Seen : Boolean := False;
10749 Synchronous_Seen : Boolean := False;
10751 -- Flags used to store the static value of all external states'
10754 AR_Val : Boolean := False;
10755 AW_Val : Boolean := False;
10756 ER_Val : Boolean := False;
10757 EW_Val : Boolean := False;
10759 State_Id : Entity_Id := Empty;
10760 -- The entity to be generated for the current state declaration
10762 procedure Analyze_External_Option (Opt : Node_Id);
10763 -- Verify the legality of option External
10765 procedure Analyze_External_Property
10767 Expr : Node_Id := Empty);
10768 -- Verify the legailty of a single external property. Prop
10769 -- denotes the external property. Expr is the expression used
10770 -- to set the property.
10772 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10773 -- Verify the legality of option Part_Of
10775 procedure Check_Duplicate_Option
10777 Status : in out Boolean);
10778 -- Flag Status denotes whether a particular option has been
10779 -- seen while processing a state. This routine verifies that
10780 -- Opt is not a duplicate option and sets the flag Status
10781 -- (SPARK RM 7.1.4(1)).
10783 procedure Check_Duplicate_Property
10785 Status : in out Boolean);
10786 -- Flag Status denotes whether a particular property has been
10787 -- seen while processing option External. This routine verifies
10788 -- that Prop is not a duplicate property and sets flag Status.
10789 -- Opt is not a duplicate property and sets the flag Status.
10790 -- (SPARK RM 7.1.4(2))
10792 procedure Check_Ghost_Synchronous;
10793 -- Ensure that the abstract state is not subject to both Ghost
10794 -- and Synchronous simple options. Emit an error if this is the
10797 procedure Create_Abstract_State
10801 Is_Null : Boolean);
10802 -- Generate an abstract state entity with name Nam and enter it
10803 -- into visibility. Decl is the "declaration" of the state as
10804 -- it appears in pragma Abstract_State. Loc is the location of
10805 -- the related state "declaration". Flag Is_Null should be set
10806 -- when the associated Abstract_State pragma defines a null
10809 -----------------------------
10810 -- Analyze_External_Option --
10811 -----------------------------
10813 procedure Analyze_External_Option (Opt : Node_Id) is
10814 Errors : constant Nat := Serious_Errors_Detected;
10816 Props : Node_Id := Empty;
10819 if Nkind (Opt) = N_Component_Association then
10820 Props := Expression (Opt);
10823 -- External state with properties
10825 if Present (Props) then
10827 -- Multiple properties appear as an aggregate
10829 if Nkind (Props) = N_Aggregate then
10831 -- Simple property form
10833 Prop := First (Expressions (Props));
10834 while Present (Prop) loop
10835 Analyze_External_Property (Prop);
10839 -- Property with expression form
10841 Prop := First (Component_Associations (Props));
10842 while Present (Prop) loop
10843 Analyze_External_Property
10844 (Prop => First (Choices (Prop)),
10845 Expr => Expression (Prop));
10853 Analyze_External_Property (Props);
10856 -- An external state defined without any properties defaults
10857 -- all properties to True.
10866 -- Once all external properties have been processed, verify
10867 -- their mutual interaction. Do not perform the check when
10868 -- at least one of the properties is illegal as this will
10869 -- produce a bogus error.
10871 if Errors = Serious_Errors_Detected then
10872 Check_External_Properties
10873 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10875 end Analyze_External_Option;
10877 -------------------------------
10878 -- Analyze_External_Property --
10879 -------------------------------
10881 procedure Analyze_External_Property
10883 Expr : Node_Id := Empty)
10885 Expr_Val : Boolean;
10888 -- Check the placement of "others" (if available)
10890 if Nkind (Prop) = N_Others_Choice then
10891 if Others_Seen then
10893 ("only one others choice allowed in option External",
10896 Others_Seen := True;
10899 elsif Others_Seen then
10901 ("others must be the last property in option External",
10904 -- The only remaining legal options are the four predefined
10905 -- external properties.
10907 elsif Nkind (Prop) = N_Identifier
10908 and then Nam_In (Chars (Prop), Name_Async_Readers,
10909 Name_Async_Writers,
10910 Name_Effective_Reads,
10911 Name_Effective_Writes)
10915 -- Otherwise the construct is not a valid property
10918 SPARK_Msg_N ("invalid external state property", Prop);
10922 -- Ensure that the expression of the external state property
10923 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10925 if Present (Expr) then
10926 Analyze_And_Resolve (Expr, Standard_Boolean);
10928 if Is_OK_Static_Expression (Expr) then
10929 Expr_Val := Is_True (Expr_Value (Expr));
10932 ("expression of external state property must be "
10936 -- The lack of expression defaults the property to True
10942 -- Named properties
10944 if Nkind (Prop) = N_Identifier then
10945 if Chars (Prop) = Name_Async_Readers then
10946 Check_Duplicate_Property (Prop, AR_Seen);
10947 AR_Val := Expr_Val;
10949 elsif Chars (Prop) = Name_Async_Writers then
10950 Check_Duplicate_Property (Prop, AW_Seen);
10951 AW_Val := Expr_Val;
10953 elsif Chars (Prop) = Name_Effective_Reads then
10954 Check_Duplicate_Property (Prop, ER_Seen);
10955 ER_Val := Expr_Val;
10958 Check_Duplicate_Property (Prop, EW_Seen);
10959 EW_Val := Expr_Val;
10962 -- The handling of property "others" must take into account
10963 -- all other named properties that have been encountered so
10964 -- far. Only those that have not been seen are affected by
10968 if not AR_Seen then
10969 AR_Val := Expr_Val;
10972 if not AW_Seen then
10973 AW_Val := Expr_Val;
10976 if not ER_Seen then
10977 ER_Val := Expr_Val;
10980 if not EW_Seen then
10981 EW_Val := Expr_Val;
10984 end Analyze_External_Property;
10986 ----------------------------
10987 -- Analyze_Part_Of_Option --
10988 ----------------------------
10990 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10991 Encap : constant Node_Id := Expression (Opt);
10992 Constits : Elist_Id;
10993 Encap_Id : Entity_Id;
10997 Check_Duplicate_Option (Opt, Part_Of_Seen);
11000 (Indic => First (Choices (Opt)),
11001 Item_Id => State_Id,
11003 Encap_Id => Encap_Id,
11006 -- The Part_Of indicator transforms the abstract state into
11007 -- a constituent of the encapsulating state or single
11008 -- concurrent type.
11011 pragma Assert (Present (Encap_Id));
11012 Constits := Part_Of_Constituents (Encap_Id);
11014 if No (Constits) then
11015 Constits := New_Elmt_List;
11016 Set_Part_Of_Constituents (Encap_Id, Constits);
11019 Append_Elmt (State_Id, Constits);
11020 Set_Encapsulating_State (State_Id, Encap_Id);
11022 end Analyze_Part_Of_Option;
11024 ----------------------------
11025 -- Check_Duplicate_Option --
11026 ----------------------------
11028 procedure Check_Duplicate_Option
11030 Status : in out Boolean)
11034 SPARK_Msg_N ("duplicate state option", Opt);
11038 end Check_Duplicate_Option;
11040 ------------------------------
11041 -- Check_Duplicate_Property --
11042 ------------------------------
11044 procedure Check_Duplicate_Property
11046 Status : in out Boolean)
11050 SPARK_Msg_N ("duplicate external property", Prop);
11054 end Check_Duplicate_Property;
11056 -----------------------------
11057 -- Check_Ghost_Synchronous --
11058 -----------------------------
11060 procedure Check_Ghost_Synchronous is
11062 -- A synchronized abstract state cannot be Ghost and vice
11063 -- versa (SPARK RM 6.9(19)).
11065 if Ghost_Seen and Synchronous_Seen then
11066 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11068 end Check_Ghost_Synchronous;
11070 ---------------------------
11071 -- Create_Abstract_State --
11072 ---------------------------
11074 procedure Create_Abstract_State
11081 -- The abstract state may be semi-declared when the related
11082 -- package was withed through a limited with clause. In that
11083 -- case reuse the entity to fully declare the state.
11085 if Present (Decl) and then Present (Entity (Decl)) then
11086 State_Id := Entity (Decl);
11088 -- Otherwise the elaboration of pragma Abstract_State
11089 -- declares the state.
11092 State_Id := Make_Defining_Identifier (Loc, Nam);
11094 if Present (Decl) then
11095 Set_Entity (Decl, State_Id);
11099 -- Null states never come from source
11101 Set_Comes_From_Source (State_Id, not Is_Null);
11102 Set_Parent (State_Id, State);
11103 Set_Ekind (State_Id, E_Abstract_State);
11104 Set_Etype (State_Id, Standard_Void_Type);
11105 Set_Encapsulating_State (State_Id, Empty);
11107 -- An abstract state declared within a Ghost region becomes
11108 -- Ghost (SPARK RM 6.9(2)).
11110 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11111 Set_Is_Ghost_Entity (State_Id);
11114 -- Establish a link between the state declaration and the
11115 -- abstract state entity. Note that a null state remains as
11116 -- N_Null and does not carry any linkages.
11118 if not Is_Null then
11119 if Present (Decl) then
11120 Set_Entity (Decl, State_Id);
11121 Set_Etype (Decl, Standard_Void_Type);
11124 -- Every non-null state must be defined, nameable and
11127 Push_Scope (Pack_Id);
11128 Generate_Definition (State_Id);
11129 Enter_Name (State_Id);
11132 end Create_Abstract_State;
11139 -- Start of processing for Analyze_Abstract_State
11142 -- A package with a null abstract state is not allowed to
11143 -- declare additional states.
11147 ("package & has null abstract state", State, Pack_Id);
11149 -- Null states appear as internally generated entities
11151 elsif Nkind (State) = N_Null then
11152 Create_Abstract_State
11153 (Nam => New_Internal_Name ('S'),
11155 Loc => Sloc (State),
11159 -- Catch a case where a null state appears in a list of
11160 -- non-null states.
11162 if Non_Null_Seen then
11164 ("package & has non-null abstract state",
11168 -- Simple state declaration
11170 elsif Nkind (State) = N_Identifier then
11171 Create_Abstract_State
11172 (Nam => Chars (State),
11174 Loc => Sloc (State),
11176 Non_Null_Seen := True;
11178 -- State declaration with various options. This construct
11179 -- appears as an extension aggregate in the tree.
11181 elsif Nkind (State) = N_Extension_Aggregate then
11182 if Nkind (Ancestor_Part (State)) = N_Identifier then
11183 Create_Abstract_State
11184 (Nam => Chars (Ancestor_Part (State)),
11185 Decl => Ancestor_Part (State),
11186 Loc => Sloc (Ancestor_Part (State)),
11188 Non_Null_Seen := True;
11191 ("state name must be an identifier",
11192 Ancestor_Part (State));
11195 -- Options External, Ghost and Synchronous appear as
11198 Opt := First (Expressions (State));
11199 while Present (Opt) loop
11200 if Nkind (Opt) = N_Identifier then
11204 if Chars (Opt) = Name_External then
11205 Check_Duplicate_Option (Opt, External_Seen);
11206 Analyze_External_Option (Opt);
11210 elsif Chars (Opt) = Name_Ghost then
11211 Check_Duplicate_Option (Opt, Ghost_Seen);
11212 Check_Ghost_Synchronous;
11214 if Present (State_Id) then
11215 Set_Is_Ghost_Entity (State_Id);
11220 elsif Chars (Opt) = Name_Synchronous then
11221 Check_Duplicate_Option (Opt, Synchronous_Seen);
11222 Check_Ghost_Synchronous;
11224 -- Option Part_Of without an encapsulating state is
11225 -- illegal (SPARK RM 7.1.4(9)).
11227 elsif Chars (Opt) = Name_Part_Of then
11229 ("indicator Part_Of must denote abstract state, "
11230 & "single protected type or single task type",
11233 -- Do not emit an error message when a previous state
11234 -- declaration with options was not parenthesized as
11235 -- the option is actually another state declaration.
11237 -- with Abstract_State
11238 -- (State_1 with ..., -- missing parentheses
11239 -- (State_2 with ...),
11240 -- State_3) -- ok state declaration
11242 elsif Missing_Parentheses then
11245 -- Otherwise the option is not allowed. Note that it
11246 -- is not possible to distinguish between an option
11247 -- and a state declaration when a previous state with
11248 -- options not properly parentheses.
11250 -- with Abstract_State
11251 -- (State_1 with ..., -- missing parentheses
11252 -- State_2); -- could be an option
11256 ("simple option not allowed in state declaration",
11260 -- Catch a case where missing parentheses around a state
11261 -- declaration with options cause a subsequent state
11262 -- declaration with options to be treated as an option.
11264 -- with Abstract_State
11265 -- (State_1 with ..., -- missing parentheses
11266 -- (State_2 with ...))
11268 elsif Nkind (Opt) = N_Extension_Aggregate then
11269 Missing_Parentheses := True;
11271 ("state declaration must be parenthesized",
11272 Ancestor_Part (State));
11274 -- Otherwise the option is malformed
11277 SPARK_Msg_N ("malformed option", Opt);
11283 -- Options External and Part_Of appear as component
11286 Opt := First (Component_Associations (State));
11287 while Present (Opt) loop
11288 Opt_Nam := First (Choices (Opt));
11290 if Nkind (Opt_Nam) = N_Identifier then
11291 if Chars (Opt_Nam) = Name_External then
11292 Analyze_External_Option (Opt);
11294 elsif Chars (Opt_Nam) = Name_Part_Of then
11295 Analyze_Part_Of_Option (Opt);
11298 SPARK_Msg_N ("invalid state option", Opt);
11301 SPARK_Msg_N ("invalid state option", Opt);
11307 -- Any other attempt to declare a state is illegal
11310 Malformed_State_Error (State);
11314 -- Guard against a junk state. In such cases no entity is
11315 -- generated and the subsequent checks cannot be applied.
11317 if Present (State_Id) then
11319 -- Verify whether the state does not introduce an illegal
11320 -- hidden state within a package subject to a null abstract
11323 Check_No_Hidden_State (State_Id);
11325 -- Check whether the lack of option Part_Of agrees with the
11326 -- placement of the abstract state with respect to the state
11329 if not Part_Of_Seen then
11330 Check_Missing_Part_Of (State_Id);
11333 -- Associate the state with its related package
11335 if No (Abstract_States (Pack_Id)) then
11336 Set_Abstract_States (Pack_Id, New_Elmt_List);
11339 Append_Elmt (State_Id, Abstract_States (Pack_Id));
11341 end Analyze_Abstract_State;
11343 ---------------------------
11344 -- Malformed_State_Error --
11345 ---------------------------
11347 procedure Malformed_State_Error (State : Node_Id) is
11349 Error_Msg_N ("malformed abstract state declaration", State);
11351 -- An abstract state with a simple option is being declared
11352 -- with "=>" rather than the legal "with". The state appears
11353 -- as a component association.
11355 if Nkind (State) = N_Component_Association then
11356 Error_Msg_N ("\use WITH to specify simple option", State);
11358 end Malformed_State_Error;
11362 Pack_Decl : Node_Id;
11363 Pack_Id : Entity_Id;
11367 -- Start of processing for Abstract_State
11371 Check_No_Identifiers;
11372 Check_Arg_Count (1);
11374 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11376 -- Ensure the proper placement of the pragma. Abstract states must
11377 -- be associated with a package declaration.
11379 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11380 N_Package_Declaration)
11384 -- Otherwise the pragma is associated with an illegal construct
11391 Pack_Id := Defining_Entity (Pack_Decl);
11393 -- A pragma that applies to a Ghost entity becomes Ghost for the
11394 -- purposes of legality checks and removal of ignored Ghost code.
11396 Mark_Ghost_Pragma (N, Pack_Id);
11397 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11399 -- Chain the pragma on the contract for completeness
11401 Add_Contract_Item (N, Pack_Id);
11403 -- The legality checks of pragmas Abstract_State, Initializes, and
11404 -- Initial_Condition are affected by the SPARK mode in effect. In
11405 -- addition, these three pragmas are subject to an inherent order:
11407 -- 1) Abstract_State
11409 -- 3) Initial_Condition
11411 -- Analyze all these pragmas in the order outlined above
11413 Analyze_If_Present (Pragma_SPARK_Mode);
11414 States := Expression (Get_Argument (N, Pack_Id));
11416 -- Multiple non-null abstract states appear as an aggregate
11418 if Nkind (States) = N_Aggregate then
11419 State := First (Expressions (States));
11420 while Present (State) loop
11421 Analyze_Abstract_State (State, Pack_Id);
11425 -- An abstract state with a simple option is being illegaly
11426 -- declared with "=>" rather than "with". In this case the
11427 -- state declaration appears as a component association.
11429 if Present (Component_Associations (States)) then
11430 State := First (Component_Associations (States));
11431 while Present (State) loop
11432 Malformed_State_Error (State);
11437 -- Various forms of a single abstract state. Note that these may
11438 -- include malformed state declarations.
11441 Analyze_Abstract_State (States, Pack_Id);
11444 Analyze_If_Present (Pragma_Initializes);
11445 Analyze_If_Present (Pragma_Initial_Condition);
11446 end Abstract_State;
11454 -- Note: this pragma also has some specific processing in Par.Prag
11455 -- because we want to set the Ada version mode during parsing.
11457 when Pragma_Ada_83 =>
11459 Check_Arg_Count (0);
11461 -- We really should check unconditionally for proper configuration
11462 -- pragma placement, since we really don't want mixed Ada modes
11463 -- within a single unit, and the GNAT reference manual has always
11464 -- said this was a configuration pragma, but we did not check and
11465 -- are hesitant to add the check now.
11467 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11468 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11469 -- or Ada 2012 mode.
11471 if Ada_Version >= Ada_2005 then
11472 Check_Valid_Configuration_Pragma;
11475 -- Now set Ada 83 mode
11477 if Latest_Ada_Only then
11478 Error_Pragma ("??pragma% ignored");
11480 Ada_Version := Ada_83;
11481 Ada_Version_Explicit := Ada_83;
11482 Ada_Version_Pragma := N;
11491 -- Note: this pragma also has some specific processing in Par.Prag
11492 -- because we want to set the Ada 83 version mode during parsing.
11494 when Pragma_Ada_95 =>
11496 Check_Arg_Count (0);
11498 -- We really should check unconditionally for proper configuration
11499 -- pragma placement, since we really don't want mixed Ada modes
11500 -- within a single unit, and the GNAT reference manual has always
11501 -- said this was a configuration pragma, but we did not check and
11502 -- are hesitant to add the check now.
11504 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11505 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11507 if Ada_Version >= Ada_2005 then
11508 Check_Valid_Configuration_Pragma;
11511 -- Now set Ada 95 mode
11513 if Latest_Ada_Only then
11514 Error_Pragma ("??pragma% ignored");
11516 Ada_Version := Ada_95;
11517 Ada_Version_Explicit := Ada_95;
11518 Ada_Version_Pragma := N;
11521 ---------------------
11522 -- Ada_05/Ada_2005 --
11523 ---------------------
11526 -- pragma Ada_05 (LOCAL_NAME);
11528 -- pragma Ada_2005;
11529 -- pragma Ada_2005 (LOCAL_NAME):
11531 -- Note: these pragmas also have some specific processing in Par.Prag
11532 -- because we want to set the Ada 2005 version mode during parsing.
11534 -- The one argument form is used for managing the transition from
11535 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11536 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11537 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11538 -- mode, a preference rule is established which does not choose
11539 -- such an entity unless it is unambiguously specified. This avoids
11540 -- extra subprograms marked this way from generating ambiguities in
11541 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11542 -- intended for exclusive use in the GNAT run-time library.
11553 if Arg_Count = 1 then
11554 Check_Arg_Is_Local_Name (Arg1);
11555 E_Id := Get_Pragma_Arg (Arg1);
11557 if Etype (E_Id) = Any_Type then
11561 Set_Is_Ada_2005_Only (Entity (E_Id));
11562 Record_Rep_Item (Entity (E_Id), N);
11565 Check_Arg_Count (0);
11567 -- For Ada_2005 we unconditionally enforce the documented
11568 -- configuration pragma placement, since we do not want to
11569 -- tolerate mixed modes in a unit involving Ada 2005. That
11570 -- would cause real difficulties for those cases where there
11571 -- are incompatibilities between Ada 95 and Ada 2005.
11573 Check_Valid_Configuration_Pragma;
11575 -- Now set appropriate Ada mode
11577 if Latest_Ada_Only then
11578 Error_Pragma ("??pragma% ignored");
11580 Ada_Version := Ada_2005;
11581 Ada_Version_Explicit := Ada_2005;
11582 Ada_Version_Pragma := N;
11587 ---------------------
11588 -- Ada_12/Ada_2012 --
11589 ---------------------
11592 -- pragma Ada_12 (LOCAL_NAME);
11594 -- pragma Ada_2012;
11595 -- pragma Ada_2012 (LOCAL_NAME):
11597 -- Note: these pragmas also have some specific processing in Par.Prag
11598 -- because we want to set the Ada 2012 version mode during parsing.
11600 -- The one argument form is used for managing the transition from Ada
11601 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11602 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11603 -- mode will generate a warning. In addition, in any pre-Ada_2012
11604 -- mode, a preference rule is established which does not choose
11605 -- such an entity unless it is unambiguously specified. This avoids
11606 -- extra subprograms marked this way from generating ambiguities in
11607 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11608 -- intended for exclusive use in the GNAT run-time library.
11619 if Arg_Count = 1 then
11620 Check_Arg_Is_Local_Name (Arg1);
11621 E_Id := Get_Pragma_Arg (Arg1);
11623 if Etype (E_Id) = Any_Type then
11627 Set_Is_Ada_2012_Only (Entity (E_Id));
11628 Record_Rep_Item (Entity (E_Id), N);
11631 Check_Arg_Count (0);
11633 -- For Ada_2012 we unconditionally enforce the documented
11634 -- configuration pragma placement, since we do not want to
11635 -- tolerate mixed modes in a unit involving Ada 2012. That
11636 -- would cause real difficulties for those cases where there
11637 -- are incompatibilities between Ada 95 and Ada 2012. We could
11638 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11640 Check_Valid_Configuration_Pragma;
11642 -- Now set appropriate Ada mode
11644 Ada_Version := Ada_2012;
11645 Ada_Version_Explicit := Ada_2012;
11646 Ada_Version_Pragma := N;
11650 ----------------------
11651 -- All_Calls_Remote --
11652 ----------------------
11654 -- pragma All_Calls_Remote [(library_package_NAME)];
11656 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11657 Lib_Entity : Entity_Id;
11660 Check_Ada_83_Warning;
11661 Check_Valid_Library_Unit_Pragma;
11663 if Nkind (N) = N_Null_Statement then
11667 Lib_Entity := Find_Lib_Unit_Name;
11669 -- A pragma that applies to a Ghost entity becomes Ghost for the
11670 -- purposes of legality checks and removal of ignored Ghost code.
11672 Mark_Ghost_Pragma (N, Lib_Entity);
11674 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11676 if Present (Lib_Entity) and then not Debug_Flag_U then
11677 if not Is_Remote_Call_Interface (Lib_Entity) then
11678 Error_Pragma ("pragma% only apply to rci unit");
11680 -- Set flag for entity of the library unit
11683 Set_Has_All_Calls_Remote (Lib_Entity);
11686 end All_Calls_Remote;
11688 ---------------------------
11689 -- Allow_Integer_Address --
11690 ---------------------------
11692 -- pragma Allow_Integer_Address;
11694 when Pragma_Allow_Integer_Address =>
11696 Check_Valid_Configuration_Pragma;
11697 Check_Arg_Count (0);
11699 -- If Address is a private type, then set the flag to allow
11700 -- integer address values. If Address is not private, then this
11701 -- pragma has no purpose, so it is simply ignored. Not clear if
11702 -- there are any such targets now.
11704 if Opt.Address_Is_Private then
11705 Opt.Allow_Integer_Address := True;
11713 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11714 -- ARG ::= NAME | EXPRESSION
11716 -- The first two arguments are by convention intended to refer to an
11717 -- external tool and a tool-specific function. These arguments are
11720 when Pragma_Annotate => Annotate : declare
11727 Check_At_Least_N_Arguments (1);
11729 Nam_Arg := Last (Pragma_Argument_Associations (N));
11731 -- Determine whether the last argument is "Entity => local_NAME"
11732 -- and if it is, perform the required semantic checks. Remove the
11733 -- argument from further processing.
11735 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11736 and then Chars (Nam_Arg) = Name_Entity
11738 Check_Arg_Is_Local_Name (Nam_Arg);
11739 Arg_Count := Arg_Count - 1;
11741 -- A pragma that applies to a Ghost entity becomes Ghost for
11742 -- the purposes of legality checks and removal of ignored Ghost
11745 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11746 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11748 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11751 -- Not allowed in compiler units (bootstrap issues)
11753 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11756 -- Continue the processing with last argument removed for now
11758 Check_Arg_Is_Identifier (Arg1);
11759 Check_No_Identifiers;
11762 -- The second parameter is optional, it is never analyzed
11767 -- Otherwise there is a second parameter
11770 -- The second parameter must be an identifier
11772 Check_Arg_Is_Identifier (Arg2);
11774 -- Process the remaining parameters (if any)
11776 Arg := Next (Arg2);
11777 while Present (Arg) loop
11778 Expr := Get_Pragma_Arg (Arg);
11781 if Is_Entity_Name (Expr) then
11784 -- For string literals, we assume Standard_String as the
11785 -- type, unless the string contains wide or wide_wide
11788 elsif Nkind (Expr) = N_String_Literal then
11789 if Has_Wide_Wide_Character (Expr) then
11790 Resolve (Expr, Standard_Wide_Wide_String);
11791 elsif Has_Wide_Character (Expr) then
11792 Resolve (Expr, Standard_Wide_String);
11794 Resolve (Expr, Standard_String);
11797 elsif Is_Overloaded (Expr) then
11798 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11809 -------------------------------------------------
11810 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11811 -------------------------------------------------
11814 -- ( [Check => ] Boolean_EXPRESSION
11815 -- [, [Message =>] Static_String_EXPRESSION]);
11817 -- pragma Assert_And_Cut
11818 -- ( [Check => ] Boolean_EXPRESSION
11819 -- [, [Message =>] Static_String_EXPRESSION]);
11822 -- ( [Check => ] Boolean_EXPRESSION
11823 -- [, [Message =>] Static_String_EXPRESSION]);
11825 -- pragma Loop_Invariant
11826 -- ( [Check => ] Boolean_EXPRESSION
11827 -- [, [Message =>] Static_String_EXPRESSION]);
11830 | Pragma_Assert_And_Cut
11832 | Pragma_Loop_Invariant
11835 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11836 -- Determine whether expression Expr contains a Loop_Entry
11837 -- attribute reference.
11839 -------------------------
11840 -- Contains_Loop_Entry --
11841 -------------------------
11843 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11844 Has_Loop_Entry : Boolean := False;
11846 function Process (N : Node_Id) return Traverse_Result;
11847 -- Process function for traversal to look for Loop_Entry
11853 function Process (N : Node_Id) return Traverse_Result is
11855 if Nkind (N) = N_Attribute_Reference
11856 and then Attribute_Name (N) = Name_Loop_Entry
11858 Has_Loop_Entry := True;
11865 procedure Traverse is new Traverse_Proc (Process);
11867 -- Start of processing for Contains_Loop_Entry
11871 return Has_Loop_Entry;
11872 end Contains_Loop_Entry;
11877 New_Args : List_Id;
11879 -- Start of processing for Assert
11882 -- Assert is an Ada 2005 RM-defined pragma
11884 if Prag_Id = Pragma_Assert then
11887 -- The remaining ones are GNAT pragmas
11893 Check_At_Least_N_Arguments (1);
11894 Check_At_Most_N_Arguments (2);
11895 Check_Arg_Order ((Name_Check, Name_Message));
11896 Check_Optional_Identifier (Arg1, Name_Check);
11897 Expr := Get_Pragma_Arg (Arg1);
11899 -- Special processing for Loop_Invariant, Loop_Variant or for
11900 -- other cases where a Loop_Entry attribute is present. If the
11901 -- assertion pragma contains attribute Loop_Entry, ensure that
11902 -- the related pragma is within a loop.
11904 if Prag_Id = Pragma_Loop_Invariant
11905 or else Prag_Id = Pragma_Loop_Variant
11906 or else Contains_Loop_Entry (Expr)
11908 Check_Loop_Pragma_Placement;
11910 -- Perform preanalysis to deal with embedded Loop_Entry
11913 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11916 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11917 -- a corresponding Check pragma:
11919 -- pragma Check (name, condition [, msg]);
11921 -- Where name is the identifier matching the pragma name. So
11922 -- rewrite pragma in this manner, transfer the message argument
11923 -- if present, and analyze the result
11925 -- Note: When dealing with a semantically analyzed tree, the
11926 -- information that a Check node N corresponds to a source Assert,
11927 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11928 -- pragma kind of Original_Node(N).
11930 New_Args := New_List (
11931 Make_Pragma_Argument_Association (Loc,
11932 Expression => Make_Identifier (Loc, Pname)),
11933 Make_Pragma_Argument_Association (Sloc (Expr),
11934 Expression => Expr));
11936 if Arg_Count > 1 then
11937 Check_Optional_Identifier (Arg2, Name_Message);
11939 -- Provide semantic annnotations for optional argument, for
11940 -- ASIS use, before rewriting.
11942 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11943 Append_To (New_Args, New_Copy_Tree (Arg2));
11946 -- Rewrite as Check pragma
11950 Chars => Name_Check,
11951 Pragma_Argument_Associations => New_Args));
11956 ----------------------
11957 -- Assertion_Policy --
11958 ----------------------
11960 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11962 -- The following form is Ada 2012 only, but we allow it in all modes
11964 -- Pragma Assertion_Policy (
11965 -- ASSERTION_KIND => POLICY_IDENTIFIER
11966 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11968 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11970 -- RM_ASSERTION_KIND ::= Assert |
11971 -- Static_Predicate |
11972 -- Dynamic_Predicate |
11977 -- Type_Invariant |
11978 -- Type_Invariant'Class
11980 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11982 -- Contract_Cases |
11984 -- Default_Initial_Condition |
11986 -- Initial_Condition |
11987 -- Loop_Invariant |
11993 -- Statement_Assertions
11995 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11996 -- ID_ASSERTION_KIND list contains implementation-defined additions
11997 -- recognized by GNAT. The effect is to control the behavior of
11998 -- identically named aspects and pragmas, depending on the specified
11999 -- policy identifier:
12001 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12003 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12004 -- implementation-defined addition that results in totally ignoring
12005 -- the corresponding assertion. If Disable is specified, then the
12006 -- argument of the assertion is not even analyzed. This is useful
12007 -- when the aspect/pragma argument references entities in a with'ed
12008 -- package that is replaced by a dummy package in the final build.
12010 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12011 -- and Type_Invariant'Class were recognized by the parser and
12012 -- transformed into references to the special internal identifiers
12013 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12014 -- processing is required here.
12016 when Pragma_Assertion_Policy => Assertion_Policy : declare
12017 procedure Resolve_Suppressible (Policy : Node_Id);
12018 -- Converts the assertion policy 'Suppressible' to either Check or
12019 -- Ignore based on whether checks are suppressed via -gnatp.
12021 --------------------------
12022 -- Resolve_Suppressible --
12023 --------------------------
12025 procedure Resolve_Suppressible (Policy : Node_Id) is
12026 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12030 -- Transform policy argument Suppressible into either Ignore or
12031 -- Check depending on whether checks are enabled or suppressed.
12033 if Chars (Arg) = Name_Suppressible then
12034 if Suppress_Checks then
12035 Nam := Name_Ignore;
12040 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12042 end Resolve_Suppressible;
12054 -- This can always appear as a configuration pragma
12056 if Is_Configuration_Pragma then
12059 -- It can also appear in a declarative part or package spec in Ada
12060 -- 2012 mode. We allow this in other modes, but in that case we
12061 -- consider that we have an Ada 2012 pragma on our hands.
12064 Check_Is_In_Decl_Part_Or_Package_Spec;
12068 -- One argument case with no identifier (first form above)
12071 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
12072 or else Chars (Arg1) = No_Name)
12074 Check_Arg_Is_One_Of (Arg1,
12075 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12077 Resolve_Suppressible (Arg1);
12079 -- Treat one argument Assertion_Policy as equivalent to:
12081 -- pragma Check_Policy (Assertion, policy)
12083 -- So rewrite pragma in that manner and link on to the chain
12084 -- of Check_Policy pragmas, marking the pragma as analyzed.
12086 Policy := Get_Pragma_Arg (Arg1);
12090 Chars => Name_Check_Policy,
12091 Pragma_Argument_Associations => New_List (
12092 Make_Pragma_Argument_Association (Loc,
12093 Expression => Make_Identifier (Loc, Name_Assertion)),
12095 Make_Pragma_Argument_Association (Loc,
12097 Make_Identifier (Sloc (Policy), Chars (Policy))))));
12100 -- Here if we have two or more arguments
12103 Check_At_Least_N_Arguments (1);
12106 -- Loop through arguments
12109 while Present (Arg) loop
12110 LocP := Sloc (Arg);
12112 -- Kind must be specified
12114 if Nkind (Arg) /= N_Pragma_Argument_Association
12115 or else Chars (Arg) = No_Name
12118 ("missing assertion kind for pragma%", Arg);
12121 -- Check Kind and Policy have allowed forms
12123 Kind := Chars (Arg);
12124 Policy := Get_Pragma_Arg (Arg);
12126 if not Is_Valid_Assertion_Kind (Kind) then
12128 ("invalid assertion kind for pragma%", Arg);
12131 Check_Arg_Is_One_Of (Arg,
12132 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12134 Resolve_Suppressible (Arg);
12136 if Kind = Name_Ghost then
12138 -- The Ghost policy must be either Check or Ignore
12139 -- (SPARK RM 6.9(6)).
12141 if not Nam_In (Chars (Policy), Name_Check,
12145 ("argument of pragma % Ghost must be Check or "
12146 & "Ignore", Policy);
12149 -- Pragma Assertion_Policy specifying a Ghost policy
12150 -- cannot occur within a Ghost subprogram or package
12151 -- (SPARK RM 6.9(14)).
12153 if Ghost_Mode > None then
12155 ("pragma % cannot appear within ghost subprogram or "
12160 -- Rewrite the Assertion_Policy pragma as a series of
12161 -- Check_Policy pragmas of the form:
12163 -- Check_Policy (Kind, Policy);
12165 -- Note: the insertion of the pragmas cannot be done with
12166 -- Insert_Action because in the configuration case, there
12167 -- are no scopes on the scope stack and the mechanism will
12170 Insert_Before_And_Analyze (N,
12172 Chars => Name_Check_Policy,
12173 Pragma_Argument_Associations => New_List (
12174 Make_Pragma_Argument_Association (LocP,
12175 Expression => Make_Identifier (LocP, Kind)),
12176 Make_Pragma_Argument_Association (LocP,
12177 Expression => Policy))));
12182 -- Rewrite the Assertion_Policy pragma as null since we have
12183 -- now inserted all the equivalent Check pragmas.
12185 Rewrite (N, Make_Null_Statement (Loc));
12188 end Assertion_Policy;
12190 ------------------------------
12191 -- Assume_No_Invalid_Values --
12192 ------------------------------
12194 -- pragma Assume_No_Invalid_Values (On | Off);
12196 when Pragma_Assume_No_Invalid_Values =>
12198 Check_Valid_Configuration_Pragma;
12199 Check_Arg_Count (1);
12200 Check_No_Identifiers;
12201 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12203 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12204 Assume_No_Invalid_Values := True;
12206 Assume_No_Invalid_Values := False;
12209 --------------------------
12210 -- Attribute_Definition --
12211 --------------------------
12213 -- pragma Attribute_Definition
12214 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12215 -- [Entity =>] LOCAL_NAME,
12216 -- [Expression =>] EXPRESSION | NAME);
12218 when Pragma_Attribute_Definition => Attribute_Definition : declare
12219 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12224 Check_Arg_Count (3);
12225 Check_Optional_Identifier (Arg1, "attribute");
12226 Check_Optional_Identifier (Arg2, "entity");
12227 Check_Optional_Identifier (Arg3, "expression");
12229 if Nkind (Attribute_Designator) /= N_Identifier then
12230 Error_Msg_N ("attribute name expected", Attribute_Designator);
12234 Check_Arg_Is_Local_Name (Arg2);
12236 -- If the attribute is not recognized, then issue a warning (not
12237 -- an error), and ignore the pragma.
12239 Aname := Chars (Attribute_Designator);
12241 if not Is_Attribute_Name (Aname) then
12242 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12246 -- Otherwise, rewrite the pragma as an attribute definition clause
12249 Make_Attribute_Definition_Clause (Loc,
12250 Name => Get_Pragma_Arg (Arg2),
12252 Expression => Get_Pragma_Arg (Arg3)));
12254 end Attribute_Definition;
12256 ------------------------------------------------------------------
12257 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12258 ------------------------------------------------------------------
12260 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12261 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12262 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12263 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12265 when Pragma_Async_Readers
12266 | Pragma_Async_Writers
12267 | Pragma_Effective_Reads
12268 | Pragma_Effective_Writes
12270 Async_Effective : declare
12271 Obj_Decl : Node_Id;
12272 Obj_Id : Entity_Id;
12276 Check_No_Identifiers;
12277 Check_At_Most_N_Arguments (1);
12279 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12281 -- Object declaration
12283 if Nkind (Obj_Decl) = N_Object_Declaration then
12286 -- Otherwise the pragma is associated with an illegal construact
12293 Obj_Id := Defining_Entity (Obj_Decl);
12295 -- Perform minimal verification to ensure that the argument is at
12296 -- least a variable. Subsequent finer grained checks will be done
12297 -- at the end of the declarative region the contains the pragma.
12299 if Ekind (Obj_Id) = E_Variable then
12301 -- A pragma that applies to a Ghost entity becomes Ghost for
12302 -- the purposes of legality checks and removal of ignored Ghost
12305 Mark_Ghost_Pragma (N, Obj_Id);
12307 -- Chain the pragma on the contract for further processing by
12308 -- Analyze_External_Property_In_Decl_Part.
12310 Add_Contract_Item (N, Obj_Id);
12312 -- Analyze the Boolean expression (if any)
12314 if Present (Arg1) then
12315 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12318 -- Otherwise the external property applies to a constant
12321 Error_Pragma ("pragma % must apply to a volatile object");
12323 end Async_Effective;
12329 -- pragma Asynchronous (LOCAL_NAME);
12331 when Pragma_Asynchronous => Asynchronous : declare
12334 Formal : Entity_Id;
12339 procedure Process_Async_Pragma;
12340 -- Common processing for procedure and access-to-procedure case
12342 --------------------------
12343 -- Process_Async_Pragma --
12344 --------------------------
12346 procedure Process_Async_Pragma is
12349 Set_Is_Asynchronous (Nm);
12353 -- The formals should be of mode IN (RM E.4.1(6))
12356 while Present (S) loop
12357 Formal := Defining_Identifier (S);
12359 if Nkind (Formal) = N_Defining_Identifier
12360 and then Ekind (Formal) /= E_In_Parameter
12363 ("pragma% procedure can only have IN parameter",
12370 Set_Is_Asynchronous (Nm);
12371 end Process_Async_Pragma;
12373 -- Start of processing for pragma Asynchronous
12376 Check_Ada_83_Warning;
12377 Check_No_Identifiers;
12378 Check_Arg_Count (1);
12379 Check_Arg_Is_Local_Name (Arg1);
12381 if Debug_Flag_U then
12385 C_Ent := Cunit_Entity (Current_Sem_Unit);
12386 Analyze (Get_Pragma_Arg (Arg1));
12387 Nm := Entity (Get_Pragma_Arg (Arg1));
12389 -- A pragma that applies to a Ghost entity becomes Ghost for the
12390 -- purposes of legality checks and removal of ignored Ghost code.
12392 Mark_Ghost_Pragma (N, Nm);
12394 if not Is_Remote_Call_Interface (C_Ent)
12395 and then not Is_Remote_Types (C_Ent)
12397 -- This pragma should only appear in an RCI or Remote Types
12398 -- unit (RM E.4.1(4)).
12401 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12404 if Ekind (Nm) = E_Procedure
12405 and then Nkind (Parent (Nm)) = N_Procedure_Specification
12407 if not Is_Remote_Call_Interface (Nm) then
12409 ("pragma% cannot be applied on non-remote procedure",
12413 L := Parameter_Specifications (Parent (Nm));
12414 Process_Async_Pragma;
12417 elsif Ekind (Nm) = E_Function then
12419 ("pragma% cannot be applied to function", Arg1);
12421 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12422 if Is_Record_Type (Nm) then
12424 -- A record type that is the Equivalent_Type for a remote
12425 -- access-to-subprogram type.
12427 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12430 -- A non-expanded RAS type (distribution is not enabled)
12432 Decl := Declaration_Node (Nm);
12435 if Nkind (Decl) = N_Full_Type_Declaration
12436 and then Nkind (Type_Definition (Decl)) =
12437 N_Access_Procedure_Definition
12439 L := Parameter_Specifications (Type_Definition (Decl));
12440 Process_Async_Pragma;
12442 if Is_Asynchronous (Nm)
12443 and then Expander_Active
12444 and then Get_PCS_Name /= Name_No_DSA
12446 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12451 ("pragma% cannot reference access-to-function type",
12455 -- Only other possibility is Access-to-class-wide type
12457 elsif Is_Access_Type (Nm)
12458 and then Is_Class_Wide_Type (Designated_Type (Nm))
12460 Check_First_Subtype (Arg1);
12461 Set_Is_Asynchronous (Nm);
12462 if Expander_Active then
12463 RACW_Type_Is_Asynchronous (Nm);
12467 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12475 -- pragma Atomic (LOCAL_NAME);
12477 when Pragma_Atomic =>
12478 Process_Atomic_Independent_Shared_Volatile;
12480 -----------------------
12481 -- Atomic_Components --
12482 -----------------------
12484 -- pragma Atomic_Components (array_LOCAL_NAME);
12486 -- This processing is shared by Volatile_Components
12488 when Pragma_Atomic_Components
12489 | Pragma_Volatile_Components
12491 Atomic_Components : declare
12498 Check_Ada_83_Warning;
12499 Check_No_Identifiers;
12500 Check_Arg_Count (1);
12501 Check_Arg_Is_Local_Name (Arg1);
12502 E_Id := Get_Pragma_Arg (Arg1);
12504 if Etype (E_Id) = Any_Type then
12508 E := Entity (E_Id);
12510 -- A pragma that applies to a Ghost entity becomes Ghost for the
12511 -- purposes of legality checks and removal of ignored Ghost code.
12513 Mark_Ghost_Pragma (N, E);
12514 Check_Duplicate_Pragma (E);
12516 if Rep_Item_Too_Early (E, N)
12518 Rep_Item_Too_Late (E, N)
12523 D := Declaration_Node (E);
12526 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12528 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12529 and then Nkind (D) = N_Object_Declaration
12530 and then Nkind (Object_Definition (D)) =
12531 N_Constrained_Array_Definition)
12533 -- The flag is set on the object, or on the base type
12535 if Nkind (D) /= N_Object_Declaration then
12536 E := Base_Type (E);
12539 -- Atomic implies both Independent and Volatile
12541 if Prag_Id = Pragma_Atomic_Components then
12542 Set_Has_Atomic_Components (E);
12543 Set_Has_Independent_Components (E);
12546 Set_Has_Volatile_Components (E);
12549 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12551 end Atomic_Components;
12553 --------------------
12554 -- Attach_Handler --
12555 --------------------
12557 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12559 when Pragma_Attach_Handler =>
12560 Check_Ada_83_Warning;
12561 Check_No_Identifiers;
12562 Check_Arg_Count (2);
12564 if No_Run_Time_Mode then
12565 Error_Msg_CRT ("Attach_Handler pragma", N);
12567 Check_Interrupt_Or_Attach_Handler;
12569 -- The expression that designates the attribute may depend on a
12570 -- discriminant, and is therefore a per-object expression, to
12571 -- be expanded in the init proc. If expansion is enabled, then
12572 -- perform semantic checks on a copy only.
12577 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12580 -- In Relaxed_RM_Semantics mode, we allow any static
12581 -- integer value, for compatibility with other compilers.
12583 if Relaxed_RM_Semantics
12584 and then Nkind (Parg2) = N_Integer_Literal
12586 Typ := Standard_Integer;
12588 Typ := RTE (RE_Interrupt_ID);
12591 if Expander_Active then
12592 Temp := New_Copy_Tree (Parg2);
12593 Set_Parent (Temp, N);
12594 Preanalyze_And_Resolve (Temp, Typ);
12597 Resolve (Parg2, Typ);
12601 Process_Interrupt_Or_Attach_Handler;
12604 --------------------
12605 -- C_Pass_By_Copy --
12606 --------------------
12608 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12610 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12616 Check_Valid_Configuration_Pragma;
12617 Check_Arg_Count (1);
12618 Check_Optional_Identifier (Arg1, "max_size");
12620 Arg := Get_Pragma_Arg (Arg1);
12621 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12623 Val := Expr_Value (Arg);
12627 ("maximum size for pragma% must be positive", Arg1);
12629 elsif UI_Is_In_Int_Range (Val) then
12630 Default_C_Record_Mechanism := UI_To_Int (Val);
12632 -- If a giant value is given, Int'Last will do well enough.
12633 -- If sometime someone complains that a record larger than
12634 -- two gigabytes is not copied, we will worry about it then.
12637 Default_C_Record_Mechanism := Mechanism_Type'Last;
12639 end C_Pass_By_Copy;
12645 -- pragma Check ([Name =>] CHECK_KIND,
12646 -- [Check =>] Boolean_EXPRESSION
12647 -- [,[Message =>] String_EXPRESSION]);
12649 -- CHECK_KIND ::= IDENTIFIER |
12652 -- Invariant'Class |
12653 -- Type_Invariant'Class
12655 -- The identifiers Assertions and Statement_Assertions are not
12656 -- allowed, since they have special meaning for Check_Policy.
12658 -- WARNING: The code below manages Ghost regions. Return statements
12659 -- must be replaced by gotos which jump to the end of the code and
12660 -- restore the Ghost mode.
12662 when Pragma_Check => Check : declare
12663 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
12664 -- Save the Ghost mode to restore on exit
12672 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12673 -- the mode now to ensure that any nodes generated during analysis
12674 -- and expansion are marked as Ghost.
12676 Set_Ghost_Mode (N);
12679 Check_At_Least_N_Arguments (2);
12680 Check_At_Most_N_Arguments (3);
12681 Check_Optional_Identifier (Arg1, Name_Name);
12682 Check_Optional_Identifier (Arg2, Name_Check);
12684 if Arg_Count = 3 then
12685 Check_Optional_Identifier (Arg3, Name_Message);
12686 Str := Get_Pragma_Arg (Arg3);
12689 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12690 Check_Arg_Is_Identifier (Arg1);
12691 Cname := Chars (Get_Pragma_Arg (Arg1));
12693 -- Check forbidden name Assertions or Statement_Assertions
12696 when Name_Assertions =>
12698 ("""Assertions"" is not allowed as a check kind for "
12699 & "pragma%", Arg1);
12701 when Name_Statement_Assertions =>
12703 ("""Statement_Assertions"" is not allowed as a check kind "
12704 & "for pragma%", Arg1);
12710 -- Check applicable policy. We skip this if Checked/Ignored status
12711 -- is already set (e.g. in the case of a pragma from an aspect).
12713 if Is_Checked (N) or else Is_Ignored (N) then
12716 -- For a non-source pragma that is a rewriting of another pragma,
12717 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12719 elsif Is_Rewrite_Substitution (N)
12720 and then Nkind (Original_Node (N)) = N_Pragma
12721 and then Original_Node (N) /= N
12723 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12724 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12726 -- Otherwise query the applicable policy at this point
12729 case Check_Kind (Cname) is
12730 when Name_Ignore =>
12731 Set_Is_Ignored (N, True);
12732 Set_Is_Checked (N, False);
12735 Set_Is_Ignored (N, False);
12736 Set_Is_Checked (N, True);
12738 -- For disable, rewrite pragma as null statement and skip
12739 -- rest of the analysis of the pragma.
12741 when Name_Disable =>
12742 Rewrite (N, Make_Null_Statement (Loc));
12746 -- No other possibilities
12749 raise Program_Error;
12753 -- If check kind was not Disable, then continue pragma analysis
12755 Expr := Get_Pragma_Arg (Arg2);
12757 -- Deal with SCO generation
12759 if Is_Checked (N) and then not Split_PPC (N) then
12760 Set_SCO_Pragma_Enabled (Loc);
12763 -- Deal with analyzing the string argument
12765 if Arg_Count = 3 then
12767 -- If checks are not on we don't want any expansion (since
12768 -- such expansion would not get properly deleted) but
12769 -- we do want to analyze (to get proper references).
12770 -- The Preanalyze_And_Resolve routine does just what we want
12772 if Is_Ignored (N) then
12773 Preanalyze_And_Resolve (Str, Standard_String);
12775 -- Otherwise we need a proper analysis and expansion
12778 Analyze_And_Resolve (Str, Standard_String);
12782 -- Now you might think we could just do the same with the Boolean
12783 -- expression if checks are off (and expansion is on) and then
12784 -- rewrite the check as a null statement. This would work but we
12785 -- would lose the useful warnings about an assertion being bound
12786 -- to fail even if assertions are turned off.
12788 -- So instead we wrap the boolean expression in an if statement
12789 -- that looks like:
12791 -- if False and then condition then
12795 -- The reason we do this rewriting during semantic analysis rather
12796 -- than as part of normal expansion is that we cannot analyze and
12797 -- expand the code for the boolean expression directly, or it may
12798 -- cause insertion of actions that would escape the attempt to
12799 -- suppress the check code.
12801 -- Note that the Sloc for the if statement corresponds to the
12802 -- argument condition, not the pragma itself. The reason for
12803 -- this is that we may generate a warning if the condition is
12804 -- False at compile time, and we do not want to delete this
12805 -- warning when we delete the if statement.
12807 if Expander_Active and Is_Ignored (N) then
12808 Eloc := Sloc (Expr);
12811 Make_If_Statement (Eloc,
12813 Make_And_Then (Eloc,
12814 Left_Opnd => Make_Identifier (Eloc, Name_False),
12815 Right_Opnd => Expr),
12816 Then_Statements => New_List (
12817 Make_Null_Statement (Eloc))));
12819 -- Now go ahead and analyze the if statement
12821 In_Assertion_Expr := In_Assertion_Expr + 1;
12823 -- One rather special treatment. If we are now in Eliminated
12824 -- overflow mode, then suppress overflow checking since we do
12825 -- not want to drag in the bignum stuff if we are in Ignore
12826 -- mode anyway. This is particularly important if we are using
12827 -- a configurable run time that does not support bignum ops.
12829 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12831 Svo : constant Boolean :=
12832 Scope_Suppress.Suppress (Overflow_Check);
12834 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12835 Scope_Suppress.Suppress (Overflow_Check) := True;
12837 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12838 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12841 -- Not that special case
12847 -- All done with this check
12849 In_Assertion_Expr := In_Assertion_Expr - 1;
12851 -- Check is active or expansion not active. In these cases we can
12852 -- just go ahead and analyze the boolean with no worries.
12855 In_Assertion_Expr := In_Assertion_Expr + 1;
12856 Analyze_And_Resolve (Expr, Any_Boolean);
12857 In_Assertion_Expr := In_Assertion_Expr - 1;
12860 Restore_Ghost_Mode (Saved_GM);
12863 --------------------------
12864 -- Check_Float_Overflow --
12865 --------------------------
12867 -- pragma Check_Float_Overflow;
12869 when Pragma_Check_Float_Overflow =>
12871 Check_Valid_Configuration_Pragma;
12872 Check_Arg_Count (0);
12873 Check_Float_Overflow := not Machine_Overflows_On_Target;
12879 -- pragma Check_Name (check_IDENTIFIER);
12881 when Pragma_Check_Name =>
12883 Check_No_Identifiers;
12884 Check_Valid_Configuration_Pragma;
12885 Check_Arg_Count (1);
12886 Check_Arg_Is_Identifier (Arg1);
12889 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12892 for J in Check_Names.First .. Check_Names.Last loop
12893 if Check_Names.Table (J) = Nam then
12898 Check_Names.Append (Nam);
12905 -- This is the old style syntax, which is still allowed in all modes:
12907 -- pragma Check_Policy ([Name =>] CHECK_KIND
12908 -- [Policy =>] POLICY_IDENTIFIER);
12910 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12912 -- CHECK_KIND ::= IDENTIFIER |
12915 -- Type_Invariant'Class |
12918 -- This is the new style syntax, compatible with Assertion_Policy
12919 -- and also allowed in all modes.
12921 -- Pragma Check_Policy (
12922 -- CHECK_KIND => POLICY_IDENTIFIER
12923 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12925 -- Note: the identifiers Name and Policy are not allowed as
12926 -- Check_Kind values. This avoids ambiguities between the old and
12927 -- new form syntax.
12929 when Pragma_Check_Policy => Check_Policy : declare
12934 Check_At_Least_N_Arguments (1);
12936 -- A Check_Policy pragma can appear either as a configuration
12937 -- pragma, or in a declarative part or a package spec (see RM
12938 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12939 -- followed for Check_Policy).
12941 if not Is_Configuration_Pragma then
12942 Check_Is_In_Decl_Part_Or_Package_Spec;
12945 -- Figure out if we have the old or new syntax. We have the
12946 -- old syntax if the first argument has no identifier, or the
12947 -- identifier is Name.
12949 if Nkind (Arg1) /= N_Pragma_Argument_Association
12950 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12954 Check_Arg_Count (2);
12955 Check_Optional_Identifier (Arg1, Name_Name);
12956 Kind := Get_Pragma_Arg (Arg1);
12957 Rewrite_Assertion_Kind (Kind,
12958 From_Policy => Comes_From_Source (N));
12959 Check_Arg_Is_Identifier (Arg1);
12961 -- Check forbidden check kind
12963 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12964 Error_Msg_Name_2 := Chars (Kind);
12966 ("pragma% does not allow% as check name", Arg1);
12971 Check_Optional_Identifier (Arg2, Name_Policy);
12972 Check_Arg_Is_One_Of
12974 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12976 -- And chain pragma on the Check_Policy_List for search
12978 Set_Next_Pragma (N, Opt.Check_Policy_List);
12979 Opt.Check_Policy_List := N;
12981 -- For the new syntax, what we do is to convert each argument to
12982 -- an old syntax equivalent. We do that because we want to chain
12983 -- old style Check_Policy pragmas for the search (we don't want
12984 -- to have to deal with multiple arguments in the search).
12995 while Present (Arg) loop
12996 LocP := Sloc (Arg);
12997 Argx := Get_Pragma_Arg (Arg);
12999 -- Kind must be specified
13001 if Nkind (Arg) /= N_Pragma_Argument_Association
13002 or else Chars (Arg) = No_Name
13005 ("missing assertion kind for pragma%", Arg);
13008 -- Construct equivalent old form syntax Check_Policy
13009 -- pragma and insert it to get remaining checks.
13013 Chars => Name_Check_Policy,
13014 Pragma_Argument_Associations => New_List (
13015 Make_Pragma_Argument_Association (LocP,
13017 Make_Identifier (LocP, Chars (Arg))),
13018 Make_Pragma_Argument_Association (Sloc (Argx),
13019 Expression => Argx)));
13023 -- For a configuration pragma, insert old form in
13024 -- the corresponding file.
13026 if Is_Configuration_Pragma then
13027 Insert_After (N, New_P);
13031 Insert_Action (N, New_P);
13035 -- Rewrite original Check_Policy pragma to null, since we
13036 -- have converted it into a series of old syntax pragmas.
13038 Rewrite (N, Make_Null_Statement (Loc));
13048 -- pragma Comment (static_string_EXPRESSION)
13050 -- Processing for pragma Comment shares the circuitry for pragma
13051 -- Ident. The only differences are that Ident enforces a limit of 31
13052 -- characters on its argument, and also enforces limitations on
13053 -- placement for DEC compatibility. Pragma Comment shares neither of
13054 -- these restrictions.
13056 -------------------
13057 -- Common_Object --
13058 -------------------
13060 -- pragma Common_Object (
13061 -- [Internal =>] LOCAL_NAME
13062 -- [, [External =>] EXTERNAL_SYMBOL]
13063 -- [, [Size =>] EXTERNAL_SYMBOL]);
13065 -- Processing for this pragma is shared with Psect_Object
13067 ------------------------
13068 -- Compile_Time_Error --
13069 ------------------------
13071 -- pragma Compile_Time_Error
13072 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13074 when Pragma_Compile_Time_Error =>
13076 Process_Compile_Time_Warning_Or_Error;
13078 --------------------------
13079 -- Compile_Time_Warning --
13080 --------------------------
13082 -- pragma Compile_Time_Warning
13083 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13085 when Pragma_Compile_Time_Warning =>
13087 Process_Compile_Time_Warning_Or_Error;
13089 ---------------------------
13090 -- Compiler_Unit_Warning --
13091 ---------------------------
13093 -- pragma Compiler_Unit_Warning;
13097 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13098 -- errors not warnings. This means that we had introduced a big extra
13099 -- inertia to compiler changes, since even if we implemented a new
13100 -- feature, and even if all versions to be used for bootstrapping
13101 -- implemented this new feature, we could not use it, since old
13102 -- compilers would give errors for using this feature in units
13103 -- having Compiler_Unit pragmas.
13105 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13106 -- problem. We no longer have any units mentioning Compiler_Unit,
13107 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13108 -- and thus generates a warning which can be ignored. So that deals
13109 -- with the problem of old compilers not implementing the newer form
13112 -- Newer compilers recognize the new pragma, but generate warning
13113 -- messages instead of errors, which again can be ignored in the
13114 -- case of an old compiler which implements a wanted new feature
13115 -- but at the time felt like warning about it for older compilers.
13117 -- We retain Compiler_Unit so that new compilers can be used to build
13118 -- older run-times that use this pragma. That's an unusual case, but
13119 -- it's easy enough to handle, so why not?
13121 when Pragma_Compiler_Unit
13122 | Pragma_Compiler_Unit_Warning
13125 Check_Arg_Count (0);
13127 -- Only recognized in main unit
13129 if Current_Sem_Unit = Main_Unit then
13130 Compiler_Unit := True;
13133 -----------------------------
13134 -- Complete_Representation --
13135 -----------------------------
13137 -- pragma Complete_Representation;
13139 when Pragma_Complete_Representation =>
13141 Check_Arg_Count (0);
13143 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
13145 ("pragma & must appear within record representation clause");
13148 ----------------------------
13149 -- Complex_Representation --
13150 ----------------------------
13152 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13154 when Pragma_Complex_Representation => Complex_Representation : declare
13161 Check_Arg_Count (1);
13162 Check_Optional_Identifier (Arg1, Name_Entity);
13163 Check_Arg_Is_Local_Name (Arg1);
13164 E_Id := Get_Pragma_Arg (Arg1);
13166 if Etype (E_Id) = Any_Type then
13170 E := Entity (E_Id);
13172 if not Is_Record_Type (E) then
13174 ("argument for pragma% must be record type", Arg1);
13177 Ent := First_Entity (E);
13180 or else No (Next_Entity (Ent))
13181 or else Present (Next_Entity (Next_Entity (Ent)))
13182 or else not Is_Floating_Point_Type (Etype (Ent))
13183 or else Etype (Ent) /= Etype (Next_Entity (Ent))
13186 ("record for pragma% must have two fields of the same "
13187 & "floating-point type", Arg1);
13190 Set_Has_Complex_Representation (Base_Type (E));
13192 -- We need to treat the type has having a non-standard
13193 -- representation, for back-end purposes, even though in
13194 -- general a complex will have the default representation
13195 -- of a record with two real components.
13197 Set_Has_Non_Standard_Rep (Base_Type (E));
13199 end Complex_Representation;
13201 -------------------------
13202 -- Component_Alignment --
13203 -------------------------
13205 -- pragma Component_Alignment (
13206 -- [Form =>] ALIGNMENT_CHOICE
13207 -- [, [Name =>] type_LOCAL_NAME]);
13209 -- ALIGNMENT_CHOICE ::=
13211 -- | Component_Size_4
13215 when Pragma_Component_Alignment => Component_AlignmentP : declare
13216 Args : Args_List (1 .. 2);
13217 Names : constant Name_List (1 .. 2) := (
13221 Form : Node_Id renames Args (1);
13222 Name : Node_Id renames Args (2);
13224 Atype : Component_Alignment_Kind;
13229 Gather_Associations (Names, Args);
13232 Error_Pragma ("missing Form argument for pragma%");
13235 Check_Arg_Is_Identifier (Form);
13237 -- Get proper alignment, note that Default = Component_Size on all
13238 -- machines we have so far, and we want to set this value rather
13239 -- than the default value to indicate that it has been explicitly
13240 -- set (and thus will not get overridden by the default component
13241 -- alignment for the current scope)
13243 if Chars (Form) = Name_Component_Size then
13244 Atype := Calign_Component_Size;
13246 elsif Chars (Form) = Name_Component_Size_4 then
13247 Atype := Calign_Component_Size_4;
13249 elsif Chars (Form) = Name_Default then
13250 Atype := Calign_Component_Size;
13252 elsif Chars (Form) = Name_Storage_Unit then
13253 Atype := Calign_Storage_Unit;
13257 ("invalid Form parameter for pragma%", Form);
13260 -- The pragma appears in a configuration file
13262 if No (Parent (N)) then
13263 Check_Valid_Configuration_Pragma;
13265 -- Capture the component alignment in a global variable when
13266 -- the pragma appears in a configuration file. Note that the
13267 -- scope stack is empty at this point and cannot be used to
13268 -- store the alignment value.
13270 Configuration_Component_Alignment := Atype;
13272 -- Case with no name, supplied, affects scope table entry
13274 elsif No (Name) then
13276 (Scope_Stack.Last).Component_Alignment_Default := Atype;
13278 -- Case of name supplied
13281 Check_Arg_Is_Local_Name (Name);
13283 Typ := Entity (Name);
13286 or else Rep_Item_Too_Early (Typ, N)
13290 Typ := Underlying_Type (Typ);
13293 if not Is_Record_Type (Typ)
13294 and then not Is_Array_Type (Typ)
13297 ("Name parameter of pragma% must identify record or "
13298 & "array type", Name);
13301 -- An explicit Component_Alignment pragma overrides an
13302 -- implicit pragma Pack, but not an explicit one.
13304 if not Has_Pragma_Pack (Base_Type (Typ)) then
13305 Set_Is_Packed (Base_Type (Typ), False);
13306 Set_Component_Alignment (Base_Type (Typ), Atype);
13309 end Component_AlignmentP;
13311 --------------------------------
13312 -- Constant_After_Elaboration --
13313 --------------------------------
13315 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13317 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13319 Obj_Decl : Node_Id;
13320 Obj_Id : Entity_Id;
13324 Check_No_Identifiers;
13325 Check_At_Most_N_Arguments (1);
13327 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13329 -- Object declaration
13331 if Nkind (Obj_Decl) = N_Object_Declaration then
13334 -- Otherwise the pragma is associated with an illegal construct
13341 Obj_Id := Defining_Entity (Obj_Decl);
13343 -- The object declaration must be a library-level variable which
13344 -- is either explicitly initialized or obtains a value during the
13345 -- elaboration of a package body (SPARK RM 3.3.1).
13347 if Ekind (Obj_Id) = E_Variable then
13348 if not Is_Library_Level_Entity (Obj_Id) then
13350 ("pragma % must apply to a library level variable");
13354 -- Otherwise the pragma applies to a constant, which is illegal
13357 Error_Pragma ("pragma % must apply to a variable declaration");
13361 -- A pragma that applies to a Ghost entity becomes Ghost for the
13362 -- purposes of legality checks and removal of ignored Ghost code.
13364 Mark_Ghost_Pragma (N, Obj_Id);
13366 -- Chain the pragma on the contract for completeness
13368 Add_Contract_Item (N, Obj_Id);
13370 -- Analyze the Boolean expression (if any)
13372 if Present (Arg1) then
13373 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13375 end Constant_After_Elaboration;
13377 --------------------
13378 -- Contract_Cases --
13379 --------------------
13381 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13383 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13385 -- CASE_GUARD ::= boolean_EXPRESSION | others
13387 -- CONSEQUENCE ::= boolean_EXPRESSION
13389 -- Characteristics:
13391 -- * Analysis - The annotation undergoes initial checks to verify
13392 -- the legal placement and context. Secondary checks preanalyze the
13395 -- Analyze_Contract_Cases_In_Decl_Part
13397 -- * Expansion - The annotation is expanded during the expansion of
13398 -- the related subprogram [body] contract as performed in:
13400 -- Expand_Subprogram_Contract
13402 -- * Template - The annotation utilizes the generic template of the
13403 -- related subprogram [body] when it is:
13405 -- aspect on subprogram declaration
13406 -- aspect on stand alone subprogram body
13407 -- pragma on stand alone subprogram body
13409 -- The annotation must prepare its own template when it is:
13411 -- pragma on subprogram declaration
13413 -- * Globals - Capture of global references must occur after full
13416 -- * Instance - The annotation is instantiated automatically when
13417 -- the related generic subprogram [body] is instantiated except for
13418 -- the "pragma on subprogram declaration" case. In that scenario
13419 -- the annotation must instantiate itself.
13421 when Pragma_Contract_Cases => Contract_Cases : declare
13422 Spec_Id : Entity_Id;
13423 Subp_Decl : Node_Id;
13427 Check_No_Identifiers;
13428 Check_Arg_Count (1);
13430 -- Ensure the proper placement of the pragma. Contract_Cases must
13431 -- be associated with a subprogram declaration or a body that acts
13435 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13439 if Nkind (Subp_Decl) = N_Entry_Declaration then
13442 -- Generic subprogram
13444 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13447 -- Body acts as spec
13449 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13450 and then No (Corresponding_Spec (Subp_Decl))
13454 -- Body stub acts as spec
13456 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13457 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13463 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13471 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13473 -- A pragma that applies to a Ghost entity becomes Ghost for the
13474 -- purposes of legality checks and removal of ignored Ghost code.
13476 Mark_Ghost_Pragma (N, Spec_Id);
13477 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13479 -- Chain the pragma on the contract for further processing by
13480 -- Analyze_Contract_Cases_In_Decl_Part.
13482 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13484 -- Fully analyze the pragma when it appears inside an entry
13485 -- or subprogram body because it cannot benefit from forward
13488 if Nkind_In (Subp_Decl, N_Entry_Body,
13490 N_Subprogram_Body_Stub)
13492 -- The legality checks of pragma Contract_Cases are affected by
13493 -- the SPARK mode in effect and the volatility of the context.
13494 -- Analyze all pragmas in a specific order.
13496 Analyze_If_Present (Pragma_SPARK_Mode);
13497 Analyze_If_Present (Pragma_Volatile_Function);
13498 Analyze_Contract_Cases_In_Decl_Part (N);
13500 end Contract_Cases;
13506 -- pragma Controlled (first_subtype_LOCAL_NAME);
13508 when Pragma_Controlled => Controlled : declare
13512 Check_No_Identifiers;
13513 Check_Arg_Count (1);
13514 Check_Arg_Is_Local_Name (Arg1);
13515 Arg := Get_Pragma_Arg (Arg1);
13517 if not Is_Entity_Name (Arg)
13518 or else not Is_Access_Type (Entity (Arg))
13520 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13522 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13530 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13531 -- [Entity =>] LOCAL_NAME);
13533 when Pragma_Convention => Convention : declare
13536 pragma Warnings (Off, C);
13537 pragma Warnings (Off, E);
13540 Check_Arg_Order ((Name_Convention, Name_Entity));
13541 Check_Ada_83_Warning;
13542 Check_Arg_Count (2);
13543 Process_Convention (C, E);
13545 -- A pragma that applies to a Ghost entity becomes Ghost for the
13546 -- purposes of legality checks and removal of ignored Ghost code.
13548 Mark_Ghost_Pragma (N, E);
13551 ---------------------------
13552 -- Convention_Identifier --
13553 ---------------------------
13555 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13556 -- [Convention =>] convention_IDENTIFIER);
13558 when Pragma_Convention_Identifier => Convention_Identifier : declare
13564 Check_Arg_Order ((Name_Name, Name_Convention));
13565 Check_Arg_Count (2);
13566 Check_Optional_Identifier (Arg1, Name_Name);
13567 Check_Optional_Identifier (Arg2, Name_Convention);
13568 Check_Arg_Is_Identifier (Arg1);
13569 Check_Arg_Is_Identifier (Arg2);
13570 Idnam := Chars (Get_Pragma_Arg (Arg1));
13571 Cname := Chars (Get_Pragma_Arg (Arg2));
13573 if Is_Convention_Name (Cname) then
13574 Record_Convention_Identifier
13575 (Idnam, Get_Convention_Id (Cname));
13578 ("second arg for % pragma must be convention", Arg2);
13580 end Convention_Identifier;
13586 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13588 when Pragma_CPP_Class =>
13591 if Warn_On_Obsolescent_Feature then
13593 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13594 & "effect; replace it by pragma import?j?", N);
13597 Check_Arg_Count (1);
13601 Chars => Name_Import,
13602 Pragma_Argument_Associations => New_List (
13603 Make_Pragma_Argument_Association (Loc,
13604 Expression => Make_Identifier (Loc, Name_CPP)),
13605 New_Copy (First (Pragma_Argument_Associations (N))))));
13608 ---------------------
13609 -- CPP_Constructor --
13610 ---------------------
13612 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13613 -- [, [External_Name =>] static_string_EXPRESSION ]
13614 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13616 when Pragma_CPP_Constructor => CPP_Constructor : declare
13619 Def_Id : Entity_Id;
13620 Tag_Typ : Entity_Id;
13624 Check_At_Least_N_Arguments (1);
13625 Check_At_Most_N_Arguments (3);
13626 Check_Optional_Identifier (Arg1, Name_Entity);
13627 Check_Arg_Is_Local_Name (Arg1);
13629 Id := Get_Pragma_Arg (Arg1);
13630 Find_Program_Unit_Name (Id);
13632 -- If we did not find the name, we are done
13634 if Etype (Id) = Any_Type then
13638 Def_Id := Entity (Id);
13640 -- Check if already defined as constructor
13642 if Is_Constructor (Def_Id) then
13644 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13648 if Ekind (Def_Id) = E_Function
13649 and then (Is_CPP_Class (Etype (Def_Id))
13650 or else (Is_Class_Wide_Type (Etype (Def_Id))
13652 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13654 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13656 ("'C'P'P constructor must be defined in the scope of "
13657 & "its returned type", Arg1);
13660 if Arg_Count >= 2 then
13661 Set_Imported (Def_Id);
13662 Set_Is_Public (Def_Id);
13663 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
13666 Set_Has_Completion (Def_Id);
13667 Set_Is_Constructor (Def_Id);
13668 Set_Convention (Def_Id, Convention_CPP);
13670 -- Imported C++ constructors are not dispatching primitives
13671 -- because in C++ they don't have a dispatch table slot.
13672 -- However, in Ada the constructor has the profile of a
13673 -- function that returns a tagged type and therefore it has
13674 -- been treated as a primitive operation during semantic
13675 -- analysis. We now remove it from the list of primitive
13676 -- operations of the type.
13678 if Is_Tagged_Type (Etype (Def_Id))
13679 and then not Is_Class_Wide_Type (Etype (Def_Id))
13680 and then Is_Dispatching_Operation (Def_Id)
13682 Tag_Typ := Etype (Def_Id);
13684 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13685 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13689 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13690 Set_Is_Dispatching_Operation (Def_Id, False);
13693 -- For backward compatibility, if the constructor returns a
13694 -- class wide type, and we internally change the return type to
13695 -- the corresponding root type.
13697 if Is_Class_Wide_Type (Etype (Def_Id)) then
13698 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13702 ("pragma% requires function returning a 'C'P'P_Class type",
13705 end CPP_Constructor;
13711 when Pragma_CPP_Virtual =>
13714 if Warn_On_Obsolescent_Feature then
13716 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13724 when Pragma_CPP_Vtable =>
13727 if Warn_On_Obsolescent_Feature then
13729 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13737 -- pragma CPU (EXPRESSION);
13739 when Pragma_CPU => CPU : declare
13740 P : constant Node_Id := Parent (N);
13746 Check_No_Identifiers;
13747 Check_Arg_Count (1);
13751 if Nkind (P) = N_Subprogram_Body then
13752 Check_In_Main_Program;
13754 Arg := Get_Pragma_Arg (Arg1);
13755 Analyze_And_Resolve (Arg, Any_Integer);
13757 Ent := Defining_Unit_Name (Specification (P));
13759 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13760 Ent := Defining_Identifier (Ent);
13765 if not Is_OK_Static_Expression (Arg) then
13766 Flag_Non_Static_Expr
13767 ("main subprogram affinity is not static!", Arg);
13770 -- If constraint error, then we already signalled an error
13772 elsif Raises_Constraint_Error (Arg) then
13775 -- Otherwise check in range
13779 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13780 -- This is the entity System.Multiprocessors.CPU_Range;
13782 Val : constant Uint := Expr_Value (Arg);
13785 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13787 Val > Expr_Value (Type_High_Bound (CPU_Id))
13790 ("main subprogram CPU is out of range", Arg1);
13796 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13800 elsif Nkind (P) = N_Task_Definition then
13801 Arg := Get_Pragma_Arg (Arg1);
13802 Ent := Defining_Identifier (Parent (P));
13804 -- The expression must be analyzed in the special manner
13805 -- described in "Handling of Default and Per-Object
13806 -- Expressions" in sem.ads.
13808 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13810 -- Anything else is incorrect
13816 -- Check duplicate pragma before we chain the pragma in the Rep
13817 -- Item chain of Ent.
13819 Check_Duplicate_Pragma (Ent);
13820 Record_Rep_Item (Ent, N);
13823 --------------------
13824 -- Deadline_Floor --
13825 --------------------
13827 -- pragma Deadline_Floor (time_span_EXPRESSION);
13829 when Pragma_Deadline_Floor => Deadline_Floor : declare
13830 P : constant Node_Id := Parent (N);
13836 Check_No_Identifiers;
13837 Check_Arg_Count (1);
13839 Arg := Get_Pragma_Arg (Arg1);
13841 -- The expression must be analyzed in the special manner described
13842 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
13844 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
13846 -- Only protected types allowed
13848 if Nkind (P) /= N_Protected_Definition then
13852 Ent := Defining_Identifier (Parent (P));
13854 -- Check duplicate pragma before we chain the pragma in the Rep
13855 -- Item chain of Ent.
13857 Check_Duplicate_Pragma (Ent);
13858 Record_Rep_Item (Ent, N);
13860 end Deadline_Floor;
13866 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13868 when Pragma_Debug => Debug : declare
13875 -- The condition for executing the call is that the expander
13876 -- is active and that we are not ignoring this debug pragma.
13881 (Expander_Active and then not Is_Ignored (N)),
13884 if not Is_Ignored (N) then
13885 Set_SCO_Pragma_Enabled (Loc);
13888 if Arg_Count = 2 then
13890 Make_And_Then (Loc,
13891 Left_Opnd => Relocate_Node (Cond),
13892 Right_Opnd => Get_Pragma_Arg (Arg1));
13893 Call := Get_Pragma_Arg (Arg2);
13895 Call := Get_Pragma_Arg (Arg1);
13899 N_Indexed_Component,
13903 N_Selected_Component)
13905 -- If this pragma Debug comes from source, its argument was
13906 -- parsed as a name form (which is syntactically identical).
13907 -- In a generic context a parameterless call will be left as
13908 -- an expanded name (if global) or selected_component if local.
13909 -- Change it to a procedure call statement now.
13911 Change_Name_To_Procedure_Call_Statement (Call);
13913 elsif Nkind (Call) = N_Procedure_Call_Statement then
13915 -- Already in the form of a procedure call statement: nothing
13916 -- to do (could happen in case of an internally generated
13922 -- All other cases: diagnose error
13925 ("argument of pragma ""Debug"" is not procedure call",
13930 -- Rewrite into a conditional with an appropriate condition. We
13931 -- wrap the procedure call in a block so that overhead from e.g.
13932 -- use of the secondary stack does not generate execution overhead
13933 -- for suppressed conditions.
13935 -- Normally the analysis that follows will freeze the subprogram
13936 -- being called. However, if the call is to a null procedure,
13937 -- we want to freeze it before creating the block, because the
13938 -- analysis that follows may be done with expansion disabled, in
13939 -- which case the body will not be generated, leading to spurious
13942 if Nkind (Call) = N_Procedure_Call_Statement
13943 and then Is_Entity_Name (Name (Call))
13945 Analyze (Name (Call));
13946 Freeze_Before (N, Entity (Name (Call)));
13950 Make_Implicit_If_Statement (N,
13952 Then_Statements => New_List (
13953 Make_Block_Statement (Loc,
13954 Handled_Statement_Sequence =>
13955 Make_Handled_Sequence_Of_Statements (Loc,
13956 Statements => New_List (Relocate_Node (Call)))))));
13959 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13960 -- after analysis of the normally rewritten node, to capture all
13961 -- references to entities, which avoids issuing wrong warnings
13962 -- about unused entities.
13964 if GNATprove_Mode then
13965 Rewrite (N, Make_Null_Statement (Loc));
13973 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13975 when Pragma_Debug_Policy =>
13977 Check_Arg_Count (1);
13978 Check_No_Identifiers;
13979 Check_Arg_Is_Identifier (Arg1);
13981 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13982 -- rewrite it that way, and let the rest of the checking come
13983 -- from analyzing the rewritten pragma.
13987 Chars => Name_Check_Policy,
13988 Pragma_Argument_Associations => New_List (
13989 Make_Pragma_Argument_Association (Loc,
13990 Expression => Make_Identifier (Loc, Name_Debug)),
13992 Make_Pragma_Argument_Association (Loc,
13993 Expression => Get_Pragma_Arg (Arg1)))));
13996 -------------------------------
13997 -- Default_Initial_Condition --
13998 -------------------------------
14000 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14002 when Pragma_Default_Initial_Condition => DIC : declare
14009 Check_No_Identifiers;
14010 Check_At_Most_N_Arguments (1);
14014 while Present (Stmt) loop
14016 -- Skip prior pragmas, but check for duplicates
14018 if Nkind (Stmt) = N_Pragma then
14019 if Pragma_Name (Stmt) = Pname then
14026 -- Skip internally generated code. Note that derived type
14027 -- declarations of untagged types with discriminants are
14028 -- rewritten as private type declarations.
14030 elsif not Comes_From_Source (Stmt)
14031 and then Nkind (Stmt) /= N_Private_Type_Declaration
14035 -- The associated private type [extension] has been found, stop
14038 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
14039 N_Private_Type_Declaration)
14041 Typ := Defining_Entity (Stmt);
14044 -- The pragma does not apply to a legal construct, issue an
14045 -- error and stop the analysis.
14052 Stmt := Prev (Stmt);
14055 -- The pragma does not apply to a legal construct, issue an error
14056 -- and stop the analysis.
14063 -- A pragma that applies to a Ghost entity becomes Ghost for the
14064 -- purposes of legality checks and removal of ignored Ghost code.
14066 Mark_Ghost_Pragma (N, Typ);
14068 -- The pragma signals that the type defines its own DIC assertion
14071 Set_Has_Own_DIC (Typ);
14073 -- Chain the pragma on the rep item chain for further processing
14075 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14077 -- Create the declaration of the procedure which verifies the
14078 -- assertion expression of pragma DIC at runtime.
14080 Build_DIC_Procedure_Declaration (Typ);
14083 ----------------------------------
14084 -- Default_Scalar_Storage_Order --
14085 ----------------------------------
14087 -- pragma Default_Scalar_Storage_Order
14088 -- (High_Order_First | Low_Order_First);
14090 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
14091 Default : Character;
14095 Check_Arg_Count (1);
14097 -- Default_Scalar_Storage_Order can appear as a configuration
14098 -- pragma, or in a declarative part of a package spec.
14100 if not Is_Configuration_Pragma then
14101 Check_Is_In_Decl_Part_Or_Package_Spec;
14104 Check_No_Identifiers;
14105 Check_Arg_Is_One_Of
14106 (Arg1, Name_High_Order_First, Name_Low_Order_First);
14107 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14108 Default := Fold_Upper (Name_Buffer (1));
14110 if not Support_Nondefault_SSO_On_Target
14111 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
14113 if Warn_On_Unrecognized_Pragma then
14115 ("non-default Scalar_Storage_Order not supported "
14116 & "on target?g?", N);
14118 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
14121 -- Here set the specified default
14124 Opt.Default_SSO := Default;
14128 --------------------------
14129 -- Default_Storage_Pool --
14130 --------------------------
14132 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14134 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
14139 Check_Arg_Count (1);
14141 -- Default_Storage_Pool can appear as a configuration pragma, or
14142 -- in a declarative part of a package spec.
14144 if not Is_Configuration_Pragma then
14145 Check_Is_In_Decl_Part_Or_Package_Spec;
14148 if From_Aspect_Specification (N) then
14150 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
14152 if not In_Open_Scopes (E) then
14154 ("aspect must apply to package or subprogram", N);
14159 if Present (Arg1) then
14160 Pool := Get_Pragma_Arg (Arg1);
14162 -- Case of Default_Storage_Pool (null);
14164 if Nkind (Pool) = N_Null then
14167 -- This is an odd case, this is not really an expression,
14168 -- so we don't have a type for it. So just set the type to
14171 Set_Etype (Pool, Empty);
14173 -- Case of Default_Storage_Pool (storage_pool_NAME);
14176 -- If it's a configuration pragma, then the only allowed
14177 -- argument is "null".
14179 if Is_Configuration_Pragma then
14180 Error_Pragma_Arg ("NULL expected", Arg1);
14183 -- The expected type for a non-"null" argument is
14184 -- Root_Storage_Pool'Class, and the pool must be a variable.
14186 Analyze_And_Resolve
14187 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
14189 if Is_Variable (Pool) then
14191 -- A pragma that applies to a Ghost entity becomes Ghost
14192 -- for the purposes of legality checks and removal of
14193 -- ignored Ghost code.
14195 Mark_Ghost_Pragma (N, Entity (Pool));
14199 ("default storage pool must be a variable", Arg1);
14203 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14204 -- access type will use this information to set the appropriate
14205 -- attributes of the access type.
14207 Default_Pool := Pool;
14209 end Default_Storage_Pool;
14215 -- pragma Depends (DEPENDENCY_RELATION);
14217 -- DEPENDENCY_RELATION ::=
14219 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14221 -- DEPENDENCY_CLAUSE ::=
14222 -- OUTPUT_LIST =>[+] INPUT_LIST
14223 -- | NULL_DEPENDENCY_CLAUSE
14225 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14227 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14229 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14231 -- OUTPUT ::= NAME | FUNCTION_RESULT
14234 -- where FUNCTION_RESULT is a function Result attribute_reference
14236 -- Characteristics:
14238 -- * Analysis - The annotation undergoes initial checks to verify
14239 -- the legal placement and context. Secondary checks fully analyze
14240 -- the dependency clauses in:
14242 -- Analyze_Depends_In_Decl_Part
14244 -- * Expansion - None.
14246 -- * Template - The annotation utilizes the generic template of the
14247 -- related subprogram [body] when it is:
14249 -- aspect on subprogram declaration
14250 -- aspect on stand alone subprogram body
14251 -- pragma on stand alone subprogram body
14253 -- The annotation must prepare its own template when it is:
14255 -- pragma on subprogram declaration
14257 -- * Globals - Capture of global references must occur after full
14260 -- * Instance - The annotation is instantiated automatically when
14261 -- the related generic subprogram [body] is instantiated except for
14262 -- the "pragma on subprogram declaration" case. In that scenario
14263 -- the annotation must instantiate itself.
14265 when Pragma_Depends => Depends : declare
14267 Spec_Id : Entity_Id;
14268 Subp_Decl : Node_Id;
14271 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14275 -- Chain the pragma on the contract for further processing by
14276 -- Analyze_Depends_In_Decl_Part.
14278 Add_Contract_Item (N, Spec_Id);
14280 -- Fully analyze the pragma when it appears inside an entry
14281 -- or subprogram body because it cannot benefit from forward
14284 if Nkind_In (Subp_Decl, N_Entry_Body,
14286 N_Subprogram_Body_Stub)
14288 -- The legality checks of pragmas Depends and Global are
14289 -- affected by the SPARK mode in effect and the volatility
14290 -- of the context. In addition these two pragmas are subject
14291 -- to an inherent order:
14296 -- Analyze all these pragmas in the order outlined above
14298 Analyze_If_Present (Pragma_SPARK_Mode);
14299 Analyze_If_Present (Pragma_Volatile_Function);
14300 Analyze_If_Present (Pragma_Global);
14301 Analyze_Depends_In_Decl_Part (N);
14306 ---------------------
14307 -- Detect_Blocking --
14308 ---------------------
14310 -- pragma Detect_Blocking;
14312 when Pragma_Detect_Blocking =>
14314 Check_Arg_Count (0);
14315 Check_Valid_Configuration_Pragma;
14316 Detect_Blocking := True;
14318 ------------------------------------
14319 -- Disable_Atomic_Synchronization --
14320 ------------------------------------
14322 -- pragma Disable_Atomic_Synchronization [(Entity)];
14324 when Pragma_Disable_Atomic_Synchronization =>
14326 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14328 -------------------
14329 -- Discard_Names --
14330 -------------------
14332 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14334 when Pragma_Discard_Names => Discard_Names : declare
14339 Check_Ada_83_Warning;
14341 -- Deal with configuration pragma case
14343 if Arg_Count = 0 and then Is_Configuration_Pragma then
14344 Global_Discard_Names := True;
14347 -- Otherwise, check correct appropriate context
14350 Check_Is_In_Decl_Part_Or_Package_Spec;
14352 if Arg_Count = 0 then
14354 -- If there is no parameter, then from now on this pragma
14355 -- applies to any enumeration, exception or tagged type
14356 -- defined in the current declarative part, and recursively
14357 -- to any nested scope.
14359 Set_Discard_Names (Current_Scope);
14363 Check_Arg_Count (1);
14364 Check_Optional_Identifier (Arg1, Name_On);
14365 Check_Arg_Is_Local_Name (Arg1);
14367 E_Id := Get_Pragma_Arg (Arg1);
14369 if Etype (E_Id) = Any_Type then
14372 E := Entity (E_Id);
14375 -- A pragma that applies to a Ghost entity becomes Ghost for
14376 -- the purposes of legality checks and removal of ignored
14379 Mark_Ghost_Pragma (N, E);
14381 if (Is_First_Subtype (E)
14383 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14384 or else Ekind (E) = E_Exception
14386 Set_Discard_Names (E);
14387 Record_Rep_Item (E, N);
14391 ("inappropriate entity for pragma%", Arg1);
14397 ------------------------
14398 -- Dispatching_Domain --
14399 ------------------------
14401 -- pragma Dispatching_Domain (EXPRESSION);
14403 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14404 P : constant Node_Id := Parent (N);
14410 Check_No_Identifiers;
14411 Check_Arg_Count (1);
14413 -- This pragma is born obsolete, but not the aspect
14415 if not From_Aspect_Specification (N) then
14417 (No_Obsolescent_Features, Pragma_Identifier (N));
14420 if Nkind (P) = N_Task_Definition then
14421 Arg := Get_Pragma_Arg (Arg1);
14422 Ent := Defining_Identifier (Parent (P));
14424 -- A pragma that applies to a Ghost entity becomes Ghost for
14425 -- the purposes of legality checks and removal of ignored Ghost
14428 Mark_Ghost_Pragma (N, Ent);
14430 -- The expression must be analyzed in the special manner
14431 -- described in "Handling of Default and Per-Object
14432 -- Expressions" in sem.ads.
14434 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14436 -- Check duplicate pragma before we chain the pragma in the Rep
14437 -- Item chain of Ent.
14439 Check_Duplicate_Pragma (Ent);
14440 Record_Rep_Item (Ent, N);
14442 -- Anything else is incorrect
14447 end Dispatching_Domain;
14453 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14455 when Pragma_Elaborate => Elaborate : declare
14460 -- Pragma must be in context items list of a compilation unit
14462 if not Is_In_Context_Clause then
14466 -- Must be at least one argument
14468 if Arg_Count = 0 then
14469 Error_Pragma ("pragma% requires at least one argument");
14472 -- In Ada 83 mode, there can be no items following it in the
14473 -- context list except other pragmas and implicit with clauses
14474 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14475 -- placement rule does not apply.
14477 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14479 while Present (Citem) loop
14480 if Nkind (Citem) = N_Pragma
14481 or else (Nkind (Citem) = N_With_Clause
14482 and then Implicit_With (Citem))
14487 ("(Ada 83) pragma% must be at end of context clause");
14494 -- Finally, the arguments must all be units mentioned in a with
14495 -- clause in the same context clause. Note we already checked (in
14496 -- Par.Prag) that the arguments are all identifiers or selected
14500 Outer : while Present (Arg) loop
14501 Citem := First (List_Containing (N));
14502 Inner : while Citem /= N loop
14503 if Nkind (Citem) = N_With_Clause
14504 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14506 Set_Elaborate_Present (Citem, True);
14507 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14509 -- With the pragma present, elaboration calls on
14510 -- subprograms from the named unit need no further
14511 -- checks, as long as the pragma appears in the current
14512 -- compilation unit. If the pragma appears in some unit
14513 -- in the context, there might still be a need for an
14514 -- Elaborate_All_Desirable from the current compilation
14515 -- to the named unit, so we keep the check enabled.
14517 if In_Extended_Main_Source_Unit (N) then
14519 -- This does not apply in SPARK mode, where we allow
14520 -- pragma Elaborate, but we don't trust it to be right
14521 -- so we will still insist on the Elaborate_All.
14523 if SPARK_Mode /= On then
14524 Set_Suppress_Elaboration_Warnings
14525 (Entity (Name (Citem)));
14537 ("argument of pragma% is not withed unit", Arg);
14543 -- Give a warning if operating in static mode with one of the
14544 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14547 and not Dynamic_Elaboration_Checks
14549 -- pragma Elaborate not allowed in SPARK mode anyway. We
14550 -- already complained about it, no point in generating any
14551 -- further complaint.
14553 and SPARK_Mode /= On
14556 ("?l?use of pragma Elaborate may not be safe", N);
14558 ("?l?use pragma Elaborate_All instead if possible", N);
14562 -------------------
14563 -- Elaborate_All --
14564 -------------------
14566 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14568 when Pragma_Elaborate_All => Elaborate_All : declare
14573 Check_Ada_83_Warning;
14575 -- Pragma must be in context items list of a compilation unit
14577 if not Is_In_Context_Clause then
14581 -- Must be at least one argument
14583 if Arg_Count = 0 then
14584 Error_Pragma ("pragma% requires at least one argument");
14587 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14588 -- have to appear at the end of the context clause, but may
14589 -- appear mixed in with other items, even in Ada 83 mode.
14591 -- Final check: the arguments must all be units mentioned in
14592 -- a with clause in the same context clause. Note that we
14593 -- already checked (in Par.Prag) that all the arguments are
14594 -- either identifiers or selected components.
14597 Outr : while Present (Arg) loop
14598 Citem := First (List_Containing (N));
14599 Innr : while Citem /= N loop
14600 if Nkind (Citem) = N_With_Clause
14601 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14603 Set_Elaborate_All_Present (Citem, True);
14604 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14606 -- Suppress warnings and elaboration checks on the named
14607 -- unit if the pragma is in the current compilation, as
14608 -- for pragma Elaborate.
14610 if In_Extended_Main_Source_Unit (N) then
14611 Set_Suppress_Elaboration_Warnings
14612 (Entity (Name (Citem)));
14621 Set_Error_Posted (N);
14623 ("argument of pragma% is not withed unit", Arg);
14630 --------------------
14631 -- Elaborate_Body --
14632 --------------------
14634 -- pragma Elaborate_Body [( library_unit_NAME )];
14636 when Pragma_Elaborate_Body => Elaborate_Body : declare
14637 Cunit_Node : Node_Id;
14638 Cunit_Ent : Entity_Id;
14641 Check_Ada_83_Warning;
14642 Check_Valid_Library_Unit_Pragma;
14644 if Nkind (N) = N_Null_Statement then
14648 Cunit_Node := Cunit (Current_Sem_Unit);
14649 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14651 -- A pragma that applies to a Ghost entity becomes Ghost for the
14652 -- purposes of legality checks and removal of ignored Ghost code.
14654 Mark_Ghost_Pragma (N, Cunit_Ent);
14656 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14659 Error_Pragma ("pragma% must refer to a spec, not a body");
14661 Set_Body_Required (Cunit_Node, True);
14662 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14664 -- If we are in dynamic elaboration mode, then we suppress
14665 -- elaboration warnings for the unit, since it is definitely
14666 -- fine NOT to do dynamic checks at the first level (and such
14667 -- checks will be suppressed because no elaboration boolean
14668 -- is created for Elaborate_Body packages).
14670 -- But in the static model of elaboration, Elaborate_Body is
14671 -- definitely NOT good enough to ensure elaboration safety on
14672 -- its own, since the body may WITH other units that are not
14673 -- safe from an elaboration point of view, so a client must
14674 -- still do an Elaborate_All on such units.
14676 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14677 -- Elaborate_Body always suppressed elab warnings.
14679 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14680 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14683 end Elaborate_Body;
14685 ------------------------
14686 -- Elaboration_Checks --
14687 ------------------------
14689 -- pragma Elaboration_Checks (Static | Dynamic);
14691 when Pragma_Elaboration_Checks =>
14693 Check_Arg_Count (1);
14694 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14696 -- Set flag accordingly (ignore attempt at dynamic elaboration
14697 -- checks in SPARK mode).
14699 Dynamic_Elaboration_Checks :=
14700 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14706 -- pragma Eliminate (
14707 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14708 -- [,[Entity =>] IDENTIFIER |
14709 -- SELECTED_COMPONENT |
14711 -- [, OVERLOADING_RESOLUTION]);
14713 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14716 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14717 -- FUNCTION_PROFILE
14719 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14721 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14722 -- Result_Type => result_SUBTYPE_NAME]
14724 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14725 -- SUBTYPE_NAME ::= STRING_LITERAL
14727 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14728 -- SOURCE_TRACE ::= STRING_LITERAL
14730 when Pragma_Eliminate => Eliminate : declare
14731 Args : Args_List (1 .. 5);
14732 Names : constant Name_List (1 .. 5) := (
14735 Name_Parameter_Types,
14737 Name_Source_Location);
14739 Unit_Name : Node_Id renames Args (1);
14740 Entity : Node_Id renames Args (2);
14741 Parameter_Types : Node_Id renames Args (3);
14742 Result_Type : Node_Id renames Args (4);
14743 Source_Location : Node_Id renames Args (5);
14747 Check_Valid_Configuration_Pragma;
14748 Gather_Associations (Names, Args);
14750 if No (Unit_Name) then
14751 Error_Pragma ("missing Unit_Name argument for pragma%");
14755 and then (Present (Parameter_Types)
14757 Present (Result_Type)
14759 Present (Source_Location))
14761 Error_Pragma ("missing Entity argument for pragma%");
14764 if (Present (Parameter_Types)
14766 Present (Result_Type))
14768 Present (Source_Location)
14771 ("parameter profile and source location cannot be used "
14772 & "together in pragma%");
14775 Process_Eliminate_Pragma
14784 -----------------------------------
14785 -- Enable_Atomic_Synchronization --
14786 -----------------------------------
14788 -- pragma Enable_Atomic_Synchronization [(Entity)];
14790 when Pragma_Enable_Atomic_Synchronization =>
14792 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14799 -- [ Convention =>] convention_IDENTIFIER,
14800 -- [ Entity =>] LOCAL_NAME
14801 -- [, [External_Name =>] static_string_EXPRESSION ]
14802 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14804 when Pragma_Export => Export : declare
14806 Def_Id : Entity_Id;
14808 pragma Warnings (Off, C);
14811 Check_Ada_83_Warning;
14815 Name_External_Name,
14818 Check_At_Least_N_Arguments (2);
14819 Check_At_Most_N_Arguments (4);
14821 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14822 -- pragma Export (Entity, "external name");
14824 if Relaxed_RM_Semantics
14825 and then Arg_Count = 2
14826 and then Nkind (Expression (Arg2)) = N_String_Literal
14829 Def_Id := Get_Pragma_Arg (Arg1);
14832 if not Is_Entity_Name (Def_Id) then
14833 Error_Pragma_Arg ("entity name required", Arg1);
14836 Def_Id := Entity (Def_Id);
14837 Set_Exported (Def_Id, Arg1);
14840 Process_Convention (C, Def_Id);
14842 -- A pragma that applies to a Ghost entity becomes Ghost for
14843 -- the purposes of legality checks and removal of ignored Ghost
14846 Mark_Ghost_Pragma (N, Def_Id);
14848 if Ekind (Def_Id) /= E_Constant then
14849 Note_Possible_Modification
14850 (Get_Pragma_Arg (Arg2), Sure => False);
14853 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
14854 Set_Exported (Def_Id, Arg2);
14857 -- If the entity is a deferred constant, propagate the information
14858 -- to the full view, because gigi elaborates the full view only.
14860 if Ekind (Def_Id) = E_Constant
14861 and then Present (Full_View (Def_Id))
14864 Id2 : constant Entity_Id := Full_View (Def_Id);
14866 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14867 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14868 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14873 ---------------------
14874 -- Export_Function --
14875 ---------------------
14877 -- pragma Export_Function (
14878 -- [Internal =>] LOCAL_NAME
14879 -- [, [External =>] EXTERNAL_SYMBOL]
14880 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14881 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14882 -- [, [Mechanism =>] MECHANISM]
14883 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14885 -- EXTERNAL_SYMBOL ::=
14887 -- | static_string_EXPRESSION
14889 -- PARAMETER_TYPES ::=
14891 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14893 -- TYPE_DESIGNATOR ::=
14895 -- | subtype_Name ' Access
14899 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14901 -- MECHANISM_ASSOCIATION ::=
14902 -- [formal_parameter_NAME =>] MECHANISM_NAME
14904 -- MECHANISM_NAME ::=
14908 when Pragma_Export_Function => Export_Function : declare
14909 Args : Args_List (1 .. 6);
14910 Names : constant Name_List (1 .. 6) := (
14913 Name_Parameter_Types,
14916 Name_Result_Mechanism);
14918 Internal : Node_Id renames Args (1);
14919 External : Node_Id renames Args (2);
14920 Parameter_Types : Node_Id renames Args (3);
14921 Result_Type : Node_Id renames Args (4);
14922 Mechanism : Node_Id renames Args (5);
14923 Result_Mechanism : Node_Id renames Args (6);
14927 Gather_Associations (Names, Args);
14928 Process_Extended_Import_Export_Subprogram_Pragma (
14929 Arg_Internal => Internal,
14930 Arg_External => External,
14931 Arg_Parameter_Types => Parameter_Types,
14932 Arg_Result_Type => Result_Type,
14933 Arg_Mechanism => Mechanism,
14934 Arg_Result_Mechanism => Result_Mechanism);
14935 end Export_Function;
14937 -------------------
14938 -- Export_Object --
14939 -------------------
14941 -- pragma Export_Object (
14942 -- [Internal =>] LOCAL_NAME
14943 -- [, [External =>] EXTERNAL_SYMBOL]
14944 -- [, [Size =>] EXTERNAL_SYMBOL]);
14946 -- EXTERNAL_SYMBOL ::=
14948 -- | static_string_EXPRESSION
14950 -- PARAMETER_TYPES ::=
14952 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14954 -- TYPE_DESIGNATOR ::=
14956 -- | subtype_Name ' Access
14960 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14962 -- MECHANISM_ASSOCIATION ::=
14963 -- [formal_parameter_NAME =>] MECHANISM_NAME
14965 -- MECHANISM_NAME ::=
14969 when Pragma_Export_Object => Export_Object : declare
14970 Args : Args_List (1 .. 3);
14971 Names : constant Name_List (1 .. 3) := (
14976 Internal : Node_Id renames Args (1);
14977 External : Node_Id renames Args (2);
14978 Size : Node_Id renames Args (3);
14982 Gather_Associations (Names, Args);
14983 Process_Extended_Import_Export_Object_Pragma (
14984 Arg_Internal => Internal,
14985 Arg_External => External,
14989 ----------------------
14990 -- Export_Procedure --
14991 ----------------------
14993 -- pragma Export_Procedure (
14994 -- [Internal =>] LOCAL_NAME
14995 -- [, [External =>] EXTERNAL_SYMBOL]
14996 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14997 -- [, [Mechanism =>] MECHANISM]);
14999 -- EXTERNAL_SYMBOL ::=
15001 -- | static_string_EXPRESSION
15003 -- PARAMETER_TYPES ::=
15005 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15007 -- TYPE_DESIGNATOR ::=
15009 -- | subtype_Name ' Access
15013 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15015 -- MECHANISM_ASSOCIATION ::=
15016 -- [formal_parameter_NAME =>] MECHANISM_NAME
15018 -- MECHANISM_NAME ::=
15022 when Pragma_Export_Procedure => Export_Procedure : declare
15023 Args : Args_List (1 .. 4);
15024 Names : constant Name_List (1 .. 4) := (
15027 Name_Parameter_Types,
15030 Internal : Node_Id renames Args (1);
15031 External : Node_Id renames Args (2);
15032 Parameter_Types : Node_Id renames Args (3);
15033 Mechanism : Node_Id renames Args (4);
15037 Gather_Associations (Names, Args);
15038 Process_Extended_Import_Export_Subprogram_Pragma (
15039 Arg_Internal => Internal,
15040 Arg_External => External,
15041 Arg_Parameter_Types => Parameter_Types,
15042 Arg_Mechanism => Mechanism);
15043 end Export_Procedure;
15049 -- pragma Export_Value (
15050 -- [Value =>] static_integer_EXPRESSION,
15051 -- [Link_Name =>] static_string_EXPRESSION);
15053 when Pragma_Export_Value =>
15055 Check_Arg_Order ((Name_Value, Name_Link_Name));
15056 Check_Arg_Count (2);
15058 Check_Optional_Identifier (Arg1, Name_Value);
15059 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
15061 Check_Optional_Identifier (Arg2, Name_Link_Name);
15062 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
15064 -----------------------------
15065 -- Export_Valued_Procedure --
15066 -----------------------------
15068 -- pragma Export_Valued_Procedure (
15069 -- [Internal =>] LOCAL_NAME
15070 -- [, [External =>] EXTERNAL_SYMBOL,]
15071 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15072 -- [, [Mechanism =>] MECHANISM]);
15074 -- EXTERNAL_SYMBOL ::=
15076 -- | static_string_EXPRESSION
15078 -- PARAMETER_TYPES ::=
15080 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15082 -- TYPE_DESIGNATOR ::=
15084 -- | subtype_Name ' Access
15088 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15090 -- MECHANISM_ASSOCIATION ::=
15091 -- [formal_parameter_NAME =>] MECHANISM_NAME
15093 -- MECHANISM_NAME ::=
15097 when Pragma_Export_Valued_Procedure =>
15098 Export_Valued_Procedure : declare
15099 Args : Args_List (1 .. 4);
15100 Names : constant Name_List (1 .. 4) := (
15103 Name_Parameter_Types,
15106 Internal : Node_Id renames Args (1);
15107 External : Node_Id renames Args (2);
15108 Parameter_Types : Node_Id renames Args (3);
15109 Mechanism : Node_Id renames Args (4);
15113 Gather_Associations (Names, Args);
15114 Process_Extended_Import_Export_Subprogram_Pragma (
15115 Arg_Internal => Internal,
15116 Arg_External => External,
15117 Arg_Parameter_Types => Parameter_Types,
15118 Arg_Mechanism => Mechanism);
15119 end Export_Valued_Procedure;
15121 -------------------
15122 -- Extend_System --
15123 -------------------
15125 -- pragma Extend_System ([Name =>] Identifier);
15127 when Pragma_Extend_System =>
15129 Check_Valid_Configuration_Pragma;
15130 Check_Arg_Count (1);
15131 Check_Optional_Identifier (Arg1, Name_Name);
15132 Check_Arg_Is_Identifier (Arg1);
15134 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15137 and then Name_Buffer (1 .. 4) = "aux_"
15139 if Present (System_Extend_Pragma_Arg) then
15140 if Chars (Get_Pragma_Arg (Arg1)) =
15141 Chars (Expression (System_Extend_Pragma_Arg))
15145 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
15146 Error_Pragma ("pragma% conflicts with that #");
15150 System_Extend_Pragma_Arg := Arg1;
15152 if not GNAT_Mode then
15153 System_Extend_Unit := Arg1;
15157 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
15160 ------------------------
15161 -- Extensions_Allowed --
15162 ------------------------
15164 -- pragma Extensions_Allowed (ON | OFF);
15166 when Pragma_Extensions_Allowed =>
15168 Check_Arg_Count (1);
15169 Check_No_Identifiers;
15170 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
15172 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
15173 Extensions_Allowed := True;
15174 Ada_Version := Ada_Version_Type'Last;
15177 Extensions_Allowed := False;
15178 Ada_Version := Ada_Version_Explicit;
15179 Ada_Version_Pragma := Empty;
15182 ------------------------
15183 -- Extensions_Visible --
15184 ------------------------
15186 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15188 -- Characteristics:
15190 -- * Analysis - The annotation is fully analyzed immediately upon
15191 -- elaboration as its expression must be static.
15193 -- * Expansion - None.
15195 -- * Template - The annotation utilizes the generic template of the
15196 -- related subprogram [body] when it is:
15198 -- aspect on subprogram declaration
15199 -- aspect on stand alone subprogram body
15200 -- pragma on stand alone subprogram body
15202 -- The annotation must prepare its own template when it is:
15204 -- pragma on subprogram declaration
15206 -- * Globals - Capture of global references must occur after full
15209 -- * Instance - The annotation is instantiated automatically when
15210 -- the related generic subprogram [body] is instantiated except for
15211 -- the "pragma on subprogram declaration" case. In that scenario
15212 -- the annotation must instantiate itself.
15214 when Pragma_Extensions_Visible => Extensions_Visible : declare
15215 Formal : Entity_Id;
15216 Has_OK_Formal : Boolean := False;
15217 Spec_Id : Entity_Id;
15218 Subp_Decl : Node_Id;
15222 Check_No_Identifiers;
15223 Check_At_Most_N_Arguments (1);
15226 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15228 -- Abstract subprogram declaration
15230 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15233 -- Generic subprogram declaration
15235 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15238 -- Body acts as spec
15240 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15241 and then No (Corresponding_Spec (Subp_Decl))
15245 -- Body stub acts as spec
15247 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15248 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15252 -- Subprogram declaration
15254 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15257 -- Otherwise the pragma is associated with an illegal construct
15260 Error_Pragma ("pragma % must apply to a subprogram");
15264 -- Mark the pragma as Ghost if the related subprogram is also
15265 -- Ghost. This also ensures that any expansion performed further
15266 -- below will produce Ghost nodes.
15268 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15269 Mark_Ghost_Pragma (N, Spec_Id);
15271 -- Chain the pragma on the contract for completeness
15273 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15275 -- The legality checks of pragma Extension_Visible are affected
15276 -- by the SPARK mode in effect. Analyze all pragmas in specific
15279 Analyze_If_Present (Pragma_SPARK_Mode);
15281 -- Examine the formals of the related subprogram
15283 Formal := First_Formal (Spec_Id);
15284 while Present (Formal) loop
15286 -- At least one of the formals is of a specific tagged type,
15287 -- the pragma is legal.
15289 if Is_Specific_Tagged_Type (Etype (Formal)) then
15290 Has_OK_Formal := True;
15293 -- A generic subprogram with at least one formal of a private
15294 -- type ensures the legality of the pragma because the actual
15295 -- may be specifically tagged. Note that this is verified by
15296 -- the check above at instantiation time.
15298 elsif Is_Private_Type (Etype (Formal))
15299 and then Is_Generic_Type (Etype (Formal))
15301 Has_OK_Formal := True;
15305 Next_Formal (Formal);
15308 if not Has_OK_Formal then
15309 Error_Msg_Name_1 := Pname;
15310 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15312 ("\subprogram & lacks parameter of specific tagged or "
15313 & "generic private type", N, Spec_Id);
15318 -- Analyze the Boolean expression (if any)
15320 if Present (Arg1) then
15321 Check_Static_Boolean_Expression
15322 (Expression (Get_Argument (N, Spec_Id)));
15324 end Extensions_Visible;
15330 -- pragma External (
15331 -- [ Convention =>] convention_IDENTIFIER,
15332 -- [ Entity =>] LOCAL_NAME
15333 -- [, [External_Name =>] static_string_EXPRESSION ]
15334 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15336 when Pragma_External => External : declare
15339 pragma Warnings (Off, C);
15346 Name_External_Name,
15348 Check_At_Least_N_Arguments (2);
15349 Check_At_Most_N_Arguments (4);
15350 Process_Convention (C, E);
15352 -- A pragma that applies to a Ghost entity becomes Ghost for the
15353 -- purposes of legality checks and removal of ignored Ghost code.
15355 Mark_Ghost_Pragma (N, E);
15357 Note_Possible_Modification
15358 (Get_Pragma_Arg (Arg2), Sure => False);
15359 Process_Interface_Name (E, Arg3, Arg4, N);
15360 Set_Exported (E, Arg2);
15363 --------------------------
15364 -- External_Name_Casing --
15365 --------------------------
15367 -- pragma External_Name_Casing (
15368 -- UPPERCASE | LOWERCASE
15369 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15371 when Pragma_External_Name_Casing =>
15373 Check_No_Identifiers;
15375 if Arg_Count = 2 then
15376 Check_Arg_Is_One_Of
15377 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15379 case Chars (Get_Pragma_Arg (Arg2)) is
15381 Opt.External_Name_Exp_Casing := As_Is;
15383 when Name_Uppercase =>
15384 Opt.External_Name_Exp_Casing := Uppercase;
15386 when Name_Lowercase =>
15387 Opt.External_Name_Exp_Casing := Lowercase;
15394 Check_Arg_Count (1);
15397 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15399 case Chars (Get_Pragma_Arg (Arg1)) is
15400 when Name_Uppercase =>
15401 Opt.External_Name_Imp_Casing := Uppercase;
15403 when Name_Lowercase =>
15404 Opt.External_Name_Imp_Casing := Lowercase;
15414 -- pragma Fast_Math;
15416 when Pragma_Fast_Math =>
15418 Check_No_Identifiers;
15419 Check_Valid_Configuration_Pragma;
15422 --------------------------
15423 -- Favor_Top_Level --
15424 --------------------------
15426 -- pragma Favor_Top_Level (type_NAME);
15428 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15433 Check_No_Identifiers;
15434 Check_Arg_Count (1);
15435 Check_Arg_Is_Local_Name (Arg1);
15436 Typ := Entity (Get_Pragma_Arg (Arg1));
15438 -- A pragma that applies to a Ghost entity becomes Ghost for the
15439 -- purposes of legality checks and removal of ignored Ghost code.
15441 Mark_Ghost_Pragma (N, Typ);
15443 -- If it's an access-to-subprogram type (in particular, not a
15444 -- subtype), set the flag on that type.
15446 if Is_Access_Subprogram_Type (Typ) then
15447 Set_Can_Use_Internal_Rep (Typ, False);
15449 -- Otherwise it's an error (name denotes the wrong sort of entity)
15453 ("access-to-subprogram type expected",
15454 Get_Pragma_Arg (Arg1));
15456 end Favor_Top_Level;
15458 ---------------------------
15459 -- Finalize_Storage_Only --
15460 ---------------------------
15462 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15464 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15465 Assoc : constant Node_Id := Arg1;
15466 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15471 Check_No_Identifiers;
15472 Check_Arg_Count (1);
15473 Check_Arg_Is_Local_Name (Arg1);
15475 Find_Type (Type_Id);
15476 Typ := Entity (Type_Id);
15479 or else Rep_Item_Too_Early (Typ, N)
15483 Typ := Underlying_Type (Typ);
15486 if not Is_Controlled (Typ) then
15487 Error_Pragma ("pragma% must specify controlled type");
15490 Check_First_Subtype (Arg1);
15492 if Finalize_Storage_Only (Typ) then
15493 Error_Pragma ("duplicate pragma%, only one allowed");
15495 elsif not Rep_Item_Too_Late (Typ, N) then
15496 Set_Finalize_Storage_Only (Base_Type (Typ), True);
15498 end Finalize_Storage;
15504 -- pragma Ghost [ (boolean_EXPRESSION) ];
15506 when Pragma_Ghost => Ghost : declare
15510 Orig_Stmt : Node_Id;
15511 Prev_Id : Entity_Id;
15516 Check_No_Identifiers;
15517 Check_At_Most_N_Arguments (1);
15521 while Present (Stmt) loop
15523 -- Skip prior pragmas, but check for duplicates
15525 if Nkind (Stmt) = N_Pragma then
15526 if Pragma_Name (Stmt) = Pname then
15533 -- Task unit declared without a definition cannot be subject to
15534 -- pragma Ghost (SPARK RM 6.9(19)).
15536 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15537 N_Task_Type_Declaration)
15539 Error_Pragma ("pragma % cannot apply to a task type");
15542 -- Skip internally generated code
15544 elsif not Comes_From_Source (Stmt) then
15545 Orig_Stmt := Original_Node (Stmt);
15547 -- When pragma Ghost applies to an untagged derivation, the
15548 -- derivation is transformed into a [sub]type declaration.
15550 if Nkind_In (Stmt, N_Full_Type_Declaration,
15551 N_Subtype_Declaration)
15552 and then Comes_From_Source (Orig_Stmt)
15553 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15554 and then Nkind (Type_Definition (Orig_Stmt)) =
15555 N_Derived_Type_Definition
15557 Id := Defining_Entity (Stmt);
15560 -- When pragma Ghost applies to an object declaration which
15561 -- is initialized by means of a function call that returns
15562 -- on the secondary stack, the object declaration becomes a
15565 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15566 and then Comes_From_Source (Orig_Stmt)
15567 and then Nkind (Orig_Stmt) = N_Object_Declaration
15569 Id := Defining_Entity (Stmt);
15572 -- When pragma Ghost applies to an expression function, the
15573 -- expression function is transformed into a subprogram.
15575 elsif Nkind (Stmt) = N_Subprogram_Declaration
15576 and then Comes_From_Source (Orig_Stmt)
15577 and then Nkind (Orig_Stmt) = N_Expression_Function
15579 Id := Defining_Entity (Stmt);
15583 -- The pragma applies to a legal construct, stop the traversal
15585 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15586 N_Full_Type_Declaration,
15587 N_Generic_Subprogram_Declaration,
15588 N_Object_Declaration,
15589 N_Private_Extension_Declaration,
15590 N_Private_Type_Declaration,
15591 N_Subprogram_Declaration,
15592 N_Subtype_Declaration)
15594 Id := Defining_Entity (Stmt);
15597 -- The pragma does not apply to a legal construct, issue an
15598 -- error and stop the analysis.
15602 ("pragma % must apply to an object, package, subprogram "
15607 Stmt := Prev (Stmt);
15610 Context := Parent (N);
15612 -- Handle compilation units
15614 if Nkind (Context) = N_Compilation_Unit_Aux then
15615 Context := Unit (Parent (Context));
15618 -- Protected and task types cannot be subject to pragma Ghost
15619 -- (SPARK RM 6.9(19)).
15621 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15623 Error_Pragma ("pragma % cannot apply to a protected type");
15626 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15627 Error_Pragma ("pragma % cannot apply to a task type");
15633 -- When pragma Ghost is associated with a [generic] package, it
15634 -- appears in the visible declarations.
15636 if Nkind (Context) = N_Package_Specification
15637 and then Present (Visible_Declarations (Context))
15638 and then List_Containing (N) = Visible_Declarations (Context)
15640 Id := Defining_Entity (Context);
15642 -- Pragma Ghost applies to a stand alone subprogram body
15644 elsif Nkind (Context) = N_Subprogram_Body
15645 and then No (Corresponding_Spec (Context))
15647 Id := Defining_Entity (Context);
15649 -- Pragma Ghost applies to a subprogram declaration that acts
15650 -- as a compilation unit.
15652 elsif Nkind (Context) = N_Subprogram_Declaration then
15653 Id := Defining_Entity (Context);
15659 ("pragma % must apply to an object, package, subprogram or "
15664 -- Handle completions of types and constants that are subject to
15667 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15668 Prev_Id := Incomplete_Or_Partial_View (Id);
15670 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15671 Error_Msg_Name_1 := Pname;
15673 -- The full declaration of a deferred constant cannot be
15674 -- subject to pragma Ghost unless the deferred declaration
15675 -- is also Ghost (SPARK RM 6.9(9)).
15677 if Ekind (Prev_Id) = E_Constant then
15678 Error_Msg_Name_1 := Pname;
15679 Error_Msg_NE (Fix_Error
15680 ("pragma % must apply to declaration of deferred "
15681 & "constant &"), N, Id);
15684 -- Pragma Ghost may appear on the full view of an incomplete
15685 -- type because the incomplete declaration lacks aspects and
15686 -- cannot be subject to pragma Ghost.
15688 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15691 -- The full declaration of a type cannot be subject to
15692 -- pragma Ghost unless the partial view is also Ghost
15693 -- (SPARK RM 6.9(9)).
15696 Error_Msg_NE (Fix_Error
15697 ("pragma % must apply to partial view of type &"),
15703 -- A synchronized object cannot be subject to pragma Ghost
15704 -- (SPARK RM 6.9(19)).
15706 elsif Ekind (Id) = E_Variable then
15707 if Is_Protected_Type (Etype (Id)) then
15708 Error_Pragma ("pragma % cannot apply to a protected object");
15711 elsif Is_Task_Type (Etype (Id)) then
15712 Error_Pragma ("pragma % cannot apply to a task object");
15717 -- Analyze the Boolean expression (if any)
15719 if Present (Arg1) then
15720 Expr := Get_Pragma_Arg (Arg1);
15722 Analyze_And_Resolve (Expr, Standard_Boolean);
15724 if Is_OK_Static_Expression (Expr) then
15726 -- "Ghostness" cannot be turned off once enabled within a
15727 -- region (SPARK RM 6.9(6)).
15729 if Is_False (Expr_Value (Expr))
15730 and then Ghost_Mode > None
15733 ("pragma % with value False cannot appear in enabled "
15738 -- Otherwie the expression is not static
15742 ("expression of pragma % must be static", Expr);
15747 Set_Is_Ghost_Entity (Id);
15754 -- pragma Global (GLOBAL_SPECIFICATION);
15756 -- GLOBAL_SPECIFICATION ::=
15759 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15761 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15763 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15764 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15765 -- GLOBAL_ITEM ::= NAME
15767 -- Characteristics:
15769 -- * Analysis - The annotation undergoes initial checks to verify
15770 -- the legal placement and context. Secondary checks fully analyze
15771 -- the dependency clauses in:
15773 -- Analyze_Global_In_Decl_Part
15775 -- * Expansion - None.
15777 -- * Template - The annotation utilizes the generic template of the
15778 -- related subprogram [body] when it is:
15780 -- aspect on subprogram declaration
15781 -- aspect on stand alone subprogram body
15782 -- pragma on stand alone subprogram body
15784 -- The annotation must prepare its own template when it is:
15786 -- pragma on subprogram declaration
15788 -- * Globals - Capture of global references must occur after full
15791 -- * Instance - The annotation is instantiated automatically when
15792 -- the related generic subprogram [body] is instantiated except for
15793 -- the "pragma on subprogram declaration" case. In that scenario
15794 -- the annotation must instantiate itself.
15796 when Pragma_Global => Global : declare
15798 Spec_Id : Entity_Id;
15799 Subp_Decl : Node_Id;
15802 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15806 -- Chain the pragma on the contract for further processing by
15807 -- Analyze_Global_In_Decl_Part.
15809 Add_Contract_Item (N, Spec_Id);
15811 -- Fully analyze the pragma when it appears inside an entry
15812 -- or subprogram body because it cannot benefit from forward
15815 if Nkind_In (Subp_Decl, N_Entry_Body,
15817 N_Subprogram_Body_Stub)
15819 -- The legality checks of pragmas Depends and Global are
15820 -- affected by the SPARK mode in effect and the volatility
15821 -- of the context. In addition these two pragmas are subject
15822 -- to an inherent order:
15827 -- Analyze all these pragmas in the order outlined above
15829 Analyze_If_Present (Pragma_SPARK_Mode);
15830 Analyze_If_Present (Pragma_Volatile_Function);
15831 Analyze_Global_In_Decl_Part (N);
15832 Analyze_If_Present (Pragma_Depends);
15841 -- pragma Ident (static_string_EXPRESSION)
15843 -- Note: pragma Comment shares this processing. Pragma Ident is
15844 -- identical in effect to pragma Commment.
15846 when Pragma_Comment
15854 Check_Arg_Count (1);
15855 Check_No_Identifiers;
15856 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15859 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15866 GP := Parent (Parent (N));
15868 if Nkind_In (GP, N_Package_Declaration,
15869 N_Generic_Package_Declaration)
15874 -- If we have a compilation unit, then record the ident value,
15875 -- checking for improper duplication.
15877 if Nkind (GP) = N_Compilation_Unit then
15878 CS := Ident_String (Current_Sem_Unit);
15880 if Present (CS) then
15882 -- If we have multiple instances, concatenate them, but
15883 -- not in ASIS, where we want the original tree.
15885 if not ASIS_Mode then
15886 Start_String (Strval (CS));
15887 Store_String_Char (' ');
15888 Store_String_Chars (Strval (Str));
15889 Set_Strval (CS, End_String);
15893 Set_Ident_String (Current_Sem_Unit, Str);
15896 -- For subunits, we just ignore the Ident, since in GNAT these
15897 -- are not separate object files, and hence not separate units
15898 -- in the unit table.
15900 elsif Nkind (GP) = N_Subunit then
15906 -------------------
15907 -- Ignore_Pragma --
15908 -------------------
15910 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15912 -- Entirely handled in the parser, nothing to do here
15914 when Pragma_Ignore_Pragma =>
15917 ----------------------------
15918 -- Implementation_Defined --
15919 ----------------------------
15921 -- pragma Implementation_Defined (LOCAL_NAME);
15923 -- Marks previously declared entity as implementation defined. For
15924 -- an overloaded entity, applies to the most recent homonym.
15926 -- pragma Implementation_Defined;
15928 -- The form with no arguments appears anywhere within a scope, most
15929 -- typically a package spec, and indicates that all entities that are
15930 -- defined within the package spec are Implementation_Defined.
15932 when Pragma_Implementation_Defined => Implementation_Defined : declare
15937 Check_No_Identifiers;
15939 -- Form with no arguments
15941 if Arg_Count = 0 then
15942 Set_Is_Implementation_Defined (Current_Scope);
15944 -- Form with one argument
15947 Check_Arg_Count (1);
15948 Check_Arg_Is_Local_Name (Arg1);
15949 Ent := Entity (Get_Pragma_Arg (Arg1));
15950 Set_Is_Implementation_Defined (Ent);
15952 end Implementation_Defined;
15958 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15960 -- IMPLEMENTATION_KIND ::=
15961 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15963 -- "By_Any" and "Optional" are treated as synonyms in order to
15964 -- support Ada 2012 aspect Synchronization.
15966 when Pragma_Implemented => Implemented : declare
15967 Proc_Id : Entity_Id;
15972 Check_Arg_Count (2);
15973 Check_No_Identifiers;
15974 Check_Arg_Is_Identifier (Arg1);
15975 Check_Arg_Is_Local_Name (Arg1);
15976 Check_Arg_Is_One_Of (Arg2,
15979 Name_By_Protected_Procedure,
15982 -- Extract the name of the local procedure
15984 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15986 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15987 -- primitive procedure of a synchronized tagged type.
15989 if Ekind (Proc_Id) = E_Procedure
15990 and then Is_Primitive (Proc_Id)
15991 and then Present (First_Formal (Proc_Id))
15993 Typ := Etype (First_Formal (Proc_Id));
15995 if Is_Tagged_Type (Typ)
15998 -- Check for a protected, a synchronized or a task interface
16000 ((Is_Interface (Typ)
16001 and then Is_Synchronized_Interface (Typ))
16003 -- Check for a protected type or a task type that implements
16007 (Is_Concurrent_Record_Type (Typ)
16008 and then Present (Interfaces (Typ)))
16010 -- In analysis-only mode, examine original protected type
16013 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
16014 and then Present (Interface_List (Parent (Typ))))
16016 -- Check for a private record extension with keyword
16020 (Ekind_In (Typ, E_Record_Type_With_Private,
16021 E_Record_Subtype_With_Private)
16022 and then Synchronized_Present (Parent (Typ))))
16027 ("controlling formal must be of synchronized tagged type",
16032 -- Procedures declared inside a protected type must be accepted
16034 elsif Ekind (Proc_Id) = E_Procedure
16035 and then Is_Protected_Type (Scope (Proc_Id))
16039 -- The first argument is not a primitive procedure
16043 ("pragma % must be applied to a primitive procedure", Arg1);
16047 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16048 -- By_Protected_Procedure to the primitive procedure of a task
16051 if Chars (Arg2) = Name_By_Protected_Procedure
16052 and then Is_Interface (Typ)
16053 and then Is_Task_Interface (Typ)
16056 ("implementation kind By_Protected_Procedure cannot be "
16057 & "applied to a task interface primitive", Arg2);
16061 Record_Rep_Item (Proc_Id, N);
16064 ----------------------
16065 -- Implicit_Packing --
16066 ----------------------
16068 -- pragma Implicit_Packing;
16070 when Pragma_Implicit_Packing =>
16072 Check_Arg_Count (0);
16073 Implicit_Packing := True;
16080 -- [Convention =>] convention_IDENTIFIER,
16081 -- [Entity =>] LOCAL_NAME
16082 -- [, [External_Name =>] static_string_EXPRESSION ]
16083 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16085 when Pragma_Import =>
16086 Check_Ada_83_Warning;
16090 Name_External_Name,
16093 Check_At_Least_N_Arguments (2);
16094 Check_At_Most_N_Arguments (4);
16095 Process_Import_Or_Interface;
16097 ---------------------
16098 -- Import_Function --
16099 ---------------------
16101 -- pragma Import_Function (
16102 -- [Internal =>] LOCAL_NAME,
16103 -- [, [External =>] EXTERNAL_SYMBOL]
16104 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16105 -- [, [Result_Type =>] SUBTYPE_MARK]
16106 -- [, [Mechanism =>] MECHANISM]
16107 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16109 -- EXTERNAL_SYMBOL ::=
16111 -- | static_string_EXPRESSION
16113 -- PARAMETER_TYPES ::=
16115 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16117 -- TYPE_DESIGNATOR ::=
16119 -- | subtype_Name ' Access
16123 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16125 -- MECHANISM_ASSOCIATION ::=
16126 -- [formal_parameter_NAME =>] MECHANISM_NAME
16128 -- MECHANISM_NAME ::=
16132 when Pragma_Import_Function => Import_Function : declare
16133 Args : Args_List (1 .. 6);
16134 Names : constant Name_List (1 .. 6) := (
16137 Name_Parameter_Types,
16140 Name_Result_Mechanism);
16142 Internal : Node_Id renames Args (1);
16143 External : Node_Id renames Args (2);
16144 Parameter_Types : Node_Id renames Args (3);
16145 Result_Type : Node_Id renames Args (4);
16146 Mechanism : Node_Id renames Args (5);
16147 Result_Mechanism : Node_Id renames Args (6);
16151 Gather_Associations (Names, Args);
16152 Process_Extended_Import_Export_Subprogram_Pragma (
16153 Arg_Internal => Internal,
16154 Arg_External => External,
16155 Arg_Parameter_Types => Parameter_Types,
16156 Arg_Result_Type => Result_Type,
16157 Arg_Mechanism => Mechanism,
16158 Arg_Result_Mechanism => Result_Mechanism);
16159 end Import_Function;
16161 -------------------
16162 -- Import_Object --
16163 -------------------
16165 -- pragma Import_Object (
16166 -- [Internal =>] LOCAL_NAME
16167 -- [, [External =>] EXTERNAL_SYMBOL]
16168 -- [, [Size =>] EXTERNAL_SYMBOL]);
16170 -- EXTERNAL_SYMBOL ::=
16172 -- | static_string_EXPRESSION
16174 when Pragma_Import_Object => Import_Object : declare
16175 Args : Args_List (1 .. 3);
16176 Names : constant Name_List (1 .. 3) := (
16181 Internal : Node_Id renames Args (1);
16182 External : Node_Id renames Args (2);
16183 Size : Node_Id renames Args (3);
16187 Gather_Associations (Names, Args);
16188 Process_Extended_Import_Export_Object_Pragma (
16189 Arg_Internal => Internal,
16190 Arg_External => External,
16194 ----------------------
16195 -- Import_Procedure --
16196 ----------------------
16198 -- pragma Import_Procedure (
16199 -- [Internal =>] LOCAL_NAME
16200 -- [, [External =>] EXTERNAL_SYMBOL]
16201 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16202 -- [, [Mechanism =>] MECHANISM]);
16204 -- EXTERNAL_SYMBOL ::=
16206 -- | static_string_EXPRESSION
16208 -- PARAMETER_TYPES ::=
16210 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16212 -- TYPE_DESIGNATOR ::=
16214 -- | subtype_Name ' Access
16218 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16220 -- MECHANISM_ASSOCIATION ::=
16221 -- [formal_parameter_NAME =>] MECHANISM_NAME
16223 -- MECHANISM_NAME ::=
16227 when Pragma_Import_Procedure => Import_Procedure : declare
16228 Args : Args_List (1 .. 4);
16229 Names : constant Name_List (1 .. 4) := (
16232 Name_Parameter_Types,
16235 Internal : Node_Id renames Args (1);
16236 External : Node_Id renames Args (2);
16237 Parameter_Types : Node_Id renames Args (3);
16238 Mechanism : Node_Id renames Args (4);
16242 Gather_Associations (Names, Args);
16243 Process_Extended_Import_Export_Subprogram_Pragma (
16244 Arg_Internal => Internal,
16245 Arg_External => External,
16246 Arg_Parameter_Types => Parameter_Types,
16247 Arg_Mechanism => Mechanism);
16248 end Import_Procedure;
16250 -----------------------------
16251 -- Import_Valued_Procedure --
16252 -----------------------------
16254 -- pragma Import_Valued_Procedure (
16255 -- [Internal =>] LOCAL_NAME
16256 -- [, [External =>] EXTERNAL_SYMBOL]
16257 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16258 -- [, [Mechanism =>] MECHANISM]);
16260 -- EXTERNAL_SYMBOL ::=
16262 -- | static_string_EXPRESSION
16264 -- PARAMETER_TYPES ::=
16266 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16268 -- TYPE_DESIGNATOR ::=
16270 -- | subtype_Name ' Access
16274 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16276 -- MECHANISM_ASSOCIATION ::=
16277 -- [formal_parameter_NAME =>] MECHANISM_NAME
16279 -- MECHANISM_NAME ::=
16283 when Pragma_Import_Valued_Procedure =>
16284 Import_Valued_Procedure : declare
16285 Args : Args_List (1 .. 4);
16286 Names : constant Name_List (1 .. 4) := (
16289 Name_Parameter_Types,
16292 Internal : Node_Id renames Args (1);
16293 External : Node_Id renames Args (2);
16294 Parameter_Types : Node_Id renames Args (3);
16295 Mechanism : Node_Id renames Args (4);
16299 Gather_Associations (Names, Args);
16300 Process_Extended_Import_Export_Subprogram_Pragma (
16301 Arg_Internal => Internal,
16302 Arg_External => External,
16303 Arg_Parameter_Types => Parameter_Types,
16304 Arg_Mechanism => Mechanism);
16305 end Import_Valued_Procedure;
16311 -- pragma Independent (LOCAL_NAME);
16313 when Pragma_Independent =>
16314 Process_Atomic_Independent_Shared_Volatile;
16316 ----------------------------
16317 -- Independent_Components --
16318 ----------------------------
16320 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16322 when Pragma_Independent_Components => Independent_Components : declare
16330 Check_Ada_83_Warning;
16332 Check_No_Identifiers;
16333 Check_Arg_Count (1);
16334 Check_Arg_Is_Local_Name (Arg1);
16335 E_Id := Get_Pragma_Arg (Arg1);
16337 if Etype (E_Id) = Any_Type then
16341 E := Entity (E_Id);
16343 -- A pragma that applies to a Ghost entity becomes Ghost for the
16344 -- purposes of legality checks and removal of ignored Ghost code.
16346 Mark_Ghost_Pragma (N, E);
16348 -- Check duplicate before we chain ourselves
16350 Check_Duplicate_Pragma (E);
16352 -- Check appropriate entity
16354 if Rep_Item_Too_Early (E, N)
16356 Rep_Item_Too_Late (E, N)
16361 D := Declaration_Node (E);
16364 -- The flag is set on the base type, or on the object
16366 if K = N_Full_Type_Declaration
16367 and then (Is_Array_Type (E) or else Is_Record_Type (E))
16369 Set_Has_Independent_Components (Base_Type (E));
16370 Record_Independence_Check (N, Base_Type (E));
16372 -- For record type, set all components independent
16374 if Is_Record_Type (E) then
16375 C := First_Component (E);
16376 while Present (C) loop
16377 Set_Is_Independent (C);
16378 Next_Component (C);
16382 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16383 and then Nkind (D) = N_Object_Declaration
16384 and then Nkind (Object_Definition (D)) =
16385 N_Constrained_Array_Definition
16387 Set_Has_Independent_Components (E);
16388 Record_Independence_Check (N, E);
16391 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16393 end Independent_Components;
16395 -----------------------
16396 -- Initial_Condition --
16397 -----------------------
16399 -- pragma Initial_Condition (boolean_EXPRESSION);
16401 -- Characteristics:
16403 -- * Analysis - The annotation undergoes initial checks to verify
16404 -- the legal placement and context. Secondary checks preanalyze the
16407 -- Analyze_Initial_Condition_In_Decl_Part
16409 -- * Expansion - The annotation is expanded during the expansion of
16410 -- the package body whose declaration is subject to the annotation
16413 -- Expand_Pragma_Initial_Condition
16415 -- * Template - The annotation utilizes the generic template of the
16416 -- related package declaration.
16418 -- * Globals - Capture of global references must occur after full
16421 -- * Instance - The annotation is instantiated automatically when
16422 -- the related generic package is instantiated.
16424 when Pragma_Initial_Condition => Initial_Condition : declare
16425 Pack_Decl : Node_Id;
16426 Pack_Id : Entity_Id;
16430 Check_No_Identifiers;
16431 Check_Arg_Count (1);
16433 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16435 -- Ensure the proper placement of the pragma. Initial_Condition
16436 -- must be associated with a package declaration.
16438 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16439 N_Package_Declaration)
16443 -- Otherwise the pragma is associated with an illegal context
16450 Pack_Id := Defining_Entity (Pack_Decl);
16452 -- A pragma that applies to a Ghost entity becomes Ghost for the
16453 -- purposes of legality checks and removal of ignored Ghost code.
16455 Mark_Ghost_Pragma (N, Pack_Id);
16457 -- Chain the pragma on the contract for further processing by
16458 -- Analyze_Initial_Condition_In_Decl_Part.
16460 Add_Contract_Item (N, Pack_Id);
16462 -- The legality checks of pragmas Abstract_State, Initializes, and
16463 -- Initial_Condition are affected by the SPARK mode in effect. In
16464 -- addition, these three pragmas are subject to an inherent order:
16466 -- 1) Abstract_State
16468 -- 3) Initial_Condition
16470 -- Analyze all these pragmas in the order outlined above
16472 Analyze_If_Present (Pragma_SPARK_Mode);
16473 Analyze_If_Present (Pragma_Abstract_State);
16474 Analyze_If_Present (Pragma_Initializes);
16475 end Initial_Condition;
16477 ------------------------
16478 -- Initialize_Scalars --
16479 ------------------------
16481 -- pragma Initialize_Scalars;
16483 when Pragma_Initialize_Scalars =>
16485 Check_Arg_Count (0);
16486 Check_Valid_Configuration_Pragma;
16487 Check_Restriction (No_Initialize_Scalars, N);
16489 -- Initialize_Scalars creates false positives in CodePeer, and
16490 -- incorrect negative results in GNATprove mode, so ignore this
16491 -- pragma in these modes.
16493 if not Restriction_Active (No_Initialize_Scalars)
16494 and then not (CodePeer_Mode or GNATprove_Mode)
16496 Init_Or_Norm_Scalars := True;
16497 Initialize_Scalars := True;
16504 -- pragma Initializes (INITIALIZATION_LIST);
16506 -- INITIALIZATION_LIST ::=
16508 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16510 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16515 -- | (INPUT {, INPUT})
16519 -- Characteristics:
16521 -- * Analysis - The annotation undergoes initial checks to verify
16522 -- the legal placement and context. Secondary checks preanalyze the
16525 -- Analyze_Initializes_In_Decl_Part
16527 -- * Expansion - None.
16529 -- * Template - The annotation utilizes the generic template of the
16530 -- related package declaration.
16532 -- * Globals - Capture of global references must occur after full
16535 -- * Instance - The annotation is instantiated automatically when
16536 -- the related generic package is instantiated.
16538 when Pragma_Initializes => Initializes : declare
16539 Pack_Decl : Node_Id;
16540 Pack_Id : Entity_Id;
16544 Check_No_Identifiers;
16545 Check_Arg_Count (1);
16547 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16549 -- Ensure the proper placement of the pragma. Initializes must be
16550 -- associated with a package declaration.
16552 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16553 N_Package_Declaration)
16557 -- Otherwise the pragma is associated with an illegal construc
16564 Pack_Id := Defining_Entity (Pack_Decl);
16566 -- A pragma that applies to a Ghost entity becomes Ghost for the
16567 -- purposes of legality checks and removal of ignored Ghost code.
16569 Mark_Ghost_Pragma (N, Pack_Id);
16570 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16572 -- Chain the pragma on the contract for further processing by
16573 -- Analyze_Initializes_In_Decl_Part.
16575 Add_Contract_Item (N, Pack_Id);
16577 -- The legality checks of pragmas Abstract_State, Initializes, and
16578 -- Initial_Condition are affected by the SPARK mode in effect. In
16579 -- addition, these three pragmas are subject to an inherent order:
16581 -- 1) Abstract_State
16583 -- 3) Initial_Condition
16585 -- Analyze all these pragmas in the order outlined above
16587 Analyze_If_Present (Pragma_SPARK_Mode);
16588 Analyze_If_Present (Pragma_Abstract_State);
16589 Analyze_If_Present (Pragma_Initial_Condition);
16596 -- pragma Inline ( NAME {, NAME} );
16598 when Pragma_Inline =>
16600 -- Pragma always active unless in GNATprove mode. It is disabled
16601 -- in GNATprove mode because frontend inlining is applied
16602 -- independently of pragmas Inline and Inline_Always for
16603 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16606 if not GNATprove_Mode then
16608 -- Inline status is Enabled if option -gnatn is specified.
16609 -- However this status determines only the value of the
16610 -- Is_Inlined flag on the subprogram and does not prevent
16611 -- the pragma itself from being recorded for later use,
16612 -- in particular for a later modification of Is_Inlined
16613 -- independently of the -gnatn option.
16615 -- In other words, if -gnatn is specified for a unit, then
16616 -- all Inline pragmas processed for the compilation of this
16617 -- unit, including those in the spec of other units, are
16618 -- activated, so subprograms will be inlined across units.
16620 -- If -gnatn is not specified, no Inline pragma is activated
16621 -- here, which means that subprograms will not be inlined
16622 -- across units. The Is_Inlined flag will nevertheless be
16623 -- set later when bodies are analyzed, so subprograms will
16624 -- be inlined within the unit.
16626 if Inline_Active then
16627 Process_Inline (Enabled);
16629 Process_Inline (Disabled);
16633 -------------------
16634 -- Inline_Always --
16635 -------------------
16637 -- pragma Inline_Always ( NAME {, NAME} );
16639 when Pragma_Inline_Always =>
16642 -- Pragma always active unless in CodePeer mode or GNATprove
16643 -- mode. It is disabled in CodePeer mode because inlining is
16644 -- not helpful, and enabling it caused walk order issues. It
16645 -- is disabled in GNATprove mode because frontend inlining is
16646 -- applied independently of pragmas Inline and Inline_Always for
16647 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16650 if not CodePeer_Mode and not GNATprove_Mode then
16651 Process_Inline (Enabled);
16654 --------------------
16655 -- Inline_Generic --
16656 --------------------
16658 -- pragma Inline_Generic (NAME {, NAME});
16660 when Pragma_Inline_Generic =>
16662 Process_Generic_List;
16664 ----------------------
16665 -- Inspection_Point --
16666 ----------------------
16668 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16670 when Pragma_Inspection_Point => Inspection_Point : declare
16677 if Arg_Count > 0 then
16680 Exp := Get_Pragma_Arg (Arg);
16683 if not Is_Entity_Name (Exp)
16684 or else not Is_Object (Entity (Exp))
16686 Error_Pragma_Arg ("object name required", Arg);
16690 exit when No (Arg);
16693 end Inspection_Point;
16699 -- pragma Interface (
16700 -- [ Convention =>] convention_IDENTIFIER,
16701 -- [ Entity =>] LOCAL_NAME
16702 -- [, [External_Name =>] static_string_EXPRESSION ]
16703 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16705 when Pragma_Interface =>
16710 Name_External_Name,
16712 Check_At_Least_N_Arguments (2);
16713 Check_At_Most_N_Arguments (4);
16714 Process_Import_Or_Interface;
16716 -- In Ada 2005, the permission to use Interface (a reserved word)
16717 -- as a pragma name is considered an obsolescent feature, and this
16718 -- pragma was already obsolescent in Ada 95.
16720 if Ada_Version >= Ada_95 then
16722 (No_Obsolescent_Features, Pragma_Identifier (N));
16724 if Warn_On_Obsolescent_Feature then
16726 ("pragma Interface is an obsolescent feature?j?", N);
16728 ("|use pragma Import instead?j?", N);
16732 --------------------
16733 -- Interface_Name --
16734 --------------------
16736 -- pragma Interface_Name (
16737 -- [ Entity =>] LOCAL_NAME
16738 -- [,[External_Name =>] static_string_EXPRESSION ]
16739 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16741 when Pragma_Interface_Name => Interface_Name : declare
16743 Def_Id : Entity_Id;
16744 Hom_Id : Entity_Id;
16750 ((Name_Entity, Name_External_Name, Name_Link_Name));
16751 Check_At_Least_N_Arguments (2);
16752 Check_At_Most_N_Arguments (3);
16753 Id := Get_Pragma_Arg (Arg1);
16756 -- This is obsolete from Ada 95 on, but it is an implementation
16757 -- defined pragma, so we do not consider that it violates the
16758 -- restriction (No_Obsolescent_Features).
16760 if Ada_Version >= Ada_95 then
16761 if Warn_On_Obsolescent_Feature then
16763 ("pragma Interface_Name is an obsolescent feature?j?", N);
16765 ("|use pragma Import instead?j?", N);
16769 if not Is_Entity_Name (Id) then
16771 ("first argument for pragma% must be entity name", Arg1);
16772 elsif Etype (Id) = Any_Type then
16775 Def_Id := Entity (Id);
16778 -- Special DEC-compatible processing for the object case, forces
16779 -- object to be imported.
16781 if Ekind (Def_Id) = E_Variable then
16782 Kill_Size_Check_Code (Def_Id);
16783 Note_Possible_Modification (Id, Sure => False);
16785 -- Initialization is not allowed for imported variable
16787 if Present (Expression (Parent (Def_Id)))
16788 and then Comes_From_Source (Expression (Parent (Def_Id)))
16790 Error_Msg_Sloc := Sloc (Def_Id);
16792 ("no initialization allowed for declaration of& #",
16796 -- For compatibility, support VADS usage of providing both
16797 -- pragmas Interface and Interface_Name to obtain the effect
16798 -- of a single Import pragma.
16800 if Is_Imported (Def_Id)
16801 and then Present (First_Rep_Item (Def_Id))
16802 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16803 and then Pragma_Name (First_Rep_Item (Def_Id)) =
16808 Set_Imported (Def_Id);
16811 Set_Is_Public (Def_Id);
16812 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16815 -- Otherwise must be subprogram
16817 elsif not Is_Subprogram (Def_Id) then
16819 ("argument of pragma% is not subprogram", Arg1);
16822 Check_At_Most_N_Arguments (3);
16826 -- Loop through homonyms
16829 Def_Id := Get_Base_Subprogram (Hom_Id);
16831 if Is_Imported (Def_Id) then
16832 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16836 exit when From_Aspect_Specification (N);
16837 Hom_Id := Homonym (Hom_Id);
16839 exit when No (Hom_Id)
16840 or else Scope (Hom_Id) /= Current_Scope;
16845 ("argument of pragma% is not imported subprogram",
16849 end Interface_Name;
16851 -----------------------
16852 -- Interrupt_Handler --
16853 -----------------------
16855 -- pragma Interrupt_Handler (handler_NAME);
16857 when Pragma_Interrupt_Handler =>
16858 Check_Ada_83_Warning;
16859 Check_Arg_Count (1);
16860 Check_No_Identifiers;
16862 if No_Run_Time_Mode then
16863 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16865 Check_Interrupt_Or_Attach_Handler;
16866 Process_Interrupt_Or_Attach_Handler;
16869 ------------------------
16870 -- Interrupt_Priority --
16871 ------------------------
16873 -- pragma Interrupt_Priority [(EXPRESSION)];
16875 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16876 P : constant Node_Id := Parent (N);
16881 Check_Ada_83_Warning;
16883 if Arg_Count /= 0 then
16884 Arg := Get_Pragma_Arg (Arg1);
16885 Check_Arg_Count (1);
16886 Check_No_Identifiers;
16888 -- The expression must be analyzed in the special manner
16889 -- described in "Handling of Default and Per-Object
16890 -- Expressions" in sem.ads.
16892 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16895 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16900 Ent := Defining_Identifier (Parent (P));
16902 -- Check duplicate pragma before we chain the pragma in the Rep
16903 -- Item chain of Ent.
16905 Check_Duplicate_Pragma (Ent);
16906 Record_Rep_Item (Ent, N);
16908 -- Check the No_Task_At_Interrupt_Priority restriction
16910 if Nkind (P) = N_Task_Definition then
16911 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16914 end Interrupt_Priority;
16916 ---------------------
16917 -- Interrupt_State --
16918 ---------------------
16920 -- pragma Interrupt_State (
16921 -- [Name =>] INTERRUPT_ID,
16922 -- [State =>] INTERRUPT_STATE);
16924 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16925 -- INTERRUPT_STATE => System | Runtime | User
16927 -- Note: if the interrupt id is given as an identifier, then it must
16928 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16929 -- given as a static integer expression which must be in the range of
16930 -- Ada.Interrupts.Interrupt_ID.
16932 when Pragma_Interrupt_State => Interrupt_State : declare
16933 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16934 -- This is the entity Ada.Interrupts.Interrupt_ID;
16936 State_Type : Character;
16937 -- Set to 's'/'r'/'u' for System/Runtime/User
16940 -- Index to entry in Interrupt_States table
16943 -- Value of interrupt
16945 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16946 -- The first argument to the pragma
16948 Int_Ent : Entity_Id;
16949 -- Interrupt entity in Ada.Interrupts.Names
16953 Check_Arg_Order ((Name_Name, Name_State));
16954 Check_Arg_Count (2);
16956 Check_Optional_Identifier (Arg1, Name_Name);
16957 Check_Optional_Identifier (Arg2, Name_State);
16958 Check_Arg_Is_Identifier (Arg2);
16960 -- First argument is identifier
16962 if Nkind (Arg1X) = N_Identifier then
16964 -- Search list of names in Ada.Interrupts.Names
16966 Int_Ent := First_Entity (RTE (RE_Names));
16968 if No (Int_Ent) then
16969 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16971 elsif Chars (Int_Ent) = Chars (Arg1X) then
16972 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16976 Next_Entity (Int_Ent);
16979 -- First argument is not an identifier, so it must be a static
16980 -- expression of type Ada.Interrupts.Interrupt_ID.
16983 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16984 Int_Val := Expr_Value (Arg1X);
16986 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16988 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16991 ("value not in range of type "
16992 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16998 case Chars (Get_Pragma_Arg (Arg2)) is
16999 when Name_Runtime => State_Type := 'r';
17000 when Name_System => State_Type := 's';
17001 when Name_User => State_Type := 'u';
17004 Error_Pragma_Arg ("invalid interrupt state", Arg2);
17007 -- Check if entry is already stored
17009 IST_Num := Interrupt_States.First;
17011 -- If entry not found, add it
17013 if IST_Num > Interrupt_States.Last then
17014 Interrupt_States.Append
17015 ((Interrupt_Number => UI_To_Int (Int_Val),
17016 Interrupt_State => State_Type,
17017 Pragma_Loc => Loc));
17020 -- Case of entry for the same entry
17022 elsif Int_Val = Interrupt_States.Table (IST_Num).
17025 -- If state matches, done, no need to make redundant entry
17028 State_Type = Interrupt_States.Table (IST_Num).
17031 -- Otherwise if state does not match, error
17034 Interrupt_States.Table (IST_Num).Pragma_Loc;
17036 ("state conflicts with that given #", Arg2);
17040 IST_Num := IST_Num + 1;
17042 end Interrupt_State;
17048 -- pragma Invariant
17049 -- ([Entity =>] type_LOCAL_NAME,
17050 -- [Check =>] EXPRESSION
17051 -- [,[Message =>] String_Expression]);
17053 when Pragma_Invariant => Invariant : declare
17060 Check_At_Least_N_Arguments (2);
17061 Check_At_Most_N_Arguments (3);
17062 Check_Optional_Identifier (Arg1, Name_Entity);
17063 Check_Optional_Identifier (Arg2, Name_Check);
17065 if Arg_Count = 3 then
17066 Check_Optional_Identifier (Arg3, Name_Message);
17067 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
17070 Check_Arg_Is_Local_Name (Arg1);
17072 Typ_Arg := Get_Pragma_Arg (Arg1);
17073 Find_Type (Typ_Arg);
17074 Typ := Entity (Typ_Arg);
17076 -- Nothing to do of the related type is erroneous in some way
17078 if Typ = Any_Type then
17081 -- AI12-0041: Invariants are allowed in interface types
17083 elsif Is_Interface (Typ) then
17086 -- An invariant must apply to a private type, or appear in the
17087 -- private part of a package spec and apply to a completion.
17088 -- a class-wide invariant can only appear on a private declaration
17089 -- or private extension, not a completion.
17091 -- A [class-wide] invariant may be associated a [limited] private
17092 -- type or a private extension.
17094 elsif Ekind_In (Typ, E_Limited_Private_Type,
17096 E_Record_Type_With_Private)
17100 -- A non-class-wide invariant may be associated with the full view
17101 -- of a [limited] private type or a private extension.
17103 elsif Has_Private_Declaration (Typ)
17104 and then not Class_Present (N)
17108 -- A class-wide invariant may appear on the partial view only
17110 elsif Class_Present (N) then
17112 ("pragma % only allowed for private type", Arg1);
17115 -- A regular invariant may appear on both views
17119 ("pragma % only allowed for private type or corresponding "
17120 & "full view", Arg1);
17124 -- An invariant associated with an abstract type (this includes
17125 -- interfaces) must be class-wide.
17127 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
17129 ("pragma % not allowed for abstract type", Arg1);
17133 -- A pragma that applies to a Ghost entity becomes Ghost for the
17134 -- purposes of legality checks and removal of ignored Ghost code.
17136 Mark_Ghost_Pragma (N, Typ);
17138 -- The pragma defines a type-specific invariant, the type is said
17139 -- to have invariants of its "own".
17141 Set_Has_Own_Invariants (Typ);
17143 -- If the invariant is class-wide, then it can be inherited by
17144 -- derived or interface implementing types. The type is said to
17145 -- have "inheritable" invariants.
17147 if Class_Present (N) then
17148 Set_Has_Inheritable_Invariants (Typ);
17151 -- Chain the pragma on to the rep item chain, for processing when
17152 -- the type is frozen.
17154 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
17156 -- Create the declaration of the invariant procedure that will
17157 -- verify the invariant at run time. Interfaces are treated as the
17158 -- partial view of a private type in order to achieve uniformity
17159 -- with the general case. As a result, an interface receives only
17160 -- a "partial" invariant procedure, which is never called.
17162 Build_Invariant_Procedure_Declaration
17164 Partial_Invariant => Is_Interface (Typ));
17171 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17173 when Pragma_Keep_Names => Keep_Names : declare
17178 Check_Arg_Count (1);
17179 Check_Optional_Identifier (Arg1, Name_On);
17180 Check_Arg_Is_Local_Name (Arg1);
17182 Arg := Get_Pragma_Arg (Arg1);
17185 if Etype (Arg) = Any_Type then
17189 if not Is_Entity_Name (Arg)
17190 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
17193 ("pragma% requires a local enumeration type", Arg1);
17196 Set_Discard_Names (Entity (Arg), False);
17203 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17205 when Pragma_License =>
17208 -- Do not analyze pragma any further in CodePeer mode, to avoid
17209 -- extraneous errors in this implementation-dependent pragma,
17210 -- which has a different profile on other compilers.
17212 if CodePeer_Mode then
17216 Check_Arg_Count (1);
17217 Check_No_Identifiers;
17218 Check_Valid_Configuration_Pragma;
17219 Check_Arg_Is_Identifier (Arg1);
17222 Sind : constant Source_File_Index :=
17223 Source_Index (Current_Sem_Unit);
17226 case Chars (Get_Pragma_Arg (Arg1)) is
17228 Set_License (Sind, GPL);
17230 when Name_Modified_GPL =>
17231 Set_License (Sind, Modified_GPL);
17233 when Name_Restricted =>
17234 Set_License (Sind, Restricted);
17236 when Name_Unrestricted =>
17237 Set_License (Sind, Unrestricted);
17240 Error_Pragma_Arg ("invalid license name", Arg1);
17248 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17250 when Pragma_Link_With => Link_With : declare
17256 if Operating_Mode = Generate_Code
17257 and then In_Extended_Main_Source_Unit (N)
17259 Check_At_Least_N_Arguments (1);
17260 Check_No_Identifiers;
17261 Check_Is_In_Decl_Part_Or_Package_Spec;
17262 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17266 while Present (Arg) loop
17267 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17269 -- Store argument, converting sequences of spaces to a
17270 -- single null character (this is one of the differences
17271 -- in processing between Link_With and Linker_Options).
17273 Arg_Store : declare
17274 C : constant Char_Code := Get_Char_Code (' ');
17275 S : constant String_Id :=
17276 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17277 L : constant Nat := String_Length (S);
17280 procedure Skip_Spaces;
17281 -- Advance F past any spaces
17287 procedure Skip_Spaces is
17289 while F <= L and then Get_String_Char (S, F) = C loop
17294 -- Start of processing for Arg_Store
17297 Skip_Spaces; -- skip leading spaces
17299 -- Loop through characters, changing any embedded
17300 -- sequence of spaces to a single null character (this
17301 -- is how Link_With/Linker_Options differ)
17304 if Get_String_Char (S, F) = C then
17307 Store_String_Char (ASCII.NUL);
17310 Store_String_Char (Get_String_Char (S, F));
17318 if Present (Arg) then
17319 Store_String_Char (ASCII.NUL);
17323 Store_Linker_Option_String (End_String);
17331 -- pragma Linker_Alias (
17332 -- [Entity =>] LOCAL_NAME
17333 -- [Target =>] static_string_EXPRESSION);
17335 when Pragma_Linker_Alias =>
17337 Check_Arg_Order ((Name_Entity, Name_Target));
17338 Check_Arg_Count (2);
17339 Check_Optional_Identifier (Arg1, Name_Entity);
17340 Check_Optional_Identifier (Arg2, Name_Target);
17341 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17342 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17344 -- The only processing required is to link this item on to the
17345 -- list of rep items for the given entity. This is accomplished
17346 -- by the call to Rep_Item_Too_Late (when no error is detected
17347 -- and False is returned).
17349 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17352 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17355 ------------------------
17356 -- Linker_Constructor --
17357 ------------------------
17359 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17361 -- Code is shared with Linker_Destructor
17363 -----------------------
17364 -- Linker_Destructor --
17365 -----------------------
17367 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17369 when Pragma_Linker_Constructor
17370 | Pragma_Linker_Destructor
17372 Linker_Constructor : declare
17378 Check_Arg_Count (1);
17379 Check_No_Identifiers;
17380 Check_Arg_Is_Local_Name (Arg1);
17381 Arg1_X := Get_Pragma_Arg (Arg1);
17383 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17385 if not Is_Library_Level_Entity (Proc) then
17387 ("argument for pragma% must be library level entity", Arg1);
17390 -- The only processing required is to link this item on to the
17391 -- list of rep items for the given entity. This is accomplished
17392 -- by the call to Rep_Item_Too_Late (when no error is detected
17393 -- and False is returned).
17395 if Rep_Item_Too_Late (Proc, N) then
17398 Set_Has_Gigi_Rep_Item (Proc);
17400 end Linker_Constructor;
17402 --------------------
17403 -- Linker_Options --
17404 --------------------
17406 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17408 when Pragma_Linker_Options => Linker_Options : declare
17412 Check_Ada_83_Warning;
17413 Check_No_Identifiers;
17414 Check_Arg_Count (1);
17415 Check_Is_In_Decl_Part_Or_Package_Spec;
17416 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17417 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17420 while Present (Arg) loop
17421 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17422 Store_String_Char (ASCII.NUL);
17424 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17428 if Operating_Mode = Generate_Code
17429 and then In_Extended_Main_Source_Unit (N)
17431 Store_Linker_Option_String (End_String);
17433 end Linker_Options;
17435 --------------------
17436 -- Linker_Section --
17437 --------------------
17439 -- pragma Linker_Section (
17440 -- [Entity =>] LOCAL_NAME
17441 -- [Section =>] static_string_EXPRESSION);
17443 when Pragma_Linker_Section => Linker_Section : declare
17448 Ghost_Error_Posted : Boolean := False;
17449 -- Flag set when an error concerning the illegal mix of Ghost and
17450 -- non-Ghost subprograms is emitted.
17452 Ghost_Id : Entity_Id := Empty;
17453 -- The entity of the first Ghost subprogram encountered while
17454 -- processing the arguments of the pragma.
17458 Check_Arg_Order ((Name_Entity, Name_Section));
17459 Check_Arg_Count (2);
17460 Check_Optional_Identifier (Arg1, Name_Entity);
17461 Check_Optional_Identifier (Arg2, Name_Section);
17462 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17463 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17465 -- Check kind of entity
17467 Arg := Get_Pragma_Arg (Arg1);
17468 Ent := Entity (Arg);
17470 case Ekind (Ent) is
17472 -- Objects (constants and variables) and types. For these cases
17473 -- all we need to do is to set the Linker_Section_pragma field,
17474 -- checking that we do not have a duplicate.
17480 LPE := Linker_Section_Pragma (Ent);
17482 if Present (LPE) then
17483 Error_Msg_Sloc := Sloc (LPE);
17485 ("Linker_Section already specified for &#", Arg1, Ent);
17488 Set_Linker_Section_Pragma (Ent, N);
17490 -- A pragma that applies to a Ghost entity becomes Ghost for
17491 -- the purposes of legality checks and removal of ignored
17494 Mark_Ghost_Pragma (N, Ent);
17498 when Subprogram_Kind =>
17500 -- Aspect case, entity already set
17502 if From_Aspect_Specification (N) then
17503 Set_Linker_Section_Pragma
17504 (Entity (Corresponding_Aspect (N)), N);
17506 -- Pragma case, we must climb the homonym chain, but skip
17507 -- any for which the linker section is already set.
17511 if No (Linker_Section_Pragma (Ent)) then
17512 Set_Linker_Section_Pragma (Ent, N);
17514 -- A pragma that applies to a Ghost entity becomes
17515 -- Ghost for the purposes of legality checks and
17516 -- removal of ignored Ghost code.
17518 Mark_Ghost_Pragma (N, Ent);
17520 -- Capture the entity of the first Ghost subprogram
17521 -- being processed for error detection purposes.
17523 if Is_Ghost_Entity (Ent) then
17524 if No (Ghost_Id) then
17528 -- Otherwise the subprogram is non-Ghost. It is
17529 -- illegal to mix references to Ghost and non-Ghost
17530 -- entities (SPARK RM 6.9).
17532 elsif Present (Ghost_Id)
17533 and then not Ghost_Error_Posted
17535 Ghost_Error_Posted := True;
17537 Error_Msg_Name_1 := Pname;
17539 ("pragma % cannot mention ghost and "
17540 & "non-ghost subprograms", N);
17542 Error_Msg_Sloc := Sloc (Ghost_Id);
17544 ("\& # declared as ghost", N, Ghost_Id);
17546 Error_Msg_Sloc := Sloc (Ent);
17548 ("\& # declared as non-ghost", N, Ent);
17552 Ent := Homonym (Ent);
17554 or else Scope (Ent) /= Current_Scope;
17558 -- All other cases are illegal
17562 ("pragma% applies only to objects, subprograms, and types",
17565 end Linker_Section;
17571 -- pragma List (On | Off)
17573 -- There is nothing to do here, since we did all the processing for
17574 -- this pragma in Par.Prag (so that it works properly even in syntax
17577 when Pragma_List =>
17584 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17586 when Pragma_Lock_Free => Lock_Free : declare
17587 P : constant Node_Id := Parent (N);
17593 Check_No_Identifiers;
17594 Check_At_Most_N_Arguments (1);
17596 -- Protected definition case
17598 if Nkind (P) = N_Protected_Definition then
17599 Ent := Defining_Identifier (Parent (P));
17603 if Arg_Count = 1 then
17604 Arg := Get_Pragma_Arg (Arg1);
17605 Val := Is_True (Static_Boolean (Arg));
17607 -- No arguments (expression is considered to be True)
17613 -- Check duplicate pragma before we chain the pragma in the Rep
17614 -- Item chain of Ent.
17616 Check_Duplicate_Pragma (Ent);
17617 Record_Rep_Item (Ent, N);
17618 Set_Uses_Lock_Free (Ent, Val);
17620 -- Anything else is incorrect placement
17627 --------------------
17628 -- Locking_Policy --
17629 --------------------
17631 -- pragma Locking_Policy (policy_IDENTIFIER);
17633 when Pragma_Locking_Policy => declare
17634 subtype LP_Range is Name_Id
17635 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17640 Check_Ada_83_Warning;
17641 Check_Arg_Count (1);
17642 Check_No_Identifiers;
17643 Check_Arg_Is_Locking_Policy (Arg1);
17644 Check_Valid_Configuration_Pragma;
17645 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17648 when Name_Ceiling_Locking => LP := 'C';
17649 when Name_Concurrent_Readers_Locking => LP := 'R';
17650 when Name_Inheritance_Locking => LP := 'I';
17653 if Locking_Policy /= ' '
17654 and then Locking_Policy /= LP
17656 Error_Msg_Sloc := Locking_Policy_Sloc;
17657 Error_Pragma ("locking policy incompatible with policy#");
17659 -- Set new policy, but always preserve System_Location since we
17660 -- like the error message with the run time name.
17663 Locking_Policy := LP;
17665 if Locking_Policy_Sloc /= System_Location then
17666 Locking_Policy_Sloc := Loc;
17671 -------------------
17672 -- Loop_Optimize --
17673 -------------------
17675 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17677 -- OPTIMIZATION_HINT ::=
17678 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17680 when Pragma_Loop_Optimize => Loop_Optimize : declare
17685 Check_At_Least_N_Arguments (1);
17686 Check_No_Identifiers;
17688 Hint := First (Pragma_Argument_Associations (N));
17689 while Present (Hint) loop
17690 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17698 Check_Loop_Pragma_Placement;
17705 -- pragma Loop_Variant
17706 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17708 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17710 -- CHANGE_DIRECTION ::= Increases | Decreases
17712 when Pragma_Loop_Variant => Loop_Variant : declare
17717 Check_At_Least_N_Arguments (1);
17718 Check_Loop_Pragma_Placement;
17720 -- Process all increasing / decreasing expressions
17722 Variant := First (Pragma_Argument_Associations (N));
17723 while Present (Variant) loop
17724 if not Nam_In (Chars (Variant), Name_Decreases,
17727 Error_Pragma_Arg ("wrong change modifier", Variant);
17730 Preanalyze_Assert_Expression
17731 (Expression (Variant), Any_Discrete);
17737 -----------------------
17738 -- Machine_Attribute --
17739 -----------------------
17741 -- pragma Machine_Attribute (
17742 -- [Entity =>] LOCAL_NAME,
17743 -- [Attribute_Name =>] static_string_EXPRESSION
17744 -- [, [Info =>] static_EXPRESSION] );
17746 when Pragma_Machine_Attribute => Machine_Attribute : declare
17747 Def_Id : Entity_Id;
17751 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17753 if Arg_Count = 3 then
17754 Check_Optional_Identifier (Arg3, Name_Info);
17755 Check_Arg_Is_OK_Static_Expression (Arg3);
17757 Check_Arg_Count (2);
17760 Check_Optional_Identifier (Arg1, Name_Entity);
17761 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17762 Check_Arg_Is_Local_Name (Arg1);
17763 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17764 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17766 if Is_Access_Type (Def_Id) then
17767 Def_Id := Designated_Type (Def_Id);
17770 if Rep_Item_Too_Early (Def_Id, N) then
17774 Def_Id := Underlying_Type (Def_Id);
17776 -- The only processing required is to link this item on to the
17777 -- list of rep items for the given entity. This is accomplished
17778 -- by the call to Rep_Item_Too_Late (when no error is detected
17779 -- and False is returned).
17781 if Rep_Item_Too_Late (Def_Id, N) then
17784 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17786 end Machine_Attribute;
17793 -- (MAIN_OPTION [, MAIN_OPTION]);
17796 -- [STACK_SIZE =>] static_integer_EXPRESSION
17797 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17798 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17800 when Pragma_Main => Main : declare
17801 Args : Args_List (1 .. 3);
17802 Names : constant Name_List (1 .. 3) := (
17804 Name_Task_Stack_Size_Default,
17805 Name_Time_Slicing_Enabled);
17811 Gather_Associations (Names, Args);
17813 for J in 1 .. 2 loop
17814 if Present (Args (J)) then
17815 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17819 if Present (Args (3)) then
17820 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17824 while Present (Nod) loop
17825 if Nkind (Nod) = N_Pragma
17826 and then Pragma_Name (Nod) = Name_Main
17828 Error_Msg_Name_1 := Pname;
17829 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17840 -- pragma Main_Storage
17841 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17843 -- MAIN_STORAGE_OPTION ::=
17844 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17845 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17847 when Pragma_Main_Storage => Main_Storage : declare
17848 Args : Args_List (1 .. 2);
17849 Names : constant Name_List (1 .. 2) := (
17850 Name_Working_Storage,
17857 Gather_Associations (Names, Args);
17859 for J in 1 .. 2 loop
17860 if Present (Args (J)) then
17861 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17865 Check_In_Main_Program;
17868 while Present (Nod) loop
17869 if Nkind (Nod) = N_Pragma
17870 and then Pragma_Name (Nod) = Name_Main_Storage
17872 Error_Msg_Name_1 := Pname;
17873 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17880 ----------------------
17881 -- Max_Queue_Length --
17882 ----------------------
17884 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17886 when Pragma_Max_Queue_Length => Max_Queue_Length : declare
17888 Entry_Decl : Node_Id;
17889 Entry_Id : Entity_Id;
17894 Check_Arg_Count (1);
17897 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
17899 -- Entry declaration
17901 if Nkind (Entry_Decl) = N_Entry_Declaration then
17903 -- Entry illegally within a task
17905 if Nkind (Parent (N)) = N_Task_Definition then
17906 Error_Pragma ("pragma % cannot apply to task entries");
17910 Entry_Id := Unique_Defining_Entity (Entry_Decl);
17912 -- Otherwise the pragma is associated with an illegal construct
17915 Error_Pragma ("pragma % must apply to a protected entry");
17919 -- Mark the pragma as Ghost if the related subprogram is also
17920 -- Ghost. This also ensures that any expansion performed further
17921 -- below will produce Ghost nodes.
17923 Mark_Ghost_Pragma (N, Entry_Id);
17925 -- Analyze the Integer expression
17927 Arg := Get_Pragma_Arg (Arg1);
17928 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
17930 Val := Expr_Value (Arg);
17934 ("argument for pragma% must be positive", Arg1);
17936 elsif not UI_Is_In_Int_Range (Val) then
17938 ("argument for pragma% out of range of Integer", Arg1);
17942 -- Manually substitute the expression value of the pragma argument
17943 -- if it's not an integer literal because this is not taken care
17944 -- of automatically elsewhere.
17946 if Nkind (Arg) /= N_Integer_Literal then
17947 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
17950 Record_Rep_Item (Entry_Id, N);
17951 end Max_Queue_Length;
17957 -- pragma Memory_Size (NUMERIC_LITERAL)
17959 when Pragma_Memory_Size =>
17962 -- Memory size is simply ignored
17964 Check_No_Identifiers;
17965 Check_Arg_Count (1);
17966 Check_Arg_Is_Integer_Literal (Arg1);
17974 -- The only correct use of this pragma is on its own in a file, in
17975 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17976 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17977 -- check for a file containing nothing but a No_Body pragma). If we
17978 -- attempt to process it during normal semantics processing, it means
17979 -- it was misplaced.
17981 when Pragma_No_Body =>
17985 -----------------------------
17986 -- No_Elaboration_Code_All --
17987 -----------------------------
17989 -- pragma No_Elaboration_Code_All;
17991 when Pragma_No_Elaboration_Code_All =>
17993 Check_Valid_Library_Unit_Pragma;
17995 if Nkind (N) = N_Null_Statement then
17999 -- Must appear for a spec or generic spec
18001 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
18002 N_Generic_Package_Declaration,
18003 N_Generic_Subprogram_Declaration,
18004 N_Package_Declaration,
18005 N_Subprogram_Declaration)
18009 ("pragma% can only occur for package "
18010 & "or subprogram spec"));
18013 -- Set flag in unit table
18015 Set_No_Elab_Code_All (Current_Sem_Unit);
18017 -- Set restriction No_Elaboration_Code if this is the main unit
18019 if Current_Sem_Unit = Main_Unit then
18020 Set_Restriction (No_Elaboration_Code, N);
18023 -- If we are in the main unit or in an extended main source unit,
18024 -- then we also add it to the configuration restrictions so that
18025 -- it will apply to all units in the extended main source.
18027 if Current_Sem_Unit = Main_Unit
18028 or else In_Extended_Main_Source_Unit (N)
18030 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
18033 -- If in main extended unit, activate transitive with test
18035 if In_Extended_Main_Source_Unit (N) then
18036 Opt.No_Elab_Code_All_Pragma := N;
18039 --------------------------
18040 -- No_Heap_Finalization --
18041 --------------------------
18043 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18045 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
18046 Context : constant Node_Id := Parent (N);
18047 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
18053 Check_No_Identifiers;
18055 -- The pragma appears in a configuration file
18057 if No (Context) then
18058 Check_Arg_Count (0);
18059 Check_Valid_Configuration_Pragma;
18061 -- Detect a duplicate pragma
18063 if Present (No_Heap_Finalization_Pragma) then
18066 Prev => No_Heap_Finalization_Pragma);
18070 No_Heap_Finalization_Pragma := N;
18072 -- Otherwise the pragma should be associated with a library-level
18073 -- named access-to-object type.
18076 Check_Arg_Count (1);
18077 Check_Arg_Is_Local_Name (Arg1);
18079 Find_Type (Typ_Arg);
18080 Typ := Entity (Typ_Arg);
18082 -- The type being subjected to the pragma is erroneous
18084 if Typ = Any_Type then
18085 Error_Pragma ("cannot find type referenced by pragma %");
18087 -- The pragma is applied to an incomplete or generic formal
18088 -- type way too early.
18090 elsif Rep_Item_Too_Early (Typ, N) then
18094 Typ := Underlying_Type (Typ);
18097 -- The pragma must apply to an access-to-object type
18099 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
18102 -- Give a detailed error message on all other access type kinds
18104 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
18106 ("pragma % cannot apply to access protected subprogram "
18109 elsif Ekind (Typ) = E_Access_Subprogram_Type then
18111 ("pragma % cannot apply to access subprogram type");
18113 elsif Is_Anonymous_Access_Type (Typ) then
18115 ("pragma % cannot apply to anonymous access type");
18117 -- Give a general error message in case the pragma applies to a
18118 -- non-access type.
18122 ("pragma % must apply to library level access type");
18125 -- At this point the argument denotes an access-to-object type.
18126 -- Ensure that the type is declared at the library level.
18128 if Is_Library_Level_Entity (Typ) then
18131 -- Quietly ignore an access-to-object type originally declared
18132 -- at the library level within a generic, but instantiated at
18133 -- a non-library level. As a result the access-to-object type
18134 -- "loses" its No_Heap_Finalization property.
18136 elsif In_Instance then
18141 ("pragma % must apply to library level access type");
18144 -- Detect a duplicate pragma
18146 if Present (No_Heap_Finalization_Pragma) then
18149 Prev => No_Heap_Finalization_Pragma);
18153 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
18155 if Present (Prev) then
18163 Record_Rep_Item (Typ, N);
18165 end No_Heap_Finalization;
18171 -- pragma No_Inline ( NAME {, NAME} );
18173 when Pragma_No_Inline =>
18175 Process_Inline (Suppressed);
18181 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18183 when Pragma_No_Return => No_Return : declare
18189 Ghost_Error_Posted : Boolean := False;
18190 -- Flag set when an error concerning the illegal mix of Ghost and
18191 -- non-Ghost subprograms is emitted.
18193 Ghost_Id : Entity_Id := Empty;
18194 -- The entity of the first Ghost procedure encountered while
18195 -- processing the arguments of the pragma.
18199 Check_At_Least_N_Arguments (1);
18201 -- Loop through arguments of pragma
18204 while Present (Arg) loop
18205 Check_Arg_Is_Local_Name (Arg);
18206 Id := Get_Pragma_Arg (Arg);
18209 if not Is_Entity_Name (Id) then
18210 Error_Pragma_Arg ("entity name required", Arg);
18213 if Etype (Id) = Any_Type then
18217 -- Loop to find matching procedures
18223 and then Scope (E) = Current_Scope
18225 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
18227 -- Check that the pragma is not applied to a body.
18228 -- First check the specless body case, to give a
18229 -- different error message. These checks do not apply
18230 -- if Relaxed_RM_Semantics, to accommodate other Ada
18231 -- compilers. Disable these checks under -gnatd.J.
18233 if not Debug_Flag_Dot_JJ then
18234 if Nkind (Parent (Declaration_Node (E))) =
18236 and then not Relaxed_RM_Semantics
18239 ("pragma% requires separate spec and must come "
18243 -- Now the "specful" body case
18245 if Rep_Item_Too_Late (E, N) then
18252 -- A pragma that applies to a Ghost entity becomes Ghost
18253 -- for the purposes of legality checks and removal of
18254 -- ignored Ghost code.
18256 Mark_Ghost_Pragma (N, E);
18258 -- Capture the entity of the first Ghost procedure being
18259 -- processed for error detection purposes.
18261 if Is_Ghost_Entity (E) then
18262 if No (Ghost_Id) then
18266 -- Otherwise the subprogram is non-Ghost. It is illegal
18267 -- to mix references to Ghost and non-Ghost entities
18270 elsif Present (Ghost_Id)
18271 and then not Ghost_Error_Posted
18273 Ghost_Error_Posted := True;
18275 Error_Msg_Name_1 := Pname;
18277 ("pragma % cannot mention ghost and non-ghost "
18278 & "procedures", N);
18280 Error_Msg_Sloc := Sloc (Ghost_Id);
18281 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
18283 Error_Msg_Sloc := Sloc (E);
18284 Error_Msg_NE ("\& # declared as non-ghost", N, E);
18287 -- Set flag on any alias as well
18289 if Is_Overloadable (E) and then Present (Alias (E)) then
18290 Set_No_Return (Alias (E));
18296 exit when From_Aspect_Specification (N);
18300 -- If entity in not in current scope it may be the enclosing
18301 -- suprogram body to which the aspect applies.
18304 if Entity (Id) = Current_Scope
18305 and then From_Aspect_Specification (N)
18307 Set_No_Return (Entity (Id));
18309 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
18321 -- pragma No_Run_Time;
18323 -- Note: this pragma is retained for backwards compatibility. See
18324 -- body of Rtsfind for full details on its handling.
18326 when Pragma_No_Run_Time =>
18328 Check_Valid_Configuration_Pragma;
18329 Check_Arg_Count (0);
18331 -- Remove backward compatibility if Build_Type is FSF or GPL and
18332 -- generate a warning.
18335 Ignore : constant Boolean := Build_Type in FSF .. GPL;
18338 Error_Pragma ("pragma% is ignored, has no effect??");
18340 No_Run_Time_Mode := True;
18341 Configurable_Run_Time_Mode := True;
18343 -- Set Duration to 32 bits if word size is 32
18345 if Ttypes.System_Word_Size = 32 then
18346 Duration_32_Bits_On_Target := True;
18349 -- Set appropriate restrictions
18351 Set_Restriction (No_Finalization, N);
18352 Set_Restriction (No_Exception_Handlers, N);
18353 Set_Restriction (Max_Tasks, N, 0);
18354 Set_Restriction (No_Tasking, N);
18358 -----------------------
18359 -- No_Tagged_Streams --
18360 -----------------------
18362 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18364 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
18370 Check_At_Most_N_Arguments (1);
18372 -- One argument case
18374 if Arg_Count = 1 then
18375 Check_Optional_Identifier (Arg1, Name_Entity);
18376 Check_Arg_Is_Local_Name (Arg1);
18377 E_Id := Get_Pragma_Arg (Arg1);
18379 if Etype (E_Id) = Any_Type then
18383 E := Entity (E_Id);
18385 Check_Duplicate_Pragma (E);
18387 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
18389 ("argument for pragma% must be root tagged type", Arg1);
18392 if Rep_Item_Too_Early (E, N)
18394 Rep_Item_Too_Late (E, N)
18398 Set_No_Tagged_Streams_Pragma (E, N);
18401 -- Zero argument case
18404 Check_Is_In_Decl_Part_Or_Package_Spec;
18405 No_Tagged_Streams := N;
18407 end No_Tagged_Strms;
18409 ------------------------
18410 -- No_Strict_Aliasing --
18411 ------------------------
18413 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18415 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
18420 Check_At_Most_N_Arguments (1);
18422 if Arg_Count = 0 then
18423 Check_Valid_Configuration_Pragma;
18424 Opt.No_Strict_Aliasing := True;
18427 Check_Optional_Identifier (Arg2, Name_Entity);
18428 Check_Arg_Is_Local_Name (Arg1);
18429 E_Id := Entity (Get_Pragma_Arg (Arg1));
18431 if E_Id = Any_Type then
18433 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
18434 Error_Pragma_Arg ("pragma% requires access type", Arg1);
18437 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
18439 end No_Strict_Aliasing;
18441 -----------------------
18442 -- Normalize_Scalars --
18443 -----------------------
18445 -- pragma Normalize_Scalars;
18447 when Pragma_Normalize_Scalars =>
18448 Check_Ada_83_Warning;
18449 Check_Arg_Count (0);
18450 Check_Valid_Configuration_Pragma;
18452 -- Normalize_Scalars creates false positives in CodePeer, and
18453 -- incorrect negative results in GNATprove mode, so ignore this
18454 -- pragma in these modes.
18456 if not (CodePeer_Mode or GNATprove_Mode) then
18457 Normalize_Scalars := True;
18458 Init_Or_Norm_Scalars := True;
18465 -- pragma Obsolescent;
18467 -- pragma Obsolescent (
18468 -- [Message =>] static_string_EXPRESSION
18469 -- [,[Version =>] Ada_05]]);
18471 -- pragma Obsolescent (
18472 -- [Entity =>] NAME
18473 -- [,[Message =>] static_string_EXPRESSION
18474 -- [,[Version =>] Ada_05]] );
18476 when Pragma_Obsolescent => Obsolescent : declare
18480 procedure Set_Obsolescent (E : Entity_Id);
18481 -- Given an entity Ent, mark it as obsolescent if appropriate
18483 ---------------------
18484 -- Set_Obsolescent --
18485 ---------------------
18487 procedure Set_Obsolescent (E : Entity_Id) is
18496 -- A pragma that applies to a Ghost entity becomes Ghost for
18497 -- the purposes of legality checks and removal of ignored Ghost
18500 Mark_Ghost_Pragma (N, E);
18502 -- Entity name was given
18504 if Present (Ename) then
18506 -- If entity name matches, we are fine. Save entity in
18507 -- pragma argument, for ASIS use.
18509 if Chars (Ename) = Chars (Ent) then
18510 Set_Entity (Ename, Ent);
18511 Generate_Reference (Ent, Ename);
18513 -- If entity name does not match, only possibility is an
18514 -- enumeration literal from an enumeration type declaration.
18516 elsif Ekind (Ent) /= E_Enumeration_Type then
18518 ("pragma % entity name does not match declaration");
18521 Ent := First_Literal (E);
18525 ("pragma % entity name does not match any "
18526 & "enumeration literal");
18528 elsif Chars (Ent) = Chars (Ename) then
18529 Set_Entity (Ename, Ent);
18530 Generate_Reference (Ent, Ename);
18534 Ent := Next_Literal (Ent);
18540 -- Ent points to entity to be marked
18542 if Arg_Count >= 1 then
18544 -- Deal with static string argument
18546 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18547 S := Strval (Get_Pragma_Arg (Arg1));
18549 for J in 1 .. String_Length (S) loop
18550 if not In_Character_Range (Get_String_Char (S, J)) then
18552 ("pragma% argument does not allow wide characters",
18557 Obsolescent_Warnings.Append
18558 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18560 -- Check for Ada_05 parameter
18562 if Arg_Count /= 1 then
18563 Check_Arg_Count (2);
18566 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18569 Check_Arg_Is_Identifier (Argx);
18571 if Chars (Argx) /= Name_Ada_05 then
18572 Error_Msg_Name_2 := Name_Ada_05;
18574 ("only allowed argument for pragma% is %", Argx);
18577 if Ada_Version_Explicit < Ada_2005
18578 or else not Warn_On_Ada_2005_Compatibility
18586 -- Set flag if pragma active
18589 Set_Is_Obsolescent (Ent);
18593 end Set_Obsolescent;
18595 -- Start of processing for pragma Obsolescent
18600 Check_At_Most_N_Arguments (3);
18602 -- See if first argument specifies an entity name
18606 (Chars (Arg1) = Name_Entity
18608 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18610 N_Operator_Symbol))
18612 Ename := Get_Pragma_Arg (Arg1);
18614 -- Eliminate first argument, so we can share processing
18618 Arg_Count := Arg_Count - 1;
18620 -- No Entity name argument given
18626 if Arg_Count >= 1 then
18627 Check_Optional_Identifier (Arg1, Name_Message);
18629 if Arg_Count = 2 then
18630 Check_Optional_Identifier (Arg2, Name_Version);
18634 -- Get immediately preceding declaration
18637 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18641 -- Cases where we do not follow anything other than another pragma
18645 -- First case: library level compilation unit declaration with
18646 -- the pragma immediately following the declaration.
18648 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18650 (Defining_Entity (Unit (Parent (Parent (N)))));
18653 -- Case 2: library unit placement for package
18657 Ent : constant Entity_Id := Find_Lib_Unit_Name;
18659 if Is_Package_Or_Generic_Package (Ent) then
18660 Set_Obsolescent (Ent);
18666 -- Cases where we must follow a declaration, including an
18667 -- abstract subprogram declaration, which is not in the
18668 -- other node subtypes.
18671 if Nkind (Decl) not in N_Declaration
18672 and then Nkind (Decl) not in N_Later_Decl_Item
18673 and then Nkind (Decl) not in N_Generic_Declaration
18674 and then Nkind (Decl) not in N_Renaming_Declaration
18675 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18678 ("pragma% misplaced, "
18679 & "must immediately follow a declaration");
18682 Set_Obsolescent (Defining_Entity (Decl));
18692 -- pragma Optimize (Time | Space | Off);
18694 -- The actual check for optimize is done in Gigi. Note that this
18695 -- pragma does not actually change the optimization setting, it
18696 -- simply checks that it is consistent with the pragma.
18698 when Pragma_Optimize =>
18699 Check_No_Identifiers;
18700 Check_Arg_Count (1);
18701 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18703 ------------------------
18704 -- Optimize_Alignment --
18705 ------------------------
18707 -- pragma Optimize_Alignment (Time | Space | Off);
18709 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18711 Check_No_Identifiers;
18712 Check_Arg_Count (1);
18713 Check_Valid_Configuration_Pragma;
18716 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18719 when Name_Off => Opt.Optimize_Alignment := 'O';
18720 when Name_Space => Opt.Optimize_Alignment := 'S';
18721 when Name_Time => Opt.Optimize_Alignment := 'T';
18724 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18728 -- Set indication that mode is set locally. If we are in fact in a
18729 -- configuration pragma file, this setting is harmless since the
18730 -- switch will get reset anyway at the start of each unit.
18732 Optimize_Alignment_Local := True;
18733 end Optimize_Alignment;
18739 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18741 when Pragma_Ordered => Ordered : declare
18742 Assoc : constant Node_Id := Arg1;
18748 Check_No_Identifiers;
18749 Check_Arg_Count (1);
18750 Check_Arg_Is_Local_Name (Arg1);
18752 Type_Id := Get_Pragma_Arg (Assoc);
18753 Find_Type (Type_Id);
18754 Typ := Entity (Type_Id);
18756 if Typ = Any_Type then
18759 Typ := Underlying_Type (Typ);
18762 if not Is_Enumeration_Type (Typ) then
18763 Error_Pragma ("pragma% must specify enumeration type");
18766 Check_First_Subtype (Arg1);
18767 Set_Has_Pragma_Ordered (Base_Type (Typ));
18770 -------------------
18771 -- Overflow_Mode --
18772 -------------------
18774 -- pragma Overflow_Mode
18775 -- ([General => ] MODE [, [Assertions => ] MODE]);
18777 -- MODE := STRICT | MINIMIZED | ELIMINATED
18779 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18780 -- since System.Bignums makes this assumption. This is true of nearly
18781 -- all (all?) targets.
18783 when Pragma_Overflow_Mode => Overflow_Mode : declare
18784 function Get_Overflow_Mode
18786 Arg : Node_Id) return Overflow_Mode_Type;
18787 -- Function to process one pragma argument, Arg. If an identifier
18788 -- is present, it must be Name. Mode type is returned if a valid
18789 -- argument exists, otherwise an error is signalled.
18791 -----------------------
18792 -- Get_Overflow_Mode --
18793 -----------------------
18795 function Get_Overflow_Mode
18797 Arg : Node_Id) return Overflow_Mode_Type
18799 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18802 Check_Optional_Identifier (Arg, Name);
18803 Check_Arg_Is_Identifier (Argx);
18805 if Chars (Argx) = Name_Strict then
18808 elsif Chars (Argx) = Name_Minimized then
18811 elsif Chars (Argx) = Name_Eliminated then
18812 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18814 ("Eliminated not implemented on this target", Argx);
18820 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18822 end Get_Overflow_Mode;
18824 -- Start of processing for Overflow_Mode
18828 Check_At_Least_N_Arguments (1);
18829 Check_At_Most_N_Arguments (2);
18831 -- Process first argument
18833 Scope_Suppress.Overflow_Mode_General :=
18834 Get_Overflow_Mode (Name_General, Arg1);
18836 -- Case of only one argument
18838 if Arg_Count = 1 then
18839 Scope_Suppress.Overflow_Mode_Assertions :=
18840 Scope_Suppress.Overflow_Mode_General;
18842 -- Case of two arguments present
18845 Scope_Suppress.Overflow_Mode_Assertions :=
18846 Get_Overflow_Mode (Name_Assertions, Arg2);
18850 --------------------------
18851 -- Overriding Renamings --
18852 --------------------------
18854 -- pragma Overriding_Renamings;
18856 when Pragma_Overriding_Renamings =>
18858 Check_Arg_Count (0);
18859 Check_Valid_Configuration_Pragma;
18860 Overriding_Renamings := True;
18866 -- pragma Pack (first_subtype_LOCAL_NAME);
18868 when Pragma_Pack => Pack : declare
18869 Assoc : constant Node_Id := Arg1;
18871 Ignore : Boolean := False;
18876 Check_No_Identifiers;
18877 Check_Arg_Count (1);
18878 Check_Arg_Is_Local_Name (Arg1);
18879 Type_Id := Get_Pragma_Arg (Assoc);
18881 if not Is_Entity_Name (Type_Id)
18882 or else not Is_Type (Entity (Type_Id))
18885 ("argument for pragma% must be type or subtype", Arg1);
18888 Find_Type (Type_Id);
18889 Typ := Entity (Type_Id);
18892 or else Rep_Item_Too_Early (Typ, N)
18896 Typ := Underlying_Type (Typ);
18899 -- A pragma that applies to a Ghost entity becomes Ghost for the
18900 -- purposes of legality checks and removal of ignored Ghost code.
18902 Mark_Ghost_Pragma (N, Typ);
18904 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18905 Error_Pragma ("pragma% must specify array or record type");
18908 Check_First_Subtype (Arg1);
18909 Check_Duplicate_Pragma (Typ);
18913 if Is_Array_Type (Typ) then
18914 Ctyp := Component_Type (Typ);
18916 -- Ignore pack that does nothing
18918 if Known_Static_Esize (Ctyp)
18919 and then Known_Static_RM_Size (Ctyp)
18920 and then Esize (Ctyp) = RM_Size (Ctyp)
18921 and then Addressable (Esize (Ctyp))
18926 -- Process OK pragma Pack. Note that if there is a separate
18927 -- component clause present, the Pack will be cancelled. This
18928 -- processing is in Freeze.
18930 if not Rep_Item_Too_Late (Typ, N) then
18932 -- In CodePeer mode, we do not need complex front-end
18933 -- expansions related to pragma Pack, so disable handling
18936 if CodePeer_Mode then
18939 -- Normal case where we do the pack action
18943 Set_Is_Packed (Base_Type (Typ));
18944 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18947 Set_Has_Pragma_Pack (Base_Type (Typ));
18951 -- For record types, the pack is always effective
18953 else pragma Assert (Is_Record_Type (Typ));
18954 if not Rep_Item_Too_Late (Typ, N) then
18955 Set_Is_Packed (Base_Type (Typ));
18956 Set_Has_Pragma_Pack (Base_Type (Typ));
18957 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18968 -- There is nothing to do here, since we did all the processing for
18969 -- this pragma in Par.Prag (so that it works properly even in syntax
18972 when Pragma_Page =>
18979 -- pragma Part_Of (ABSTRACT_STATE);
18981 -- ABSTRACT_STATE ::= NAME
18983 when Pragma_Part_Of => Part_Of : declare
18984 procedure Propagate_Part_Of
18985 (Pack_Id : Entity_Id;
18986 State_Id : Entity_Id;
18987 Instance : Node_Id);
18988 -- Propagate the Part_Of indicator to all abstract states and
18989 -- objects declared in the visible state space of a package
18990 -- denoted by Pack_Id. State_Id is the encapsulating state.
18991 -- Instance is the package instantiation node.
18993 -----------------------
18994 -- Propagate_Part_Of --
18995 -----------------------
18997 procedure Propagate_Part_Of
18998 (Pack_Id : Entity_Id;
18999 State_Id : Entity_Id;
19000 Instance : Node_Id)
19002 Has_Item : Boolean := False;
19003 -- Flag set when the visible state space contains at least one
19004 -- abstract state or variable.
19006 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
19007 -- Propagate the Part_Of indicator to all abstract states and
19008 -- objects declared in the visible state space of a package
19009 -- denoted by Pack_Id.
19011 -----------------------
19012 -- Propagate_Part_Of --
19013 -----------------------
19015 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
19016 Constits : Elist_Id;
19017 Item_Id : Entity_Id;
19020 -- Traverse the entity chain of the package and set relevant
19021 -- attributes of abstract states and objects declared in the
19022 -- visible state space of the package.
19024 Item_Id := First_Entity (Pack_Id);
19025 while Present (Item_Id)
19026 and then not In_Private_Part (Item_Id)
19028 -- Do not consider internally generated items
19030 if not Comes_From_Source (Item_Id) then
19033 -- The Part_Of indicator turns an abstract state or an
19034 -- object into a constituent of the encapsulating state.
19036 elsif Ekind_In (Item_Id, E_Abstract_State,
19041 Constits := Part_Of_Constituents (State_Id);
19043 if No (Constits) then
19044 Constits := New_Elmt_List;
19045 Set_Part_Of_Constituents (State_Id, Constits);
19048 Append_Elmt (Item_Id, Constits);
19049 Set_Encapsulating_State (Item_Id, State_Id);
19051 -- Recursively handle nested packages and instantiations
19053 elsif Ekind (Item_Id) = E_Package then
19054 Propagate_Part_Of (Item_Id);
19057 Next_Entity (Item_Id);
19059 end Propagate_Part_Of;
19061 -- Start of processing for Propagate_Part_Of
19064 Propagate_Part_Of (Pack_Id);
19066 -- Detect a package instantiation that is subject to a Part_Of
19067 -- indicator, but has no visible state.
19069 if not Has_Item then
19071 ("package instantiation & has Part_Of indicator but "
19072 & "lacks visible state", Instance, Pack_Id);
19074 end Propagate_Part_Of;
19078 Constits : Elist_Id;
19080 Encap_Id : Entity_Id;
19081 Item_Id : Entity_Id;
19085 -- Start of processing for Part_Of
19089 Check_No_Identifiers;
19090 Check_Arg_Count (1);
19092 Stmt := Find_Related_Context (N, Do_Checks => True);
19094 -- Object declaration
19096 if Nkind (Stmt) = N_Object_Declaration then
19099 -- Package instantiation
19101 elsif Nkind (Stmt) = N_Package_Instantiation then
19104 -- Single concurrent type declaration
19106 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
19109 -- Otherwise the pragma is associated with an illegal construct
19116 -- Extract the entity of the related object declaration or package
19117 -- instantiation. In the case of the instantiation, use the entity
19118 -- of the instance spec.
19120 if Nkind (Stmt) = N_Package_Instantiation then
19121 Stmt := Instance_Spec (Stmt);
19124 Item_Id := Defining_Entity (Stmt);
19126 -- A pragma that applies to a Ghost entity becomes Ghost for the
19127 -- purposes of legality checks and removal of ignored Ghost code.
19129 Mark_Ghost_Pragma (N, Item_Id);
19131 -- Chain the pragma on the contract for further processing by
19132 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19134 Add_Contract_Item (N, Item_Id);
19136 -- A variable may act as constituent of a single concurrent type
19137 -- which in turn could be declared after the variable. Due to this
19138 -- discrepancy, the full analysis of indicator Part_Of is delayed
19139 -- until the end of the enclosing declarative region (see routine
19140 -- Analyze_Part_Of_In_Decl_Part).
19142 if Ekind (Item_Id) = E_Variable then
19145 -- Otherwise indicator Part_Of applies to a constant or a package
19149 Encap := Get_Pragma_Arg (Arg1);
19151 -- Detect any discrepancies between the placement of the
19152 -- constant or package instantiation with respect to state
19153 -- space and the encapsulating state.
19157 Item_Id => Item_Id,
19159 Encap_Id => Encap_Id,
19163 pragma Assert (Present (Encap_Id));
19165 if Ekind (Item_Id) = E_Constant then
19166 Constits := Part_Of_Constituents (Encap_Id);
19168 if No (Constits) then
19169 Constits := New_Elmt_List;
19170 Set_Part_Of_Constituents (Encap_Id, Constits);
19173 Append_Elmt (Item_Id, Constits);
19174 Set_Encapsulating_State (Item_Id, Encap_Id);
19176 -- Propagate the Part_Of indicator to the visible state
19177 -- space of the package instantiation.
19181 (Pack_Id => Item_Id,
19182 State_Id => Encap_Id,
19189 ----------------------------------
19190 -- Partition_Elaboration_Policy --
19191 ----------------------------------
19193 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19195 when Pragma_Partition_Elaboration_Policy => PEP : declare
19196 subtype PEP_Range is Name_Id
19197 range First_Partition_Elaboration_Policy_Name
19198 .. Last_Partition_Elaboration_Policy_Name;
19199 PEP_Val : PEP_Range;
19204 Check_Arg_Count (1);
19205 Check_No_Identifiers;
19206 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
19207 Check_Valid_Configuration_Pragma;
19208 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
19211 when Name_Concurrent => PEP := 'C';
19212 when Name_Sequential => PEP := 'S';
19215 if Partition_Elaboration_Policy /= ' '
19216 and then Partition_Elaboration_Policy /= PEP
19218 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
19220 ("partition elaboration policy incompatible with policy#");
19222 -- Set new policy, but always preserve System_Location since we
19223 -- like the error message with the run time name.
19226 Partition_Elaboration_Policy := PEP;
19228 if Partition_Elaboration_Policy_Sloc /= System_Location then
19229 Partition_Elaboration_Policy_Sloc := Loc;
19238 -- pragma Passive [(PASSIVE_FORM)];
19240 -- PASSIVE_FORM ::= Semaphore | No
19242 when Pragma_Passive =>
19245 if Nkind (Parent (N)) /= N_Task_Definition then
19246 Error_Pragma ("pragma% must be within task definition");
19249 if Arg_Count /= 0 then
19250 Check_Arg_Count (1);
19251 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
19254 ----------------------------------
19255 -- Preelaborable_Initialization --
19256 ----------------------------------
19258 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19260 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
19265 Check_Arg_Count (1);
19266 Check_No_Identifiers;
19267 Check_Arg_Is_Identifier (Arg1);
19268 Check_Arg_Is_Local_Name (Arg1);
19269 Check_First_Subtype (Arg1);
19270 Ent := Entity (Get_Pragma_Arg (Arg1));
19272 -- A pragma that applies to a Ghost entity becomes Ghost for the
19273 -- purposes of legality checks and removal of ignored Ghost code.
19275 Mark_Ghost_Pragma (N, Ent);
19277 -- The pragma may come from an aspect on a private declaration,
19278 -- even if the freeze point at which this is analyzed in the
19279 -- private part after the full view.
19281 if Has_Private_Declaration (Ent)
19282 and then From_Aspect_Specification (N)
19286 -- Check appropriate type argument
19288 elsif Is_Private_Type (Ent)
19289 or else Is_Protected_Type (Ent)
19290 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
19292 -- AI05-0028: The pragma applies to all composite types. Note
19293 -- that we apply this binding interpretation to earlier versions
19294 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19295 -- choice since there are other compilers that do the same.
19297 or else Is_Composite_Type (Ent)
19303 ("pragma % can only be applied to private, formal derived, "
19304 & "protected, or composite type", Arg1);
19307 -- Give an error if the pragma is applied to a protected type that
19308 -- does not qualify (due to having entries, or due to components
19309 -- that do not qualify).
19311 if Is_Protected_Type (Ent)
19312 and then not Has_Preelaborable_Initialization (Ent)
19315 ("protected type & does not have preelaborable "
19316 & "initialization", Ent);
19318 -- Otherwise mark the type as definitely having preelaborable
19322 Set_Known_To_Have_Preelab_Init (Ent);
19325 if Has_Pragma_Preelab_Init (Ent)
19326 and then Warn_On_Redundant_Constructs
19328 Error_Pragma ("?r?duplicate pragma%!");
19330 Set_Has_Pragma_Preelab_Init (Ent);
19334 --------------------
19335 -- Persistent_BSS --
19336 --------------------
19338 -- pragma Persistent_BSS [(object_NAME)];
19340 when Pragma_Persistent_BSS => Persistent_BSS : declare
19347 Check_At_Most_N_Arguments (1);
19349 -- Case of application to specific object (one argument)
19351 if Arg_Count = 1 then
19352 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19354 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
19356 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
19359 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
19362 Ent := Entity (Get_Pragma_Arg (Arg1));
19364 -- A pragma that applies to a Ghost entity becomes Ghost for
19365 -- the purposes of legality checks and removal of ignored Ghost
19368 Mark_Ghost_Pragma (N, Ent);
19370 -- Check for duplication before inserting in list of
19371 -- representation items.
19373 Check_Duplicate_Pragma (Ent);
19375 if Rep_Item_Too_Late (Ent, N) then
19379 Decl := Parent (Ent);
19381 if Present (Expression (Decl)) then
19383 ("object for pragma% cannot have initialization", Arg1);
19386 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
19388 ("object type for pragma% is not potentially persistent",
19393 Make_Linker_Section_Pragma
19394 (Ent, Sloc (N), ".persistent.bss");
19395 Insert_After (N, Prag);
19398 -- Case of use as configuration pragma with no arguments
19401 Check_Valid_Configuration_Pragma;
19402 Persistent_BSS_Mode := True;
19404 end Persistent_BSS;
19406 --------------------
19407 -- Rename_Pragma --
19408 --------------------
19410 -- pragma Rename_Pragma (
19411 -- [New_Name =>] IDENTIFIER,
19412 -- [Renamed =>] pragma_IDENTIFIER);
19414 when Pragma_Rename_Pragma => Rename_Pragma : declare
19415 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
19416 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
19420 Check_Valid_Configuration_Pragma;
19421 Check_Arg_Count (2);
19422 Check_Optional_Identifier (Arg1, Name_New_Name);
19423 Check_Optional_Identifier (Arg2, Name_Renamed);
19425 if Nkind (New_Name) /= N_Identifier then
19426 Error_Pragma_Arg ("identifier expected", Arg1);
19429 if Nkind (Old_Name) /= N_Identifier then
19430 Error_Pragma_Arg ("identifier expected", Arg2);
19433 -- The New_Name arg should not be an existing pragma (but we allow
19434 -- it; it's just a warning). The Old_Name arg must be an existing
19437 if Is_Pragma_Name (Chars (New_Name)) then
19438 Error_Pragma_Arg ("??pragma is already defined", Arg1);
19441 if not Is_Pragma_Name (Chars (Old_Name)) then
19442 Error_Pragma_Arg ("existing pragma name expected", Arg1);
19445 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
19452 -- pragma Polling (ON | OFF);
19454 when Pragma_Polling =>
19456 Check_Arg_Count (1);
19457 Check_No_Identifiers;
19458 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19459 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
19461 -----------------------------------
19462 -- Post/Post_Class/Postcondition --
19463 -----------------------------------
19465 -- pragma Post (Boolean_EXPRESSION);
19466 -- pragma Post_Class (Boolean_EXPRESSION);
19467 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19468 -- [,[Message =>] String_EXPRESSION]);
19470 -- Characteristics:
19472 -- * Analysis - The annotation undergoes initial checks to verify
19473 -- the legal placement and context. Secondary checks preanalyze the
19476 -- Analyze_Pre_Post_Condition_In_Decl_Part
19478 -- * Expansion - The annotation is expanded during the expansion of
19479 -- the related subprogram [body] contract as performed in:
19481 -- Expand_Subprogram_Contract
19483 -- * Template - The annotation utilizes the generic template of the
19484 -- related subprogram [body] when it is:
19486 -- aspect on subprogram declaration
19487 -- aspect on stand alone subprogram body
19488 -- pragma on stand alone subprogram body
19490 -- The annotation must prepare its own template when it is:
19492 -- pragma on subprogram declaration
19494 -- * Globals - Capture of global references must occur after full
19497 -- * Instance - The annotation is instantiated automatically when
19498 -- the related generic subprogram [body] is instantiated except for
19499 -- the "pragma on subprogram declaration" case. In that scenario
19500 -- the annotation must instantiate itself.
19503 | Pragma_Post_Class
19504 | Pragma_Postcondition
19506 Analyze_Pre_Post_Condition;
19508 --------------------------------
19509 -- Pre/Pre_Class/Precondition --
19510 --------------------------------
19512 -- pragma Pre (Boolean_EXPRESSION);
19513 -- pragma Pre_Class (Boolean_EXPRESSION);
19514 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19515 -- [,[Message =>] String_EXPRESSION]);
19517 -- Characteristics:
19519 -- * Analysis - The annotation undergoes initial checks to verify
19520 -- the legal placement and context. Secondary checks preanalyze the
19523 -- Analyze_Pre_Post_Condition_In_Decl_Part
19525 -- * Expansion - The annotation is expanded during the expansion of
19526 -- the related subprogram [body] contract as performed in:
19528 -- Expand_Subprogram_Contract
19530 -- * Template - The annotation utilizes the generic template of the
19531 -- related subprogram [body] when it is:
19533 -- aspect on subprogram declaration
19534 -- aspect on stand alone subprogram body
19535 -- pragma on stand alone subprogram body
19537 -- The annotation must prepare its own template when it is:
19539 -- pragma on subprogram declaration
19541 -- * Globals - Capture of global references must occur after full
19544 -- * Instance - The annotation is instantiated automatically when
19545 -- the related generic subprogram [body] is instantiated except for
19546 -- the "pragma on subprogram declaration" case. In that scenario
19547 -- the annotation must instantiate itself.
19551 | Pragma_Precondition
19553 Analyze_Pre_Post_Condition;
19559 -- pragma Predicate
19560 -- ([Entity =>] type_LOCAL_NAME,
19561 -- [Check =>] boolean_EXPRESSION);
19563 when Pragma_Predicate => Predicate : declare
19570 Check_Arg_Count (2);
19571 Check_Optional_Identifier (Arg1, Name_Entity);
19572 Check_Optional_Identifier (Arg2, Name_Check);
19574 Check_Arg_Is_Local_Name (Arg1);
19576 Type_Id := Get_Pragma_Arg (Arg1);
19577 Find_Type (Type_Id);
19578 Typ := Entity (Type_Id);
19580 if Typ = Any_Type then
19584 -- A pragma that applies to a Ghost entity becomes Ghost for the
19585 -- purposes of legality checks and removal of ignored Ghost code.
19587 Mark_Ghost_Pragma (N, Typ);
19589 -- The remaining processing is simply to link the pragma on to
19590 -- the rep item chain, for processing when the type is frozen.
19591 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19592 -- mark the type as having predicates.
19594 -- If the current policy for predicate checking is Ignore mark the
19595 -- subtype accordingly. In the case of predicates we consider them
19596 -- enabled unless Ignore is specified (either directly or with a
19597 -- general Assertion_Policy pragma) to preserve existing warnings.
19599 Set_Has_Predicates (Typ);
19600 Set_Predicates_Ignored (Typ,
19601 Present (Check_Policy_List)
19603 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
19604 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19607 -----------------------
19608 -- Predicate_Failure --
19609 -----------------------
19611 -- pragma Predicate_Failure
19612 -- ([Entity =>] type_LOCAL_NAME,
19613 -- [Message =>] string_EXPRESSION);
19615 when Pragma_Predicate_Failure => Predicate_Failure : declare
19622 Check_Arg_Count (2);
19623 Check_Optional_Identifier (Arg1, Name_Entity);
19624 Check_Optional_Identifier (Arg2, Name_Message);
19626 Check_Arg_Is_Local_Name (Arg1);
19628 Type_Id := Get_Pragma_Arg (Arg1);
19629 Find_Type (Type_Id);
19630 Typ := Entity (Type_Id);
19632 if Typ = Any_Type then
19636 -- A pragma that applies to a Ghost entity becomes Ghost for the
19637 -- purposes of legality checks and removal of ignored Ghost code.
19639 Mark_Ghost_Pragma (N, Typ);
19641 -- The remaining processing is simply to link the pragma on to
19642 -- the rep item chain, for processing when the type is frozen.
19643 -- This is accomplished by a call to Rep_Item_Too_Late.
19645 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19646 end Predicate_Failure;
19652 -- pragma Preelaborate [(library_unit_NAME)];
19654 -- Set the flag Is_Preelaborated of program unit name entity
19656 when Pragma_Preelaborate => Preelaborate : declare
19657 Pa : constant Node_Id := Parent (N);
19658 Pk : constant Node_Kind := Nkind (Pa);
19662 Check_Ada_83_Warning;
19663 Check_Valid_Library_Unit_Pragma;
19665 if Nkind (N) = N_Null_Statement then
19669 Ent := Find_Lib_Unit_Name;
19671 -- A pragma that applies to a Ghost entity becomes Ghost for the
19672 -- purposes of legality checks and removal of ignored Ghost code.
19674 Mark_Ghost_Pragma (N, Ent);
19675 Check_Duplicate_Pragma (Ent);
19677 -- This filters out pragmas inside generic parents that show up
19678 -- inside instantiations. Pragmas that come from aspects in the
19679 -- unit are not ignored.
19681 if Present (Ent) then
19682 if Pk = N_Package_Specification
19683 and then Present (Generic_Parent (Pa))
19684 and then not From_Aspect_Specification (N)
19689 if not Debug_Flag_U then
19690 Set_Is_Preelaborated (Ent);
19691 Set_Suppress_Elaboration_Warnings (Ent);
19697 -------------------------------
19698 -- Prefix_Exception_Messages --
19699 -------------------------------
19701 -- pragma Prefix_Exception_Messages;
19703 when Pragma_Prefix_Exception_Messages =>
19705 Check_Valid_Configuration_Pragma;
19706 Check_Arg_Count (0);
19707 Prefix_Exception_Messages := True;
19713 -- pragma Priority (EXPRESSION);
19715 when Pragma_Priority => Priority : declare
19716 P : constant Node_Id := Parent (N);
19721 Check_No_Identifiers;
19722 Check_Arg_Count (1);
19726 if Nkind (P) = N_Subprogram_Body then
19727 Check_In_Main_Program;
19729 Ent := Defining_Unit_Name (Specification (P));
19731 if Nkind (Ent) = N_Defining_Program_Unit_Name then
19732 Ent := Defining_Identifier (Ent);
19735 Arg := Get_Pragma_Arg (Arg1);
19736 Analyze_And_Resolve (Arg, Standard_Integer);
19740 if not Is_OK_Static_Expression (Arg) then
19741 Flag_Non_Static_Expr
19742 ("main subprogram priority is not static!", Arg);
19745 -- If constraint error, then we already signalled an error
19747 elsif Raises_Constraint_Error (Arg) then
19750 -- Otherwise check in range except if Relaxed_RM_Semantics
19751 -- where we ignore the value if out of range.
19754 if not Relaxed_RM_Semantics
19755 and then not Is_In_Range (Arg, RTE (RE_Priority))
19758 ("main subprogram priority is out of range", Arg1);
19761 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19765 -- Load an arbitrary entity from System.Tasking.Stages or
19766 -- System.Tasking.Restricted.Stages (depending on the
19767 -- supported profile) to make sure that one of these packages
19768 -- is implicitly with'ed, since we need to have the tasking
19769 -- run time active for the pragma Priority to have any effect.
19770 -- Previously we with'ed the package System.Tasking, but this
19771 -- package does not trigger the required initialization of the
19772 -- run-time library.
19775 Discard : Entity_Id;
19776 pragma Warnings (Off, Discard);
19778 if Restricted_Profile then
19779 Discard := RTE (RE_Activate_Restricted_Tasks);
19781 Discard := RTE (RE_Activate_Tasks);
19785 -- Task or Protected, must be of type Integer
19787 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19788 Arg := Get_Pragma_Arg (Arg1);
19789 Ent := Defining_Identifier (Parent (P));
19791 -- The expression must be analyzed in the special manner
19792 -- described in "Handling of Default and Per-Object
19793 -- Expressions" in sem.ads.
19795 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19797 if not Is_OK_Static_Expression (Arg) then
19798 Check_Restriction (Static_Priorities, Arg);
19801 -- Anything else is incorrect
19807 -- Check duplicate pragma before we chain the pragma in the Rep
19808 -- Item chain of Ent.
19810 Check_Duplicate_Pragma (Ent);
19811 Record_Rep_Item (Ent, N);
19814 -----------------------------------
19815 -- Priority_Specific_Dispatching --
19816 -----------------------------------
19818 -- pragma Priority_Specific_Dispatching (
19819 -- policy_IDENTIFIER,
19820 -- first_priority_EXPRESSION,
19821 -- last_priority_EXPRESSION);
19823 when Pragma_Priority_Specific_Dispatching =>
19824 Priority_Specific_Dispatching : declare
19825 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19826 -- This is the entity System.Any_Priority;
19829 Lower_Bound : Node_Id;
19830 Upper_Bound : Node_Id;
19836 Check_Arg_Count (3);
19837 Check_No_Identifiers;
19838 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19839 Check_Valid_Configuration_Pragma;
19840 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19841 DP := Fold_Upper (Name_Buffer (1));
19843 Lower_Bound := Get_Pragma_Arg (Arg2);
19844 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19845 Lower_Val := Expr_Value (Lower_Bound);
19847 Upper_Bound := Get_Pragma_Arg (Arg3);
19848 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19849 Upper_Val := Expr_Value (Upper_Bound);
19851 -- It is not allowed to use Task_Dispatching_Policy and
19852 -- Priority_Specific_Dispatching in the same partition.
19854 if Task_Dispatching_Policy /= ' ' then
19855 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19857 ("pragma% incompatible with Task_Dispatching_Policy#");
19859 -- Check lower bound in range
19861 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19863 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19866 ("first_priority is out of range", Arg2);
19868 -- Check upper bound in range
19870 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19872 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19875 ("last_priority is out of range", Arg3);
19877 -- Check that the priority range is valid
19879 elsif Lower_Val > Upper_Val then
19881 ("last_priority_expression must be greater than or equal to "
19882 & "first_priority_expression");
19884 -- Store the new policy, but always preserve System_Location since
19885 -- we like the error message with the run-time name.
19888 -- Check overlapping in the priority ranges specified in other
19889 -- Priority_Specific_Dispatching pragmas within the same
19890 -- partition. We can only check those we know about.
19893 Specific_Dispatching.First .. Specific_Dispatching.Last
19895 if Specific_Dispatching.Table (J).First_Priority in
19896 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19897 or else Specific_Dispatching.Table (J).Last_Priority in
19898 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19901 Specific_Dispatching.Table (J).Pragma_Loc;
19903 ("priority range overlaps with "
19904 & "Priority_Specific_Dispatching#");
19908 -- The use of Priority_Specific_Dispatching is incompatible
19909 -- with Task_Dispatching_Policy.
19911 if Task_Dispatching_Policy /= ' ' then
19912 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19914 ("Priority_Specific_Dispatching incompatible "
19915 & "with Task_Dispatching_Policy#");
19918 -- The use of Priority_Specific_Dispatching forces ceiling
19921 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19922 Error_Msg_Sloc := Locking_Policy_Sloc;
19924 ("Priority_Specific_Dispatching incompatible "
19925 & "with Locking_Policy#");
19927 -- Set the Ceiling_Locking policy, but preserve System_Location
19928 -- since we like the error message with the run time name.
19931 Locking_Policy := 'C';
19933 if Locking_Policy_Sloc /= System_Location then
19934 Locking_Policy_Sloc := Loc;
19938 -- Add entry in the table
19940 Specific_Dispatching.Append
19941 ((Dispatching_Policy => DP,
19942 First_Priority => UI_To_Int (Lower_Val),
19943 Last_Priority => UI_To_Int (Upper_Val),
19944 Pragma_Loc => Loc));
19946 end Priority_Specific_Dispatching;
19952 -- pragma Profile (profile_IDENTIFIER);
19954 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19956 when Pragma_Profile =>
19958 Check_Arg_Count (1);
19959 Check_Valid_Configuration_Pragma;
19960 Check_No_Identifiers;
19963 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19966 if Chars (Argx) = Name_Ravenscar then
19967 Set_Ravenscar_Profile (Ravenscar, N);
19969 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19970 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19972 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
19973 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
19975 elsif Chars (Argx) = Name_Restricted then
19976 Set_Profile_Restrictions
19978 N, Warn => Treat_Restrictions_As_Warnings);
19980 elsif Chars (Argx) = Name_Rational then
19981 Set_Rational_Profile;
19983 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19984 Set_Profile_Restrictions
19985 (No_Implementation_Extensions,
19986 N, Warn => Treat_Restrictions_As_Warnings);
19989 Error_Pragma_Arg ("& is not a valid profile", Argx);
19993 ----------------------
19994 -- Profile_Warnings --
19995 ----------------------
19997 -- pragma Profile_Warnings (profile_IDENTIFIER);
19999 -- profile_IDENTIFIER => Restricted | Ravenscar
20001 when Pragma_Profile_Warnings =>
20003 Check_Arg_Count (1);
20004 Check_Valid_Configuration_Pragma;
20005 Check_No_Identifiers;
20008 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20011 if Chars (Argx) = Name_Ravenscar then
20012 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
20014 elsif Chars (Argx) = Name_Restricted then
20015 Set_Profile_Restrictions (Restricted, N, Warn => True);
20017 elsif Chars (Argx) = Name_No_Implementation_Extensions then
20018 Set_Profile_Restrictions
20019 (No_Implementation_Extensions, N, Warn => True);
20022 Error_Pragma_Arg ("& is not a valid profile", Argx);
20026 --------------------------
20027 -- Propagate_Exceptions --
20028 --------------------------
20030 -- pragma Propagate_Exceptions;
20032 -- Note: this pragma is obsolete and has no effect
20034 when Pragma_Propagate_Exceptions =>
20036 Check_Arg_Count (0);
20038 if Warn_On_Obsolescent_Feature then
20040 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20041 "and has no effect?j?", N);
20044 -----------------------------
20045 -- Provide_Shift_Operators --
20046 -----------------------------
20048 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20050 when Pragma_Provide_Shift_Operators =>
20051 Provide_Shift_Operators : declare
20054 procedure Declare_Shift_Operator (Nam : Name_Id);
20055 -- Insert declaration and pragma Instrinsic for named shift op
20057 ----------------------------
20058 -- Declare_Shift_Operator --
20059 ----------------------------
20061 procedure Declare_Shift_Operator (Nam : Name_Id) is
20067 Make_Subprogram_Declaration (Loc,
20068 Make_Function_Specification (Loc,
20069 Defining_Unit_Name =>
20070 Make_Defining_Identifier (Loc, Chars => Nam),
20072 Result_Definition =>
20073 Make_Identifier (Loc, Chars => Chars (Ent)),
20075 Parameter_Specifications => New_List (
20076 Make_Parameter_Specification (Loc,
20077 Defining_Identifier =>
20078 Make_Defining_Identifier (Loc, Name_Value),
20080 Make_Identifier (Loc, Chars => Chars (Ent))),
20082 Make_Parameter_Specification (Loc,
20083 Defining_Identifier =>
20084 Make_Defining_Identifier (Loc, Name_Amount),
20086 New_Occurrence_Of (Standard_Natural, Loc)))));
20090 Chars => Name_Import,
20091 Pragma_Argument_Associations => New_List (
20092 Make_Pragma_Argument_Association (Loc,
20093 Expression => Make_Identifier (Loc, Name_Intrinsic)),
20094 Make_Pragma_Argument_Association (Loc,
20095 Expression => Make_Identifier (Loc, Nam))));
20097 Insert_After (N, Import);
20098 Insert_After (N, Func);
20099 end Declare_Shift_Operator;
20101 -- Start of processing for Provide_Shift_Operators
20105 Check_Arg_Count (1);
20106 Check_Arg_Is_Local_Name (Arg1);
20108 Arg1 := Get_Pragma_Arg (Arg1);
20110 -- We must have an entity name
20112 if not Is_Entity_Name (Arg1) then
20114 ("pragma % must apply to integer first subtype", Arg1);
20117 -- If no Entity, means there was a prior error so ignore
20119 if Present (Entity (Arg1)) then
20120 Ent := Entity (Arg1);
20122 -- Apply error checks
20124 if not Is_First_Subtype (Ent) then
20126 ("cannot apply pragma %",
20127 "\& is not a first subtype",
20130 elsif not Is_Integer_Type (Ent) then
20132 ("cannot apply pragma %",
20133 "\& is not an integer type",
20136 elsif Has_Shift_Operator (Ent) then
20138 ("cannot apply pragma %",
20139 "\& already has declared shift operators",
20142 elsif Is_Frozen (Ent) then
20144 ("pragma % appears too late",
20145 "\& is already frozen",
20149 -- Now declare the operators. We do this during analysis rather
20150 -- than expansion, since we want the operators available if we
20151 -- are operating in -gnatc or ASIS mode.
20153 Declare_Shift_Operator (Name_Rotate_Left);
20154 Declare_Shift_Operator (Name_Rotate_Right);
20155 Declare_Shift_Operator (Name_Shift_Left);
20156 Declare_Shift_Operator (Name_Shift_Right);
20157 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
20159 end Provide_Shift_Operators;
20165 -- pragma Psect_Object (
20166 -- [Internal =>] LOCAL_NAME,
20167 -- [, [External =>] EXTERNAL_SYMBOL]
20168 -- [, [Size =>] EXTERNAL_SYMBOL]);
20170 when Pragma_Common_Object
20171 | Pragma_Psect_Object
20173 Psect_Object : declare
20174 Args : Args_List (1 .. 3);
20175 Names : constant Name_List (1 .. 3) := (
20180 Internal : Node_Id renames Args (1);
20181 External : Node_Id renames Args (2);
20182 Size : Node_Id renames Args (3);
20184 Def_Id : Entity_Id;
20186 procedure Check_Arg (Arg : Node_Id);
20187 -- Checks that argument is either a string literal or an
20188 -- identifier, and posts error message if not.
20194 procedure Check_Arg (Arg : Node_Id) is
20196 if not Nkind_In (Original_Node (Arg),
20201 ("inappropriate argument for pragma %", Arg);
20205 -- Start of processing for Common_Object/Psect_Object
20209 Gather_Associations (Names, Args);
20210 Process_Extended_Import_Export_Internal_Arg (Internal);
20212 Def_Id := Entity (Internal);
20214 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
20216 ("pragma% must designate an object", Internal);
20219 Check_Arg (Internal);
20221 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
20223 ("cannot use pragma% for imported/exported object",
20227 if Is_Concurrent_Type (Etype (Internal)) then
20229 ("cannot specify pragma % for task/protected object",
20233 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
20235 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
20237 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
20240 if Ekind (Def_Id) = E_Constant then
20242 ("cannot specify pragma % for a constant", Internal);
20245 if Is_Record_Type (Etype (Internal)) then
20251 Ent := First_Entity (Etype (Internal));
20252 while Present (Ent) loop
20253 Decl := Declaration_Node (Ent);
20255 if Ekind (Ent) = E_Component
20256 and then Nkind (Decl) = N_Component_Declaration
20257 and then Present (Expression (Decl))
20258 and then Warn_On_Export_Import
20261 ("?x?object for pragma % has defaults", Internal);
20271 if Present (Size) then
20275 if Present (External) then
20276 Check_Arg_Is_External_Name (External);
20279 -- If all error tests pass, link pragma on to the rep item chain
20281 Record_Rep_Item (Def_Id, N);
20288 -- pragma Pure [(library_unit_NAME)];
20290 when Pragma_Pure => Pure : declare
20294 Check_Ada_83_Warning;
20296 -- If the pragma comes from a subprogram instantiation, nothing to
20297 -- check, this can happen at any level of nesting.
20299 if Is_Wrapper_Package (Current_Scope) then
20302 Check_Valid_Library_Unit_Pragma;
20305 if Nkind (N) = N_Null_Statement then
20309 Ent := Find_Lib_Unit_Name;
20311 -- A pragma that applies to a Ghost entity becomes Ghost for the
20312 -- purposes of legality checks and removal of ignored Ghost code.
20314 Mark_Ghost_Pragma (N, Ent);
20316 if not Debug_Flag_U then
20318 Set_Has_Pragma_Pure (Ent);
20319 Set_Suppress_Elaboration_Warnings (Ent);
20323 -------------------
20324 -- Pure_Function --
20325 -------------------
20327 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20329 when Pragma_Pure_Function => Pure_Function : declare
20330 Def_Id : Entity_Id;
20333 Effective : Boolean := False;
20337 Check_Arg_Count (1);
20338 Check_Optional_Identifier (Arg1, Name_Entity);
20339 Check_Arg_Is_Local_Name (Arg1);
20340 E_Id := Get_Pragma_Arg (Arg1);
20342 if Error_Posted (E_Id) then
20346 -- Loop through homonyms (overloadings) of referenced entity
20348 E := Entity (E_Id);
20350 -- A pragma that applies to a Ghost entity becomes Ghost for the
20351 -- purposes of legality checks and removal of ignored Ghost code.
20353 Mark_Ghost_Pragma (N, E);
20355 if Present (E) then
20357 Def_Id := Get_Base_Subprogram (E);
20359 if not Ekind_In (Def_Id, E_Function,
20360 E_Generic_Function,
20364 ("pragma% requires a function name", Arg1);
20367 Set_Is_Pure (Def_Id);
20369 if not Has_Pragma_Pure_Function (Def_Id) then
20370 Set_Has_Pragma_Pure_Function (Def_Id);
20374 exit when From_Aspect_Specification (N);
20376 exit when No (E) or else Scope (E) /= Current_Scope;
20380 and then Warn_On_Redundant_Constructs
20383 ("pragma Pure_Function on& is redundant?r?",
20389 --------------------
20390 -- Queuing_Policy --
20391 --------------------
20393 -- pragma Queuing_Policy (policy_IDENTIFIER);
20395 when Pragma_Queuing_Policy => declare
20399 Check_Ada_83_Warning;
20400 Check_Arg_Count (1);
20401 Check_No_Identifiers;
20402 Check_Arg_Is_Queuing_Policy (Arg1);
20403 Check_Valid_Configuration_Pragma;
20404 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20405 QP := Fold_Upper (Name_Buffer (1));
20407 if Queuing_Policy /= ' '
20408 and then Queuing_Policy /= QP
20410 Error_Msg_Sloc := Queuing_Policy_Sloc;
20411 Error_Pragma ("queuing policy incompatible with policy#");
20413 -- Set new policy, but always preserve System_Location since we
20414 -- like the error message with the run time name.
20417 Queuing_Policy := QP;
20419 if Queuing_Policy_Sloc /= System_Location then
20420 Queuing_Policy_Sloc := Loc;
20429 -- pragma Rational, for compatibility with foreign compiler
20431 when Pragma_Rational =>
20432 Set_Rational_Profile;
20434 ---------------------
20435 -- Refined_Depends --
20436 ---------------------
20438 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20440 -- DEPENDENCY_RELATION ::=
20442 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20444 -- DEPENDENCY_CLAUSE ::=
20445 -- OUTPUT_LIST =>[+] INPUT_LIST
20446 -- | NULL_DEPENDENCY_CLAUSE
20448 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20450 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20452 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20454 -- OUTPUT ::= NAME | FUNCTION_RESULT
20457 -- where FUNCTION_RESULT is a function Result attribute_reference
20459 -- Characteristics:
20461 -- * Analysis - The annotation undergoes initial checks to verify
20462 -- the legal placement and context. Secondary checks fully analyze
20463 -- the dependency clauses/global list in:
20465 -- Analyze_Refined_Depends_In_Decl_Part
20467 -- * Expansion - None.
20469 -- * Template - The annotation utilizes the generic template of the
20470 -- related subprogram body.
20472 -- * Globals - Capture of global references must occur after full
20475 -- * Instance - The annotation is instantiated automatically when
20476 -- the related generic subprogram body is instantiated.
20478 when Pragma_Refined_Depends => Refined_Depends : declare
20479 Body_Id : Entity_Id;
20481 Spec_Id : Entity_Id;
20484 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20488 -- Chain the pragma on the contract for further processing by
20489 -- Analyze_Refined_Depends_In_Decl_Part.
20491 Add_Contract_Item (N, Body_Id);
20493 -- The legality checks of pragmas Refined_Depends and
20494 -- Refined_Global are affected by the SPARK mode in effect and
20495 -- the volatility of the context. In addition these two pragmas
20496 -- are subject to an inherent order:
20498 -- 1) Refined_Global
20499 -- 2) Refined_Depends
20501 -- Analyze all these pragmas in the order outlined above
20503 Analyze_If_Present (Pragma_SPARK_Mode);
20504 Analyze_If_Present (Pragma_Volatile_Function);
20505 Analyze_If_Present (Pragma_Refined_Global);
20506 Analyze_Refined_Depends_In_Decl_Part (N);
20508 end Refined_Depends;
20510 --------------------
20511 -- Refined_Global --
20512 --------------------
20514 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20516 -- GLOBAL_SPECIFICATION ::=
20519 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20521 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20523 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20524 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20525 -- GLOBAL_ITEM ::= NAME
20527 -- Characteristics:
20529 -- * Analysis - The annotation undergoes initial checks to verify
20530 -- the legal placement and context. Secondary checks fully analyze
20531 -- the dependency clauses/global list in:
20533 -- Analyze_Refined_Global_In_Decl_Part
20535 -- * Expansion - None.
20537 -- * Template - The annotation utilizes the generic template of the
20538 -- related subprogram body.
20540 -- * Globals - Capture of global references must occur after full
20543 -- * Instance - The annotation is instantiated automatically when
20544 -- the related generic subprogram body is instantiated.
20546 when Pragma_Refined_Global => Refined_Global : declare
20547 Body_Id : Entity_Id;
20549 Spec_Id : Entity_Id;
20552 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20556 -- Chain the pragma on the contract for further processing by
20557 -- Analyze_Refined_Global_In_Decl_Part.
20559 Add_Contract_Item (N, Body_Id);
20561 -- The legality checks of pragmas Refined_Depends and
20562 -- Refined_Global are affected by the SPARK mode in effect and
20563 -- the volatility of the context. In addition these two pragmas
20564 -- are subject to an inherent order:
20566 -- 1) Refined_Global
20567 -- 2) Refined_Depends
20569 -- Analyze all these pragmas in the order outlined above
20571 Analyze_If_Present (Pragma_SPARK_Mode);
20572 Analyze_If_Present (Pragma_Volatile_Function);
20573 Analyze_Refined_Global_In_Decl_Part (N);
20574 Analyze_If_Present (Pragma_Refined_Depends);
20576 end Refined_Global;
20582 -- pragma Refined_Post (boolean_EXPRESSION);
20584 -- Characteristics:
20586 -- * Analysis - The annotation is fully analyzed immediately upon
20587 -- elaboration as it cannot forward reference entities.
20589 -- * Expansion - The annotation is expanded during the expansion of
20590 -- the related subprogram body contract as performed in:
20592 -- Expand_Subprogram_Contract
20594 -- * Template - The annotation utilizes the generic template of the
20595 -- related subprogram body.
20597 -- * Globals - Capture of global references must occur after full
20600 -- * Instance - The annotation is instantiated automatically when
20601 -- the related generic subprogram body is instantiated.
20603 when Pragma_Refined_Post => Refined_Post : declare
20604 Body_Id : Entity_Id;
20606 Spec_Id : Entity_Id;
20609 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20611 -- Fully analyze the pragma when it appears inside a subprogram
20612 -- body because it cannot benefit from forward references.
20616 -- Chain the pragma on the contract for completeness
20618 Add_Contract_Item (N, Body_Id);
20620 -- The legality checks of pragma Refined_Post are affected by
20621 -- the SPARK mode in effect and the volatility of the context.
20622 -- Analyze all pragmas in a specific order.
20624 Analyze_If_Present (Pragma_SPARK_Mode);
20625 Analyze_If_Present (Pragma_Volatile_Function);
20626 Analyze_Pre_Post_Condition_In_Decl_Part (N);
20628 -- Currently it is not possible to inline pre/postconditions on
20629 -- a subprogram subject to pragma Inline_Always.
20631 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20635 -------------------
20636 -- Refined_State --
20637 -------------------
20639 -- pragma Refined_State (REFINEMENT_LIST);
20641 -- REFINEMENT_LIST ::=
20642 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20644 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20646 -- CONSTITUENT_LIST ::=
20649 -- | (CONSTITUENT {, CONSTITUENT})
20651 -- CONSTITUENT ::= object_NAME | state_NAME
20653 -- Characteristics:
20655 -- * Analysis - The annotation undergoes initial checks to verify
20656 -- the legal placement and context. Secondary checks preanalyze the
20657 -- refinement clauses in:
20659 -- Analyze_Refined_State_In_Decl_Part
20661 -- * Expansion - None.
20663 -- * Template - The annotation utilizes the template of the related
20666 -- * Globals - Capture of global references must occur after full
20669 -- * Instance - The annotation is instantiated automatically when
20670 -- the related generic package body is instantiated.
20672 when Pragma_Refined_State => Refined_State : declare
20673 Pack_Decl : Node_Id;
20674 Spec_Id : Entity_Id;
20678 Check_No_Identifiers;
20679 Check_Arg_Count (1);
20681 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20683 -- Ensure the proper placement of the pragma. Refined states must
20684 -- be associated with a package body.
20686 if Nkind (Pack_Decl) = N_Package_Body then
20689 -- Otherwise the pragma is associated with an illegal construct
20696 Spec_Id := Corresponding_Spec (Pack_Decl);
20698 -- A pragma that applies to a Ghost entity becomes Ghost for the
20699 -- purposes of legality checks and removal of ignored Ghost code.
20701 Mark_Ghost_Pragma (N, Spec_Id);
20703 -- Chain the pragma on the contract for further processing by
20704 -- Analyze_Refined_State_In_Decl_Part.
20706 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20708 -- The legality checks of pragma Refined_State are affected by the
20709 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20711 Analyze_If_Present (Pragma_SPARK_Mode);
20713 -- State refinement is allowed only when the corresponding package
20714 -- declaration has non-null pragma Abstract_State. Refinement not
20715 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20717 if SPARK_Mode /= Off
20719 (No (Abstract_States (Spec_Id))
20720 or else Has_Null_Abstract_State (Spec_Id))
20723 ("useless refinement, package & does not define abstract "
20724 & "states", N, Spec_Id);
20729 -----------------------
20730 -- Relative_Deadline --
20731 -----------------------
20733 -- pragma Relative_Deadline (time_span_EXPRESSION);
20735 when Pragma_Relative_Deadline => Relative_Deadline : declare
20736 P : constant Node_Id := Parent (N);
20741 Check_No_Identifiers;
20742 Check_Arg_Count (1);
20744 Arg := Get_Pragma_Arg (Arg1);
20746 -- The expression must be analyzed in the special manner described
20747 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20749 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20753 if Nkind (P) = N_Subprogram_Body then
20754 Check_In_Main_Program;
20756 -- Only Task and subprogram cases allowed
20758 elsif Nkind (P) /= N_Task_Definition then
20762 -- Check duplicate pragma before we set the corresponding flag
20764 if Has_Relative_Deadline_Pragma (P) then
20765 Error_Pragma ("duplicate pragma% not allowed");
20768 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20769 -- Relative_Deadline pragma node cannot be inserted in the Rep
20770 -- Item chain of Ent since it is rewritten by the expander as a
20771 -- procedure call statement that will break the chain.
20773 Set_Has_Relative_Deadline_Pragma (P);
20774 end Relative_Deadline;
20776 ------------------------
20777 -- Remote_Access_Type --
20778 ------------------------
20780 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20782 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20787 Check_Arg_Count (1);
20788 Check_Optional_Identifier (Arg1, Name_Entity);
20789 Check_Arg_Is_Local_Name (Arg1);
20791 E := Entity (Get_Pragma_Arg (Arg1));
20793 -- A pragma that applies to a Ghost entity becomes Ghost for the
20794 -- purposes of legality checks and removal of ignored Ghost code.
20796 Mark_Ghost_Pragma (N, E);
20798 if Nkind (Parent (E)) = N_Formal_Type_Declaration
20799 and then Ekind (E) = E_General_Access_Type
20800 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20801 and then Scope (Root_Type (Directly_Designated_Type (E)))
20803 and then Is_Valid_Remote_Object_Type
20804 (Root_Type (Directly_Designated_Type (E)))
20806 Set_Is_Remote_Types (E);
20810 ("pragma% applies only to formal access-to-class-wide types",
20813 end Remote_Access_Type;
20815 ---------------------------
20816 -- Remote_Call_Interface --
20817 ---------------------------
20819 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20821 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20822 Cunit_Node : Node_Id;
20823 Cunit_Ent : Entity_Id;
20827 Check_Ada_83_Warning;
20828 Check_Valid_Library_Unit_Pragma;
20830 if Nkind (N) = N_Null_Statement then
20834 Cunit_Node := Cunit (Current_Sem_Unit);
20835 K := Nkind (Unit (Cunit_Node));
20836 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20838 -- A pragma that applies to a Ghost entity becomes Ghost for the
20839 -- purposes of legality checks and removal of ignored Ghost code.
20841 Mark_Ghost_Pragma (N, Cunit_Ent);
20843 if K = N_Package_Declaration
20844 or else K = N_Generic_Package_Declaration
20845 or else K = N_Subprogram_Declaration
20846 or else K = N_Generic_Subprogram_Declaration
20847 or else (K = N_Subprogram_Body
20848 and then Acts_As_Spec (Unit (Cunit_Node)))
20853 "pragma% must apply to package or subprogram declaration");
20856 Set_Is_Remote_Call_Interface (Cunit_Ent);
20857 end Remote_Call_Interface;
20863 -- pragma Remote_Types [(library_unit_NAME)];
20865 when Pragma_Remote_Types => Remote_Types : declare
20866 Cunit_Node : Node_Id;
20867 Cunit_Ent : Entity_Id;
20870 Check_Ada_83_Warning;
20871 Check_Valid_Library_Unit_Pragma;
20873 if Nkind (N) = N_Null_Statement then
20877 Cunit_Node := Cunit (Current_Sem_Unit);
20878 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20880 -- A pragma that applies to a Ghost entity becomes Ghost for the
20881 -- purposes of legality checks and removal of ignored Ghost code.
20883 Mark_Ghost_Pragma (N, Cunit_Ent);
20885 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20886 N_Generic_Package_Declaration)
20889 ("pragma% can only apply to a package declaration");
20892 Set_Is_Remote_Types (Cunit_Ent);
20899 -- pragma Ravenscar;
20901 when Pragma_Ravenscar =>
20903 Check_Arg_Count (0);
20904 Check_Valid_Configuration_Pragma;
20905 Set_Ravenscar_Profile (Ravenscar, N);
20907 if Warn_On_Obsolescent_Feature then
20909 ("pragma Ravenscar is an obsolescent feature?j?", N);
20911 ("|use pragma Profile (Ravenscar) instead?j?", N);
20914 -------------------------
20915 -- Restricted_Run_Time --
20916 -------------------------
20918 -- pragma Restricted_Run_Time;
20920 when Pragma_Restricted_Run_Time =>
20922 Check_Arg_Count (0);
20923 Check_Valid_Configuration_Pragma;
20924 Set_Profile_Restrictions
20925 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20927 if Warn_On_Obsolescent_Feature then
20929 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20932 ("|use pragma Profile (Restricted) instead?j?", N);
20939 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20942 -- restriction_IDENTIFIER
20943 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20945 when Pragma_Restrictions =>
20946 Process_Restrictions_Or_Restriction_Warnings
20947 (Warn => Treat_Restrictions_As_Warnings);
20949 --------------------------
20950 -- Restriction_Warnings --
20951 --------------------------
20953 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20956 -- restriction_IDENTIFIER
20957 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20959 when Pragma_Restriction_Warnings =>
20961 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20967 -- pragma Reviewable;
20969 when Pragma_Reviewable =>
20970 Check_Ada_83_Warning;
20971 Check_Arg_Count (0);
20973 -- Call dummy debugging function rv. This is done to assist front
20974 -- end debugging. By placing a Reviewable pragma in the source
20975 -- program, a breakpoint on rv catches this place in the source,
20976 -- allowing convenient stepping to the point of interest.
20980 --------------------------
20981 -- Secondary_Stack_Size --
20982 --------------------------
20984 -- pragma Secondary_Stack_Size (EXPRESSION);
20986 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
20987 P : constant Node_Id := Parent (N);
20993 Check_No_Identifiers;
20994 Check_Arg_Count (1);
20996 if Nkind (P) = N_Task_Definition then
20997 Arg := Get_Pragma_Arg (Arg1);
20998 Ent := Defining_Identifier (Parent (P));
21000 -- The expression must be analyzed in the special manner
21001 -- described in "Handling of Default Expressions" in sem.ads.
21003 Preanalyze_Spec_Expression (Arg, Any_Integer);
21005 -- The pragma cannot appear if the No_Secondary_Stack
21006 -- restriction is in effect.
21008 Check_Restriction (No_Secondary_Stack, Arg);
21010 -- Anything else is incorrect
21016 -- Check duplicate pragma before we chain the pragma in the Rep
21017 -- Item chain of Ent.
21019 Check_Duplicate_Pragma (Ent);
21020 Record_Rep_Item (Ent, N);
21021 end Secondary_Stack_Size;
21023 --------------------------
21024 -- Short_Circuit_And_Or --
21025 --------------------------
21027 -- pragma Short_Circuit_And_Or;
21029 when Pragma_Short_Circuit_And_Or =>
21031 Check_Arg_Count (0);
21032 Check_Valid_Configuration_Pragma;
21033 Short_Circuit_And_Or := True;
21035 -------------------
21036 -- Share_Generic --
21037 -------------------
21039 -- pragma Share_Generic (GNAME {, GNAME});
21041 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21043 when Pragma_Share_Generic =>
21045 Process_Generic_List;
21051 -- pragma Shared (LOCAL_NAME);
21053 when Pragma_Shared =>
21055 Process_Atomic_Independent_Shared_Volatile;
21057 --------------------
21058 -- Shared_Passive --
21059 --------------------
21061 -- pragma Shared_Passive [(library_unit_NAME)];
21063 -- Set the flag Is_Shared_Passive of program unit name entity
21065 when Pragma_Shared_Passive => Shared_Passive : declare
21066 Cunit_Node : Node_Id;
21067 Cunit_Ent : Entity_Id;
21070 Check_Ada_83_Warning;
21071 Check_Valid_Library_Unit_Pragma;
21073 if Nkind (N) = N_Null_Statement then
21077 Cunit_Node := Cunit (Current_Sem_Unit);
21078 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
21080 -- A pragma that applies to a Ghost entity becomes Ghost for the
21081 -- purposes of legality checks and removal of ignored Ghost code.
21083 Mark_Ghost_Pragma (N, Cunit_Ent);
21085 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
21086 N_Generic_Package_Declaration)
21089 ("pragma% can only apply to a package declaration");
21092 Set_Is_Shared_Passive (Cunit_Ent);
21093 end Shared_Passive;
21095 -----------------------
21096 -- Short_Descriptors --
21097 -----------------------
21099 -- pragma Short_Descriptors;
21101 -- Recognize and validate, but otherwise ignore
21103 when Pragma_Short_Descriptors =>
21105 Check_Arg_Count (0);
21106 Check_Valid_Configuration_Pragma;
21108 ------------------------------
21109 -- Simple_Storage_Pool_Type --
21110 ------------------------------
21112 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21114 when Pragma_Simple_Storage_Pool_Type =>
21115 Simple_Storage_Pool_Type : declare
21121 Check_Arg_Count (1);
21122 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21124 Type_Id := Get_Pragma_Arg (Arg1);
21125 Find_Type (Type_Id);
21126 Typ := Entity (Type_Id);
21128 if Typ = Any_Type then
21132 -- A pragma that applies to a Ghost entity becomes Ghost for the
21133 -- purposes of legality checks and removal of ignored Ghost code.
21135 Mark_Ghost_Pragma (N, Typ);
21137 -- We require the pragma to apply to a type declared in a package
21138 -- declaration, but not (immediately) within a package body.
21140 if Ekind (Current_Scope) /= E_Package
21141 or else In_Package_Body (Current_Scope)
21144 ("pragma% can only apply to type declared immediately "
21145 & "within a package declaration");
21148 -- A simple storage pool type must be an immutably limited record
21149 -- or private type. If the pragma is given for a private type,
21150 -- the full type is similarly restricted (which is checked later
21151 -- in Freeze_Entity).
21153 if Is_Record_Type (Typ)
21154 and then not Is_Limited_View (Typ)
21157 ("pragma% can only apply to explicitly limited record type");
21159 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
21161 ("pragma% can only apply to a private type that is limited");
21163 elsif not Is_Record_Type (Typ)
21164 and then not Is_Private_Type (Typ)
21167 ("pragma% can only apply to limited record or private type");
21170 Record_Rep_Item (Typ, N);
21171 end Simple_Storage_Pool_Type;
21173 ----------------------
21174 -- Source_File_Name --
21175 ----------------------
21177 -- There are five forms for this pragma:
21179 -- pragma Source_File_Name (
21180 -- [UNIT_NAME =>] unit_NAME,
21181 -- BODY_FILE_NAME => STRING_LITERAL
21182 -- [, [INDEX =>] INTEGER_LITERAL]);
21184 -- pragma Source_File_Name (
21185 -- [UNIT_NAME =>] unit_NAME,
21186 -- SPEC_FILE_NAME => STRING_LITERAL
21187 -- [, [INDEX =>] INTEGER_LITERAL]);
21189 -- pragma Source_File_Name (
21190 -- BODY_FILE_NAME => STRING_LITERAL
21191 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21192 -- [, CASING => CASING_SPEC]);
21194 -- pragma Source_File_Name (
21195 -- SPEC_FILE_NAME => STRING_LITERAL
21196 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21197 -- [, CASING => CASING_SPEC]);
21199 -- pragma Source_File_Name (
21200 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21201 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21202 -- [, CASING => CASING_SPEC]);
21204 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21206 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21207 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21208 -- only be used when no project file is used, while SFNP can only be
21209 -- used when a project file is used.
21211 -- No processing here. Processing was completed during parsing, since
21212 -- we need to have file names set as early as possible. Units are
21213 -- loaded well before semantic processing starts.
21215 -- The only processing we defer to this point is the check for
21216 -- correct placement.
21218 when Pragma_Source_File_Name =>
21220 Check_Valid_Configuration_Pragma;
21222 ------------------------------
21223 -- Source_File_Name_Project --
21224 ------------------------------
21226 -- See Source_File_Name for syntax
21228 -- No processing here. Processing was completed during parsing, since
21229 -- we need to have file names set as early as possible. Units are
21230 -- loaded well before semantic processing starts.
21232 -- The only processing we defer to this point is the check for
21233 -- correct placement.
21235 when Pragma_Source_File_Name_Project =>
21237 Check_Valid_Configuration_Pragma;
21239 -- Check that a pragma Source_File_Name_Project is used only in a
21240 -- configuration pragmas file.
21242 -- Pragmas Source_File_Name_Project should only be generated by
21243 -- the Project Manager in configuration pragmas files.
21245 -- This is really an ugly test. It seems to depend on some
21246 -- accidental and undocumented property. At the very least it
21247 -- needs to be documented, but it would be better to have a
21248 -- clean way of testing if we are in a configuration file???
21250 if Present (Parent (N)) then
21252 ("pragma% can only appear in a configuration pragmas file");
21255 ----------------------
21256 -- Source_Reference --
21257 ----------------------
21259 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21261 -- Nothing to do, all processing completed in Par.Prag, since we need
21262 -- the information for possible parser messages that are output.
21264 when Pragma_Source_Reference =>
21271 -- pragma SPARK_Mode [(On | Off)];
21273 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
21274 Mode_Id : SPARK_Mode_Type;
21276 procedure Check_Pragma_Conformance
21277 (Context_Pragma : Node_Id;
21278 Entity : Entity_Id;
21279 Entity_Pragma : Node_Id);
21280 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21281 -- conformance of pragma N depending the following scenarios:
21283 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21284 -- compatible with the pragma Context_Pragma that was inherited
21285 -- from the context:
21286 -- * If the mode of Context_Pragma is ON, then the new mode can
21288 -- * If the mode of Context_Pragma is OFF, then the only allowed
21289 -- new mode is also OFF. Emit error if this is not the case.
21291 -- If Entity is not Empty, verify that pragma N is compatible with
21292 -- pragma Entity_Pragma that belongs to Entity.
21293 -- * If Entity_Pragma is Empty, always issue an error as this
21294 -- corresponds to the case where a previous section of Entity
21295 -- has no SPARK_Mode set.
21296 -- * If the mode of Entity_Pragma is ON, then the new mode can
21298 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21299 -- new mode is also OFF. Emit error if this is not the case.
21301 procedure Check_Library_Level_Entity (E : Entity_Id);
21302 -- Subsidiary to routines Process_xxx. Verify that the related
21303 -- entity E subject to pragma SPARK_Mode is library-level.
21305 procedure Process_Body (Decl : Node_Id);
21306 -- Verify the legality of pragma SPARK_Mode when it appears as the
21307 -- top of the body declarations of entry, package, protected unit,
21308 -- subprogram or task unit body denoted by Decl.
21310 procedure Process_Overloadable (Decl : Node_Id);
21311 -- Verify the legality of pragma SPARK_Mode when it applies to an
21312 -- entry or [generic] subprogram declaration denoted by Decl.
21314 procedure Process_Private_Part (Decl : Node_Id);
21315 -- Verify the legality of pragma SPARK_Mode when it appears at the
21316 -- top of the private declarations of a package spec, protected or
21317 -- task unit declaration denoted by Decl.
21319 procedure Process_Statement_Part (Decl : Node_Id);
21320 -- Verify the legality of pragma SPARK_Mode when it appears at the
21321 -- top of the statement sequence of a package body denoted by node
21324 procedure Process_Visible_Part (Decl : Node_Id);
21325 -- Verify the legality of pragma SPARK_Mode when it appears at the
21326 -- top of the visible declarations of a package spec, protected or
21327 -- task unit declaration denoted by Decl. The routine is also used
21328 -- on protected or task units declared without a definition.
21330 procedure Set_SPARK_Context;
21331 -- Subsidiary to routines Process_xxx. Set the global variables
21332 -- which represent the mode of the context from pragma N. Ensure
21333 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21335 ------------------------------
21336 -- Check_Pragma_Conformance --
21337 ------------------------------
21339 procedure Check_Pragma_Conformance
21340 (Context_Pragma : Node_Id;
21341 Entity : Entity_Id;
21342 Entity_Pragma : Node_Id)
21344 Err_Id : Entity_Id;
21348 -- The current pragma may appear without an argument. If this
21349 -- is the case, associate all error messages with the pragma
21352 if Present (Arg1) then
21358 -- The mode of the current pragma is compared against that of
21359 -- an enclosing context.
21361 if Present (Context_Pragma) then
21362 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
21364 -- Issue an error if the new mode is less restrictive than
21365 -- that of the context.
21367 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
21368 and then Get_SPARK_Mode_From_Annotation (N) = On
21371 ("cannot change SPARK_Mode from Off to On", Err_N);
21372 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21373 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
21378 -- The mode of the current pragma is compared against that of
21379 -- an initial package, protected type, subprogram or task type
21382 if Present (Entity) then
21384 -- A simple protected or task type is transformed into an
21385 -- anonymous type whose name cannot be used to issue error
21386 -- messages. Recover the original entity of the type.
21388 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
21391 (Original_Node (Unit_Declaration_Node (Entity)));
21396 -- Both the initial declaration and the completion carry
21397 -- SPARK_Mode pragmas.
21399 if Present (Entity_Pragma) then
21400 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
21402 -- Issue an error if the new mode is less restrictive
21403 -- than that of the initial declaration.
21405 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
21406 and then Get_SPARK_Mode_From_Annotation (N) = On
21408 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21409 Error_Msg_Sloc := Sloc (Entity_Pragma);
21411 ("\value Off was set for SPARK_Mode on&#",
21416 -- Otherwise the initial declaration lacks a SPARK_Mode
21417 -- pragma in which case the current pragma is illegal as
21418 -- it cannot "complete".
21421 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21422 Error_Msg_Sloc := Sloc (Err_Id);
21424 ("\no value was set for SPARK_Mode on&#",
21429 end Check_Pragma_Conformance;
21431 --------------------------------
21432 -- Check_Library_Level_Entity --
21433 --------------------------------
21435 procedure Check_Library_Level_Entity (E : Entity_Id) is
21436 procedure Add_Entity_To_Name_Buffer;
21437 -- Add the E_Kind of entity E to the name buffer
21439 -------------------------------
21440 -- Add_Entity_To_Name_Buffer --
21441 -------------------------------
21443 procedure Add_Entity_To_Name_Buffer is
21445 if Ekind_In (E, E_Entry, E_Entry_Family) then
21446 Add_Str_To_Name_Buffer ("entry");
21448 elsif Ekind_In (E, E_Generic_Package,
21452 Add_Str_To_Name_Buffer ("package");
21454 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
21455 Add_Str_To_Name_Buffer ("protected type");
21457 elsif Ekind_In (E, E_Function,
21458 E_Generic_Function,
21459 E_Generic_Procedure,
21463 Add_Str_To_Name_Buffer ("subprogram");
21466 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
21467 Add_Str_To_Name_Buffer ("task type");
21469 end Add_Entity_To_Name_Buffer;
21473 Msg_1 : constant String := "incorrect placement of pragma%";
21476 -- Start of processing for Check_Library_Level_Entity
21479 if not Is_Library_Level_Entity (E) then
21480 Error_Msg_Name_1 := Pname;
21481 Error_Msg_N (Fix_Error (Msg_1), N);
21484 Add_Str_To_Name_Buffer ("\& is not a library-level ");
21485 Add_Entity_To_Name_Buffer;
21487 Msg_2 := Name_Find;
21488 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
21492 end Check_Library_Level_Entity;
21498 procedure Process_Body (Decl : Node_Id) is
21499 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21500 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
21503 -- Ignore pragma when applied to the special body created for
21504 -- inlining, recognized by its internal name _Parent.
21506 if Chars (Body_Id) = Name_uParent then
21510 Check_Library_Level_Entity (Body_Id);
21512 -- For entry bodies, verify the legality against:
21513 -- * The mode of the context
21514 -- * The mode of the spec (if any)
21516 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
21518 -- A stand alone subprogram body
21520 if Body_Id = Spec_Id then
21521 Check_Pragma_Conformance
21522 (Context_Pragma => SPARK_Pragma (Body_Id),
21524 Entity_Pragma => Empty);
21526 -- An entry or subprogram body that completes a previous
21530 Check_Pragma_Conformance
21531 (Context_Pragma => SPARK_Pragma (Body_Id),
21533 Entity_Pragma => SPARK_Pragma (Spec_Id));
21537 Set_SPARK_Pragma (Body_Id, N);
21538 Set_SPARK_Pragma_Inherited (Body_Id, False);
21540 -- For package bodies, verify the legality against:
21541 -- * The mode of the context
21542 -- * The mode of the private part
21544 -- This case is separated from protected and task bodies
21545 -- because the statement part of the package body inherits
21546 -- the mode of the body declarations.
21548 elsif Nkind (Decl) = N_Package_Body then
21549 Check_Pragma_Conformance
21550 (Context_Pragma => SPARK_Pragma (Body_Id),
21552 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21555 Set_SPARK_Pragma (Body_Id, N);
21556 Set_SPARK_Pragma_Inherited (Body_Id, False);
21557 Set_SPARK_Aux_Pragma (Body_Id, N);
21558 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21560 -- For protected and task bodies, verify the legality against:
21561 -- * The mode of the context
21562 -- * The mode of the private part
21566 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21568 Check_Pragma_Conformance
21569 (Context_Pragma => SPARK_Pragma (Body_Id),
21571 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21574 Set_SPARK_Pragma (Body_Id, N);
21575 Set_SPARK_Pragma_Inherited (Body_Id, False);
21579 --------------------------
21580 -- Process_Overloadable --
21581 --------------------------
21583 procedure Process_Overloadable (Decl : Node_Id) is
21584 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21585 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21588 Check_Library_Level_Entity (Spec_Id);
21590 -- Verify the legality against:
21591 -- * The mode of the context
21593 Check_Pragma_Conformance
21594 (Context_Pragma => SPARK_Pragma (Spec_Id),
21596 Entity_Pragma => Empty);
21598 Set_SPARK_Pragma (Spec_Id, N);
21599 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21601 -- When the pragma applies to the anonymous object created for
21602 -- a single task type, decorate the type as well. This scenario
21603 -- arises when the single task type lacks a task definition,
21604 -- therefore there is no issue with respect to a potential
21605 -- pragma SPARK_Mode in the private part.
21607 -- task type Anon_Task_Typ;
21608 -- Obj : Anon_Task_Typ;
21609 -- pragma SPARK_Mode ...;
21611 if Is_Single_Task_Object (Spec_Id) then
21612 Set_SPARK_Pragma (Spec_Typ, N);
21613 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
21614 Set_SPARK_Aux_Pragma (Spec_Typ, N);
21615 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21617 end Process_Overloadable;
21619 --------------------------
21620 -- Process_Private_Part --
21621 --------------------------
21623 procedure Process_Private_Part (Decl : Node_Id) is
21624 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21627 Check_Library_Level_Entity (Spec_Id);
21629 -- Verify the legality against:
21630 -- * The mode of the visible declarations
21632 Check_Pragma_Conformance
21633 (Context_Pragma => Empty,
21635 Entity_Pragma => SPARK_Pragma (Spec_Id));
21638 Set_SPARK_Aux_Pragma (Spec_Id, N);
21639 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21640 end Process_Private_Part;
21642 ----------------------------
21643 -- Process_Statement_Part --
21644 ----------------------------
21646 procedure Process_Statement_Part (Decl : Node_Id) is
21647 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21650 Check_Library_Level_Entity (Body_Id);
21652 -- Verify the legality against:
21653 -- * The mode of the body declarations
21655 Check_Pragma_Conformance
21656 (Context_Pragma => Empty,
21658 Entity_Pragma => SPARK_Pragma (Body_Id));
21661 Set_SPARK_Aux_Pragma (Body_Id, N);
21662 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21663 end Process_Statement_Part;
21665 --------------------------
21666 -- Process_Visible_Part --
21667 --------------------------
21669 procedure Process_Visible_Part (Decl : Node_Id) is
21670 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21671 Obj_Id : Entity_Id;
21674 Check_Library_Level_Entity (Spec_Id);
21676 -- Verify the legality against:
21677 -- * The mode of the context
21679 Check_Pragma_Conformance
21680 (Context_Pragma => SPARK_Pragma (Spec_Id),
21682 Entity_Pragma => Empty);
21684 -- A task unit declared without a definition does not set the
21685 -- SPARK_Mode of the context because the task does not have any
21686 -- entries that could inherit the mode.
21688 if not Nkind_In (Decl, N_Single_Task_Declaration,
21689 N_Task_Type_Declaration)
21694 Set_SPARK_Pragma (Spec_Id, N);
21695 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21696 Set_SPARK_Aux_Pragma (Spec_Id, N);
21697 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21699 -- When the pragma applies to a single protected or task type,
21700 -- decorate the corresponding anonymous object as well.
21702 -- protected Anon_Prot_Typ is
21703 -- pragma SPARK_Mode ...;
21705 -- end Anon_Prot_Typ;
21707 -- Obj : Anon_Prot_Typ;
21709 if Is_Single_Concurrent_Type (Spec_Id) then
21710 Obj_Id := Anonymous_Object (Spec_Id);
21712 Set_SPARK_Pragma (Obj_Id, N);
21713 Set_SPARK_Pragma_Inherited (Obj_Id, False);
21715 end Process_Visible_Part;
21717 -----------------------
21718 -- Set_SPARK_Context --
21719 -----------------------
21721 procedure Set_SPARK_Context is
21723 SPARK_Mode := Mode_Id;
21724 SPARK_Mode_Pragma := N;
21725 end Set_SPARK_Context;
21733 -- Start of processing for Do_SPARK_Mode
21736 -- When a SPARK_Mode pragma appears inside an instantiation whose
21737 -- enclosing context has SPARK_Mode set to "off", the pragma has
21738 -- no semantic effect.
21740 if Ignore_SPARK_Mode_Pragmas_In_Instance then
21741 Rewrite (N, Make_Null_Statement (Loc));
21747 Check_No_Identifiers;
21748 Check_At_Most_N_Arguments (1);
21750 -- Check the legality of the mode (no argument = ON)
21752 if Arg_Count = 1 then
21753 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21754 Mode := Chars (Get_Pragma_Arg (Arg1));
21759 Mode_Id := Get_SPARK_Mode_Type (Mode);
21760 Context := Parent (N);
21762 -- The pragma appears in a configuration file
21764 if No (Context) then
21765 Check_Valid_Configuration_Pragma;
21767 if Present (SPARK_Mode_Pragma) then
21770 Prev => SPARK_Mode_Pragma);
21776 -- The pragma acts as a configuration pragma in a compilation unit
21778 -- pragma SPARK_Mode ...;
21779 -- package Pack is ...;
21781 elsif Nkind (Context) = N_Compilation_Unit
21782 and then List_Containing (N) = Context_Items (Context)
21784 Check_Valid_Configuration_Pragma;
21787 -- Otherwise the placement of the pragma within the tree dictates
21788 -- its associated construct. Inspect the declarative list where
21789 -- the pragma resides to find a potential construct.
21793 while Present (Stmt) loop
21795 -- Skip prior pragmas, but check for duplicates. Note that
21796 -- this also takes care of pragmas generated for aspects.
21798 if Nkind (Stmt) = N_Pragma then
21799 if Pragma_Name (Stmt) = Pname then
21806 -- The pragma applies to an expression function that has
21807 -- already been rewritten into a subprogram declaration.
21809 -- function Expr_Func return ... is (...);
21810 -- pragma SPARK_Mode ...;
21812 elsif Nkind (Stmt) = N_Subprogram_Declaration
21813 and then Nkind (Original_Node (Stmt)) =
21814 N_Expression_Function
21816 Process_Overloadable (Stmt);
21819 -- The pragma applies to the anonymous object created for a
21820 -- single concurrent type.
21822 -- protected type Anon_Prot_Typ ...;
21823 -- Obj : Anon_Prot_Typ;
21824 -- pragma SPARK_Mode ...;
21826 elsif Nkind (Stmt) = N_Object_Declaration
21827 and then Is_Single_Concurrent_Object
21828 (Defining_Entity (Stmt))
21830 Process_Overloadable (Stmt);
21833 -- Skip internally generated code
21835 elsif not Comes_From_Source (Stmt) then
21838 -- The pragma applies to an entry or [generic] subprogram
21842 -- pragma SPARK_Mode ...;
21845 -- procedure Proc ...;
21846 -- pragma SPARK_Mode ...;
21848 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21849 N_Subprogram_Declaration)
21850 or else (Nkind (Stmt) = N_Entry_Declaration
21851 and then Is_Protected_Type
21852 (Scope (Defining_Entity (Stmt))))
21854 Process_Overloadable (Stmt);
21857 -- Otherwise the pragma does not apply to a legal construct
21858 -- or it does not appear at the top of a declarative or a
21859 -- statement list. Issue an error and stop the analysis.
21869 -- The pragma applies to a package or a subprogram that acts as
21870 -- a compilation unit.
21872 -- procedure Proc ...;
21873 -- pragma SPARK_Mode ...;
21875 if Nkind (Context) = N_Compilation_Unit_Aux then
21876 Context := Unit (Parent (Context));
21879 -- The pragma appears at the top of entry, package, protected
21880 -- unit, subprogram or task unit body declarations.
21882 -- entry Ent when ... is
21883 -- pragma SPARK_Mode ...;
21885 -- package body Pack is
21886 -- pragma SPARK_Mode ...;
21888 -- procedure Proc ... is
21889 -- pragma SPARK_Mode;
21891 -- protected body Prot is
21892 -- pragma SPARK_Mode ...;
21894 if Nkind_In (Context, N_Entry_Body,
21900 Process_Body (Context);
21902 -- The pragma appears at the top of the visible or private
21903 -- declaration of a package spec, protected or task unit.
21906 -- pragma SPARK_Mode ...;
21908 -- pragma SPARK_Mode ...;
21910 -- protected [type] Prot is
21911 -- pragma SPARK_Mode ...;
21913 -- pragma SPARK_Mode ...;
21915 elsif Nkind_In (Context, N_Package_Specification,
21916 N_Protected_Definition,
21919 if List_Containing (N) = Visible_Declarations (Context) then
21920 Process_Visible_Part (Parent (Context));
21922 Process_Private_Part (Parent (Context));
21925 -- The pragma appears at the top of package body statements
21927 -- package body Pack is
21929 -- pragma SPARK_Mode;
21931 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21932 and then Nkind (Parent (Context)) = N_Package_Body
21934 Process_Statement_Part (Parent (Context));
21936 -- The pragma appeared as an aspect of a [generic] subprogram
21937 -- declaration that acts as a compilation unit.
21940 -- procedure Proc ...;
21941 -- pragma SPARK_Mode ...;
21943 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21944 N_Subprogram_Declaration)
21946 Process_Overloadable (Context);
21948 -- The pragma does not apply to a legal construct, issue error
21956 --------------------------------
21957 -- Static_Elaboration_Desired --
21958 --------------------------------
21960 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21962 when Pragma_Static_Elaboration_Desired =>
21964 Check_At_Most_N_Arguments (1);
21966 if Is_Compilation_Unit (Current_Scope)
21967 and then Ekind (Current_Scope) = E_Package
21969 Set_Static_Elaboration_Desired (Current_Scope, True);
21971 Error_Pragma ("pragma% must apply to a library-level package");
21978 -- pragma Storage_Size (EXPRESSION);
21980 when Pragma_Storage_Size => Storage_Size : declare
21981 P : constant Node_Id := Parent (N);
21985 Check_No_Identifiers;
21986 Check_Arg_Count (1);
21988 -- The expression must be analyzed in the special manner described
21989 -- in "Handling of Default Expressions" in sem.ads.
21991 Arg := Get_Pragma_Arg (Arg1);
21992 Preanalyze_Spec_Expression (Arg, Any_Integer);
21994 if not Is_OK_Static_Expression (Arg) then
21995 Check_Restriction (Static_Storage_Size, Arg);
21998 if Nkind (P) /= N_Task_Definition then
22003 if Has_Storage_Size_Pragma (P) then
22004 Error_Pragma ("duplicate pragma% not allowed");
22006 Set_Has_Storage_Size_Pragma (P, True);
22009 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
22017 -- pragma Storage_Unit (NUMERIC_LITERAL);
22019 -- Only permitted argument is System'Storage_Unit value
22021 when Pragma_Storage_Unit =>
22022 Check_No_Identifiers;
22023 Check_Arg_Count (1);
22024 Check_Arg_Is_Integer_Literal (Arg1);
22026 if Intval (Get_Pragma_Arg (Arg1)) /=
22027 UI_From_Int (Ttypes.System_Storage_Unit)
22029 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
22031 ("the only allowed argument for pragma% is ^", Arg1);
22034 --------------------
22035 -- Stream_Convert --
22036 --------------------
22038 -- pragma Stream_Convert (
22039 -- [Entity =>] type_LOCAL_NAME,
22040 -- [Read =>] function_NAME,
22041 -- [Write =>] function NAME);
22043 when Pragma_Stream_Convert => Stream_Convert : declare
22044 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
22045 -- Check that the given argument is the name of a local function
22046 -- of one argument that is not overloaded earlier in the current
22047 -- local scope. A check is also made that the argument is a
22048 -- function with one parameter.
22050 --------------------------------------
22051 -- Check_OK_Stream_Convert_Function --
22052 --------------------------------------
22054 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
22058 Check_Arg_Is_Local_Name (Arg);
22059 Ent := Entity (Get_Pragma_Arg (Arg));
22061 if Has_Homonym (Ent) then
22063 ("argument for pragma% may not be overloaded", Arg);
22066 if Ekind (Ent) /= E_Function
22067 or else No (First_Formal (Ent))
22068 or else Present (Next_Formal (First_Formal (Ent)))
22071 ("argument for pragma% must be function of one argument",
22074 end Check_OK_Stream_Convert_Function;
22076 -- Start of processing for Stream_Convert
22080 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
22081 Check_Arg_Count (3);
22082 Check_Optional_Identifier (Arg1, Name_Entity);
22083 Check_Optional_Identifier (Arg2, Name_Read);
22084 Check_Optional_Identifier (Arg3, Name_Write);
22085 Check_Arg_Is_Local_Name (Arg1);
22086 Check_OK_Stream_Convert_Function (Arg2);
22087 Check_OK_Stream_Convert_Function (Arg3);
22090 Typ : constant Entity_Id :=
22091 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
22092 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
22093 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
22096 Check_First_Subtype (Arg1);
22098 -- Check for too early or too late. Note that we don't enforce
22099 -- the rule about primitive operations in this case, since, as
22100 -- is the case for explicit stream attributes themselves, these
22101 -- restrictions are not appropriate. Note that the chaining of
22102 -- the pragma by Rep_Item_Too_Late is actually the critical
22103 -- processing done for this pragma.
22105 if Rep_Item_Too_Early (Typ, N)
22107 Rep_Item_Too_Late (Typ, N, FOnly => True)
22112 -- Return if previous error
22114 if Etype (Typ) = Any_Type
22116 Etype (Read) = Any_Type
22118 Etype (Write) = Any_Type
22125 if Underlying_Type (Etype (Read)) /= Typ then
22127 ("incorrect return type for function&", Arg2);
22130 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
22132 ("incorrect parameter type for function&", Arg3);
22135 if Underlying_Type (Etype (First_Formal (Read))) /=
22136 Underlying_Type (Etype (Write))
22139 ("result type of & does not match Read parameter type",
22143 end Stream_Convert;
22149 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22151 -- This is processed by the parser since some of the style checks
22152 -- take place during source scanning and parsing. This means that
22153 -- we don't need to issue error messages here.
22155 when Pragma_Style_Checks => Style_Checks : declare
22156 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22162 Check_No_Identifiers;
22164 -- Two argument form
22166 if Arg_Count = 2 then
22167 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22174 E_Id := Get_Pragma_Arg (Arg2);
22177 if not Is_Entity_Name (E_Id) then
22179 ("second argument of pragma% must be entity name",
22183 E := Entity (E_Id);
22185 if not Ignore_Style_Checks_Pragmas then
22190 Set_Suppress_Style_Checks
22191 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
22192 exit when No (Homonym (E));
22199 -- One argument form
22202 Check_Arg_Count (1);
22204 if Nkind (A) = N_String_Literal then
22208 Slen : constant Natural := Natural (String_Length (S));
22209 Options : String (1 .. Slen);
22215 C := Get_String_Char (S, Pos (J));
22216 exit when not In_Character_Range (C);
22217 Options (J) := Get_Character (C);
22219 -- If at end of string, set options. As per discussion
22220 -- above, no need to check for errors, since we issued
22221 -- them in the parser.
22224 if not Ignore_Style_Checks_Pragmas then
22225 Set_Style_Check_Options (Options);
22235 elsif Nkind (A) = N_Identifier then
22236 if Chars (A) = Name_All_Checks then
22237 if not Ignore_Style_Checks_Pragmas then
22239 Set_GNAT_Style_Check_Options;
22241 Set_Default_Style_Check_Options;
22245 elsif Chars (A) = Name_On then
22246 if not Ignore_Style_Checks_Pragmas then
22247 Style_Check := True;
22250 elsif Chars (A) = Name_Off then
22251 if not Ignore_Style_Checks_Pragmas then
22252 Style_Check := False;
22263 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22265 when Pragma_Subtitle =>
22267 Check_Arg_Count (1);
22268 Check_Optional_Identifier (Arg1, Name_Subtitle);
22269 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22276 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22278 when Pragma_Suppress =>
22279 Process_Suppress_Unsuppress (Suppress_Case => True);
22285 -- pragma Suppress_All;
22287 -- The only check made here is that the pragma has no arguments.
22288 -- There are no placement rules, and the processing required (setting
22289 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22290 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22291 -- then creates and inserts a pragma Suppress (All_Checks).
22293 when Pragma_Suppress_All =>
22295 Check_Arg_Count (0);
22297 -------------------------
22298 -- Suppress_Debug_Info --
22299 -------------------------
22301 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22303 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
22304 Nam_Id : Entity_Id;
22308 Check_Arg_Count (1);
22309 Check_Optional_Identifier (Arg1, Name_Entity);
22310 Check_Arg_Is_Local_Name (Arg1);
22312 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
22314 -- A pragma that applies to a Ghost entity becomes Ghost for the
22315 -- purposes of legality checks and removal of ignored Ghost code.
22317 Mark_Ghost_Pragma (N, Nam_Id);
22318 Set_Debug_Info_Off (Nam_Id);
22319 end Suppress_Debug_Info;
22321 ----------------------------------
22322 -- Suppress_Exception_Locations --
22323 ----------------------------------
22325 -- pragma Suppress_Exception_Locations;
22327 when Pragma_Suppress_Exception_Locations =>
22329 Check_Arg_Count (0);
22330 Check_Valid_Configuration_Pragma;
22331 Exception_Locations_Suppressed := True;
22333 -----------------------------
22334 -- Suppress_Initialization --
22335 -----------------------------
22337 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22339 when Pragma_Suppress_Initialization => Suppress_Init : declare
22345 Check_Arg_Count (1);
22346 Check_Optional_Identifier (Arg1, Name_Entity);
22347 Check_Arg_Is_Local_Name (Arg1);
22349 E_Id := Get_Pragma_Arg (Arg1);
22351 if Etype (E_Id) = Any_Type then
22355 E := Entity (E_Id);
22357 -- A pragma that applies to a Ghost entity becomes Ghost for the
22358 -- purposes of legality checks and removal of ignored Ghost code.
22360 Mark_Ghost_Pragma (N, E);
22362 if not Is_Type (E) and then Ekind (E) /= E_Variable then
22364 ("pragma% requires variable, type or subtype", Arg1);
22367 if Rep_Item_Too_Early (E, N)
22369 Rep_Item_Too_Late (E, N, FOnly => True)
22374 -- For incomplete/private type, set flag on full view
22376 if Is_Incomplete_Or_Private_Type (E) then
22377 if No (Full_View (Base_Type (E))) then
22379 ("argument of pragma% cannot be an incomplete type", Arg1);
22381 Set_Suppress_Initialization (Full_View (Base_Type (E)));
22384 -- For first subtype, set flag on base type
22386 elsif Is_First_Subtype (E) then
22387 Set_Suppress_Initialization (Base_Type (E));
22389 -- For other than first subtype, set flag on subtype or variable
22392 Set_Suppress_Initialization (E);
22400 -- pragma System_Name (DIRECT_NAME);
22402 -- Syntax check: one argument, which must be the identifier GNAT or
22403 -- the identifier GCC, no other identifiers are acceptable.
22405 when Pragma_System_Name =>
22407 Check_No_Identifiers;
22408 Check_Arg_Count (1);
22409 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
22411 -----------------------------
22412 -- Task_Dispatching_Policy --
22413 -----------------------------
22415 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22417 when Pragma_Task_Dispatching_Policy => declare
22421 Check_Ada_83_Warning;
22422 Check_Arg_Count (1);
22423 Check_No_Identifiers;
22424 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
22425 Check_Valid_Configuration_Pragma;
22426 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22427 DP := Fold_Upper (Name_Buffer (1));
22429 if Task_Dispatching_Policy /= ' '
22430 and then Task_Dispatching_Policy /= DP
22432 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
22434 ("task dispatching policy incompatible with policy#");
22436 -- Set new policy, but always preserve System_Location since we
22437 -- like the error message with the run time name.
22440 Task_Dispatching_Policy := DP;
22442 if Task_Dispatching_Policy_Sloc /= System_Location then
22443 Task_Dispatching_Policy_Sloc := Loc;
22452 -- pragma Task_Info (EXPRESSION);
22454 when Pragma_Task_Info => Task_Info : declare
22455 P : constant Node_Id := Parent (N);
22461 if Warn_On_Obsolescent_Feature then
22463 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22464 & "instead?j?", N);
22467 if Nkind (P) /= N_Task_Definition then
22468 Error_Pragma ("pragma% must appear in task definition");
22471 Check_No_Identifiers;
22472 Check_Arg_Count (1);
22474 Analyze_And_Resolve
22475 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
22477 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
22481 Ent := Defining_Identifier (Parent (P));
22483 -- Check duplicate pragma before we chain the pragma in the Rep
22484 -- Item chain of Ent.
22487 (Ent, Name_Task_Info, Check_Parents => False)
22489 Error_Pragma ("duplicate pragma% not allowed");
22492 Record_Rep_Item (Ent, N);
22499 -- pragma Task_Name (string_EXPRESSION);
22501 when Pragma_Task_Name => Task_Name : declare
22502 P : constant Node_Id := Parent (N);
22507 Check_No_Identifiers;
22508 Check_Arg_Count (1);
22510 Arg := Get_Pragma_Arg (Arg1);
22512 -- The expression is used in the call to Create_Task, and must be
22513 -- expanded there, not in the context of the current spec. It must
22514 -- however be analyzed to capture global references, in case it
22515 -- appears in a generic context.
22517 Preanalyze_And_Resolve (Arg, Standard_String);
22519 if Nkind (P) /= N_Task_Definition then
22523 Ent := Defining_Identifier (Parent (P));
22525 -- Check duplicate pragma before we chain the pragma in the Rep
22526 -- Item chain of Ent.
22529 (Ent, Name_Task_Name, Check_Parents => False)
22531 Error_Pragma ("duplicate pragma% not allowed");
22534 Record_Rep_Item (Ent, N);
22541 -- pragma Task_Storage (
22542 -- [Task_Type =>] LOCAL_NAME,
22543 -- [Top_Guard =>] static_integer_EXPRESSION);
22545 when Pragma_Task_Storage => Task_Storage : declare
22546 Args : Args_List (1 .. 2);
22547 Names : constant Name_List (1 .. 2) := (
22551 Task_Type : Node_Id renames Args (1);
22552 Top_Guard : Node_Id renames Args (2);
22558 Gather_Associations (Names, Args);
22560 if No (Task_Type) then
22562 ("missing task_type argument for pragma%");
22565 Check_Arg_Is_Local_Name (Task_Type);
22567 Ent := Entity (Task_Type);
22569 if not Is_Task_Type (Ent) then
22571 ("argument for pragma% must be task type", Task_Type);
22574 if No (Top_Guard) then
22576 ("pragma% takes two arguments", Task_Type);
22578 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22581 Check_First_Subtype (Task_Type);
22583 if Rep_Item_Too_Late (Ent, N) then
22592 -- pragma Test_Case
22593 -- ([Name =>] Static_String_EXPRESSION
22594 -- ,[Mode =>] MODE_TYPE
22595 -- [, Requires => Boolean_EXPRESSION]
22596 -- [, Ensures => Boolean_EXPRESSION]);
22598 -- MODE_TYPE ::= Nominal | Robustness
22600 -- Characteristics:
22602 -- * Analysis - The annotation undergoes initial checks to verify
22603 -- the legal placement and context. Secondary checks preanalyze the
22606 -- Analyze_Test_Case_In_Decl_Part
22608 -- * Expansion - None.
22610 -- * Template - The annotation utilizes the generic template of the
22611 -- related subprogram when it is:
22613 -- aspect on subprogram declaration
22615 -- The annotation must prepare its own template when it is:
22617 -- pragma on subprogram declaration
22619 -- * Globals - Capture of global references must occur after full
22622 -- * Instance - The annotation is instantiated automatically when
22623 -- the related generic subprogram is instantiated except for the
22624 -- "pragma on subprogram declaration" case. In that scenario the
22625 -- annotation must instantiate itself.
22627 when Pragma_Test_Case => Test_Case : declare
22628 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22629 -- Ensure that the contract of subprogram Subp_Id does not contain
22630 -- another Test_Case pragma with the same Name as the current one.
22632 -------------------------
22633 -- Check_Distinct_Name --
22634 -------------------------
22636 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22637 Items : constant Node_Id := Contract (Subp_Id);
22638 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
22642 -- Inspect all Test_Case pragma of the related subprogram
22643 -- looking for one with a duplicate "Name" argument.
22645 if Present (Items) then
22646 Prag := Contract_Test_Cases (Items);
22647 while Present (Prag) loop
22648 if Pragma_Name (Prag) = Name_Test_Case
22650 and then String_Equal
22651 (Name, Get_Name_From_CTC_Pragma (Prag))
22653 Error_Msg_Sloc := Sloc (Prag);
22654 Error_Pragma ("name for pragma % is already used #");
22657 Prag := Next_Pragma (Prag);
22660 end Check_Distinct_Name;
22664 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22667 Subp_Decl : Node_Id;
22668 Subp_Id : Entity_Id;
22670 -- Start of processing for Test_Case
22674 Check_At_Least_N_Arguments (2);
22675 Check_At_Most_N_Arguments (4);
22677 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22681 Check_Optional_Identifier (Arg1, Name_Name);
22682 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22686 Check_Optional_Identifier (Arg2, Name_Mode);
22687 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22689 -- Arguments "Requires" and "Ensures"
22691 if Present (Arg3) then
22692 if Present (Arg4) then
22693 Check_Identifier (Arg3, Name_Requires);
22694 Check_Identifier (Arg4, Name_Ensures);
22696 Check_Identifier_Is_One_Of
22697 (Arg3, Name_Requires, Name_Ensures);
22701 -- Pragma Test_Case must be associated with a subprogram declared
22702 -- in a library-level package. First determine whether the current
22703 -- compilation unit is a legal context.
22705 if Nkind_In (Pack_Decl, N_Package_Declaration,
22706 N_Generic_Package_Declaration)
22710 -- Otherwise the placement is illegal
22714 ("pragma % must be specified within a package declaration");
22718 Subp_Decl := Find_Related_Declaration_Or_Body (N);
22720 -- Find the enclosing context
22722 Context := Parent (Subp_Decl);
22724 if Present (Context) then
22725 Context := Parent (Context);
22728 -- Verify the placement of the pragma
22730 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22732 ("pragma % cannot be applied to abstract subprogram");
22735 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22736 Error_Pragma ("pragma % cannot be applied to entry");
22739 -- The context is a [generic] subprogram declared at the top level
22740 -- of the [generic] package unit.
22742 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22743 N_Subprogram_Declaration)
22744 and then Present (Context)
22745 and then Nkind_In (Context, N_Generic_Package_Declaration,
22746 N_Package_Declaration)
22750 -- Otherwise the placement is illegal
22754 ("pragma % must be applied to a library-level subprogram "
22759 Subp_Id := Defining_Entity (Subp_Decl);
22761 -- A pragma that applies to a Ghost entity becomes Ghost for the
22762 -- purposes of legality checks and removal of ignored Ghost code.
22764 Mark_Ghost_Pragma (N, Subp_Id);
22766 -- Chain the pragma on the contract for further processing by
22767 -- Analyze_Test_Case_In_Decl_Part.
22769 Add_Contract_Item (N, Subp_Id);
22771 -- Preanalyze the original aspect argument "Name" for ASIS or for
22772 -- a generic subprogram to properly capture global references.
22774 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22775 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22777 if Present (Asp_Arg) then
22779 -- The argument appears with an identifier in association
22782 if Nkind (Asp_Arg) = N_Component_Association then
22783 Asp_Arg := Expression (Asp_Arg);
22786 Check_Expr_Is_OK_Static_Expression
22787 (Asp_Arg, Standard_String);
22791 -- Ensure that the all Test_Case pragmas of the related subprogram
22792 -- have distinct names.
22794 Check_Distinct_Name (Subp_Id);
22796 -- Fully analyze the pragma when it appears inside an entry
22797 -- or subprogram body because it cannot benefit from forward
22800 if Nkind_In (Subp_Decl, N_Entry_Body,
22802 N_Subprogram_Body_Stub)
22804 -- The legality checks of pragma Test_Case are affected by the
22805 -- SPARK mode in effect and the volatility of the context.
22806 -- Analyze all pragmas in a specific order.
22808 Analyze_If_Present (Pragma_SPARK_Mode);
22809 Analyze_If_Present (Pragma_Volatile_Function);
22810 Analyze_Test_Case_In_Decl_Part (N);
22814 --------------------------
22815 -- Thread_Local_Storage --
22816 --------------------------
22818 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22820 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22826 Check_Arg_Count (1);
22827 Check_Optional_Identifier (Arg1, Name_Entity);
22828 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22830 Id := Get_Pragma_Arg (Arg1);
22833 if not Is_Entity_Name (Id)
22834 or else Ekind (Entity (Id)) /= E_Variable
22836 Error_Pragma_Arg ("local variable name required", Arg1);
22841 -- A pragma that applies to a Ghost entity becomes Ghost for the
22842 -- purposes of legality checks and removal of ignored Ghost code.
22844 Mark_Ghost_Pragma (N, E);
22846 if Rep_Item_Too_Early (E, N)
22848 Rep_Item_Too_Late (E, N)
22853 Set_Has_Pragma_Thread_Local_Storage (E);
22854 Set_Has_Gigi_Rep_Item (E);
22855 end Thread_Local_Storage;
22861 -- pragma Time_Slice (static_duration_EXPRESSION);
22863 when Pragma_Time_Slice => Time_Slice : declare
22869 Check_Arg_Count (1);
22870 Check_No_Identifiers;
22871 Check_In_Main_Program;
22872 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22874 if not Error_Posted (Arg1) then
22876 while Present (Nod) loop
22877 if Nkind (Nod) = N_Pragma
22878 and then Pragma_Name (Nod) = Name_Time_Slice
22880 Error_Msg_Name_1 := Pname;
22881 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22888 -- Process only if in main unit
22890 if Get_Source_Unit (Loc) = Main_Unit then
22891 Opt.Time_Slice_Set := True;
22892 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22894 if Val <= Ureal_0 then
22895 Opt.Time_Slice_Value := 0;
22897 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22898 Opt.Time_Slice_Value := 1_000_000_000;
22901 Opt.Time_Slice_Value :=
22902 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22911 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22913 -- TITLING_OPTION ::=
22914 -- [Title =>] STRING_LITERAL
22915 -- | [Subtitle =>] STRING_LITERAL
22917 when Pragma_Title => Title : declare
22918 Args : Args_List (1 .. 2);
22919 Names : constant Name_List (1 .. 2) := (
22925 Gather_Associations (Names, Args);
22928 for J in 1 .. 2 loop
22929 if Present (Args (J)) then
22930 Check_Arg_Is_OK_Static_Expression
22931 (Args (J), Standard_String);
22936 ----------------------------
22937 -- Type_Invariant[_Class] --
22938 ----------------------------
22940 -- pragma Type_Invariant[_Class]
22941 -- ([Entity =>] type_LOCAL_NAME,
22942 -- [Check =>] EXPRESSION);
22944 when Pragma_Type_Invariant
22945 | Pragma_Type_Invariant_Class
22947 Type_Invariant : declare
22948 I_Pragma : Node_Id;
22951 Check_Arg_Count (2);
22953 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22954 -- setting Class_Present for the Type_Invariant_Class case.
22956 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22957 I_Pragma := New_Copy (N);
22958 Set_Pragma_Identifier
22959 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22960 Rewrite (N, I_Pragma);
22961 Set_Analyzed (N, False);
22963 end Type_Invariant;
22965 ---------------------
22966 -- Unchecked_Union --
22967 ---------------------
22969 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22971 when Pragma_Unchecked_Union => Unchecked_Union : declare
22972 Assoc : constant Node_Id := Arg1;
22973 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22983 Check_No_Identifiers;
22984 Check_Arg_Count (1);
22985 Check_Arg_Is_Local_Name (Arg1);
22987 Find_Type (Type_Id);
22989 Typ := Entity (Type_Id);
22991 -- A pragma that applies to a Ghost entity becomes Ghost for the
22992 -- purposes of legality checks and removal of ignored Ghost code.
22994 Mark_Ghost_Pragma (N, Typ);
22997 or else Rep_Item_Too_Early (Typ, N)
23001 Typ := Underlying_Type (Typ);
23004 if Rep_Item_Too_Late (Typ, N) then
23008 Check_First_Subtype (Arg1);
23010 -- Note remaining cases are references to a type in the current
23011 -- declarative part. If we find an error, we post the error on
23012 -- the relevant type declaration at an appropriate point.
23014 if not Is_Record_Type (Typ) then
23015 Error_Msg_N ("unchecked union must be record type", Typ);
23018 elsif Is_Tagged_Type (Typ) then
23019 Error_Msg_N ("unchecked union must not be tagged", Typ);
23022 elsif not Has_Discriminants (Typ) then
23024 ("unchecked union must have one discriminant", Typ);
23027 -- Note: in previous versions of GNAT we used to check for limited
23028 -- types and give an error, but in fact the standard does allow
23029 -- Unchecked_Union on limited types, so this check was removed.
23031 -- Similarly, GNAT used to require that all discriminants have
23032 -- default values, but this is not mandated by the RM.
23034 -- Proceed with basic error checks completed
23037 Tdef := Type_Definition (Declaration_Node (Typ));
23038 Clist := Component_List (Tdef);
23040 -- Check presence of component list and variant part
23042 if No (Clist) or else No (Variant_Part (Clist)) then
23044 ("unchecked union must have variant part", Tdef);
23048 -- Check components
23050 Comp := First (Component_Items (Clist));
23051 while Present (Comp) loop
23052 Check_Component (Comp, Typ);
23056 -- Check variant part
23058 Vpart := Variant_Part (Clist);
23060 Variant := First (Variants (Vpart));
23061 while Present (Variant) loop
23062 Check_Variant (Variant, Typ);
23067 Set_Is_Unchecked_Union (Typ);
23068 Set_Convention (Typ, Convention_C);
23069 Set_Has_Unchecked_Union (Base_Type (Typ));
23070 Set_Is_Unchecked_Union (Base_Type (Typ));
23071 end Unchecked_Union;
23073 ----------------------------
23074 -- Unevaluated_Use_Of_Old --
23075 ----------------------------
23077 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23079 when Pragma_Unevaluated_Use_Of_Old =>
23081 Check_Arg_Count (1);
23082 Check_No_Identifiers;
23083 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
23085 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23086 -- a declarative part or a package spec.
23088 if not Is_Configuration_Pragma then
23089 Check_Is_In_Decl_Part_Or_Package_Spec;
23092 -- Store proper setting of Uneval_Old
23094 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23095 Uneval_Old := Fold_Upper (Name_Buffer (1));
23097 ------------------------
23098 -- Unimplemented_Unit --
23099 ------------------------
23101 -- pragma Unimplemented_Unit;
23103 -- Note: this only gives an error if we are generating code, or if
23104 -- we are in a generic library unit (where the pragma appears in the
23105 -- body, not in the spec).
23107 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
23108 Cunitent : constant Entity_Id :=
23109 Cunit_Entity (Get_Source_Unit (Loc));
23110 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
23114 Check_Arg_Count (0);
23116 if Operating_Mode = Generate_Code
23117 or else Ent_Kind = E_Generic_Function
23118 or else Ent_Kind = E_Generic_Procedure
23119 or else Ent_Kind = E_Generic_Package
23121 Get_Name_String (Chars (Cunitent));
23122 Set_Casing (Mixed_Case);
23123 Write_Str (Name_Buffer (1 .. Name_Len));
23124 Write_Str (" is not supported in this configuration");
23126 raise Unrecoverable_Error;
23128 end Unimplemented_Unit;
23130 ------------------------
23131 -- Universal_Aliasing --
23132 ------------------------
23134 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23136 when Pragma_Universal_Aliasing => Universal_Alias : declare
23141 Check_Arg_Count (1);
23142 Check_Optional_Identifier (Arg2, Name_Entity);
23143 Check_Arg_Is_Local_Name (Arg1);
23144 E_Id := Entity (Get_Pragma_Arg (Arg1));
23146 if E_Id = Any_Type then
23148 elsif No (E_Id) or else not Is_Type (E_Id) then
23149 Error_Pragma_Arg ("pragma% requires type", Arg1);
23152 -- A pragma that applies to a Ghost entity becomes Ghost for the
23153 -- purposes of legality checks and removal of ignored Ghost code.
23155 Mark_Ghost_Pragma (N, E_Id);
23156 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
23157 Record_Rep_Item (E_Id, N);
23158 end Universal_Alias;
23160 --------------------
23161 -- Universal_Data --
23162 --------------------
23164 -- pragma Universal_Data [(library_unit_NAME)];
23166 when Pragma_Universal_Data =>
23168 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
23174 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23176 when Pragma_Unmodified =>
23177 Analyze_Unmodified_Or_Unused;
23183 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23185 -- or when used in a context clause:
23187 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23189 when Pragma_Unreferenced =>
23190 Analyze_Unreferenced_Or_Unused;
23192 --------------------------
23193 -- Unreferenced_Objects --
23194 --------------------------
23196 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23198 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
23200 Arg_Expr : Node_Id;
23201 Arg_Id : Entity_Id;
23203 Ghost_Error_Posted : Boolean := False;
23204 -- Flag set when an error concerning the illegal mix of Ghost and
23205 -- non-Ghost types is emitted.
23207 Ghost_Id : Entity_Id := Empty;
23208 -- The entity of the first Ghost type encountered while processing
23209 -- the arguments of the pragma.
23213 Check_At_Least_N_Arguments (1);
23216 while Present (Arg) loop
23217 Check_No_Identifier (Arg);
23218 Check_Arg_Is_Local_Name (Arg);
23219 Arg_Expr := Get_Pragma_Arg (Arg);
23221 if Is_Entity_Name (Arg_Expr) then
23222 Arg_Id := Entity (Arg_Expr);
23224 if Is_Type (Arg_Id) then
23225 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
23227 -- A pragma that applies to a Ghost entity becomes Ghost
23228 -- for the purposes of legality checks and removal of
23229 -- ignored Ghost code.
23231 Mark_Ghost_Pragma (N, Arg_Id);
23233 -- Capture the entity of the first Ghost type being
23234 -- processed for error detection purposes.
23236 if Is_Ghost_Entity (Arg_Id) then
23237 if No (Ghost_Id) then
23238 Ghost_Id := Arg_Id;
23241 -- Otherwise the type is non-Ghost. It is illegal to mix
23242 -- references to Ghost and non-Ghost entities
23245 elsif Present (Ghost_Id)
23246 and then not Ghost_Error_Posted
23248 Ghost_Error_Posted := True;
23250 Error_Msg_Name_1 := Pname;
23252 ("pragma % cannot mention ghost and non-ghost types",
23255 Error_Msg_Sloc := Sloc (Ghost_Id);
23256 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
23258 Error_Msg_Sloc := Sloc (Arg_Id);
23259 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
23263 ("argument for pragma% must be type or subtype", Arg);
23267 ("argument for pragma% must be type or subtype", Arg);
23272 end Unreferenced_Objects;
23274 ------------------------------
23275 -- Unreserve_All_Interrupts --
23276 ------------------------------
23278 -- pragma Unreserve_All_Interrupts;
23280 when Pragma_Unreserve_All_Interrupts =>
23282 Check_Arg_Count (0);
23284 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
23285 Unreserve_All_Interrupts := True;
23292 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23294 when Pragma_Unsuppress =>
23296 Process_Suppress_Unsuppress (Suppress_Case => False);
23302 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23304 when Pragma_Unused =>
23305 Analyze_Unmodified_Or_Unused (Is_Unused => True);
23306 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
23308 -------------------
23309 -- Use_VADS_Size --
23310 -------------------
23312 -- pragma Use_VADS_Size;
23314 when Pragma_Use_VADS_Size =>
23316 Check_Arg_Count (0);
23317 Check_Valid_Configuration_Pragma;
23318 Use_VADS_Size := True;
23320 ---------------------
23321 -- Validity_Checks --
23322 ---------------------
23324 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23326 when Pragma_Validity_Checks => Validity_Checks : declare
23327 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23333 Check_Arg_Count (1);
23334 Check_No_Identifiers;
23336 -- Pragma always active unless in CodePeer or GNATprove modes,
23337 -- which use a fixed configuration of validity checks.
23339 if not (CodePeer_Mode or GNATprove_Mode) then
23340 if Nkind (A) = N_String_Literal then
23344 Slen : constant Natural := Natural (String_Length (S));
23345 Options : String (1 .. Slen);
23349 -- Couldn't we use a for loop here over Options'Range???
23353 C := Get_String_Char (S, Pos (J));
23355 -- This is a weird test, it skips setting validity
23356 -- checks entirely if any element of S is out of
23357 -- range of Character, what is that about ???
23359 exit when not In_Character_Range (C);
23360 Options (J) := Get_Character (C);
23363 Set_Validity_Check_Options (Options);
23371 elsif Nkind (A) = N_Identifier then
23372 if Chars (A) = Name_All_Checks then
23373 Set_Validity_Check_Options ("a");
23374 elsif Chars (A) = Name_On then
23375 Validity_Checks_On := True;
23376 elsif Chars (A) = Name_Off then
23377 Validity_Checks_On := False;
23381 end Validity_Checks;
23387 -- pragma Volatile (LOCAL_NAME);
23389 when Pragma_Volatile =>
23390 Process_Atomic_Independent_Shared_Volatile;
23392 -------------------------
23393 -- Volatile_Components --
23394 -------------------------
23396 -- pragma Volatile_Components (array_LOCAL_NAME);
23398 -- Volatile is handled by the same circuit as Atomic_Components
23400 --------------------------
23401 -- Volatile_Full_Access --
23402 --------------------------
23404 -- pragma Volatile_Full_Access (LOCAL_NAME);
23406 when Pragma_Volatile_Full_Access =>
23408 Process_Atomic_Independent_Shared_Volatile;
23410 -----------------------
23411 -- Volatile_Function --
23412 -----------------------
23414 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23416 when Pragma_Volatile_Function => Volatile_Function : declare
23417 Over_Id : Entity_Id;
23418 Spec_Id : Entity_Id;
23419 Subp_Decl : Node_Id;
23423 Check_No_Identifiers;
23424 Check_At_Most_N_Arguments (1);
23427 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23429 -- Generic subprogram
23431 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23434 -- Body acts as spec
23436 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23437 and then No (Corresponding_Spec (Subp_Decl))
23441 -- Body stub acts as spec
23443 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23444 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23450 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23458 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23460 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
23465 -- A pragma that applies to a Ghost entity becomes Ghost for the
23466 -- purposes of legality checks and removal of ignored Ghost code.
23468 Mark_Ghost_Pragma (N, Spec_Id);
23470 -- Chain the pragma on the contract for completeness
23472 Add_Contract_Item (N, Spec_Id);
23474 -- The legality checks of pragma Volatile_Function are affected by
23475 -- the SPARK mode in effect. Analyze all pragmas in a specific
23478 Analyze_If_Present (Pragma_SPARK_Mode);
23480 -- A volatile function cannot override a non-volatile function
23481 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23482 -- in New_Overloaded_Entity, however at that point the pragma has
23483 -- not been processed yet.
23485 Over_Id := Overridden_Operation (Spec_Id);
23487 if Present (Over_Id)
23488 and then not Is_Volatile_Function (Over_Id)
23491 ("incompatible volatile function values in effect", Spec_Id);
23493 Error_Msg_Sloc := Sloc (Over_Id);
23495 ("\& declared # with Volatile_Function value False",
23498 Error_Msg_Sloc := Sloc (Spec_Id);
23500 ("\overridden # with Volatile_Function value True",
23504 -- Analyze the Boolean expression (if any)
23506 if Present (Arg1) then
23507 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
23509 end Volatile_Function;
23511 ----------------------
23512 -- Warning_As_Error --
23513 ----------------------
23515 -- pragma Warning_As_Error (static_string_EXPRESSION);
23517 when Pragma_Warning_As_Error =>
23519 Check_Arg_Count (1);
23520 Check_No_Identifiers;
23521 Check_Valid_Configuration_Pragma;
23523 if not Is_Static_String_Expression (Arg1) then
23525 ("argument of pragma% must be static string expression",
23528 -- OK static string expression
23531 Acquire_Warning_Match_String (Arg1);
23532 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23533 Warnings_As_Errors (Warnings_As_Errors_Count) :=
23534 new String'(Name_Buffer (1 .. Name_Len));
23541 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23543 -- DETAILS ::= On | Off
23544 -- DETAILS ::= On | Off, local_NAME
23545 -- DETAILS ::= static_string_EXPRESSION
23546 -- DETAILS ::= On | Off, static_string_EXPRESSION
23548 -- TOOL_NAME ::= GNAT | GNATProve
23550 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23552 -- Note: If the first argument matches an allowed tool name, it is
23553 -- always considered to be a tool name, even if there is a string
23554 -- variable of that name.
23556 -- Note if the second argument of DETAILS is a local_NAME then the
23557 -- second form is always understood. If the intention is to use
23558 -- the fourth form, then you can write NAME & "" to force the
23559 -- intepretation as a static_string_EXPRESSION.
23561 when Pragma_Warnings => Warnings : declare
23562 Reason : String_Id;
23566 Check_At_Least_N_Arguments (1);
23568 -- See if last argument is labeled Reason. If so, make sure we
23569 -- have a string literal or a concatenation of string literals,
23570 -- and acquire the REASON string. Then remove the REASON argument
23571 -- by decreasing Num_Args by one; Remaining processing looks only
23572 -- at first Num_Args arguments).
23575 Last_Arg : constant Node_Id :=
23576 Last (Pragma_Argument_Associations (N));
23579 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23580 and then Chars (Last_Arg) = Name_Reason
23583 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23584 Reason := End_String;
23585 Arg_Count := Arg_Count - 1;
23587 -- Not allowed in compiler units (bootstrap issues)
23589 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23591 -- No REASON string, set null string as reason
23594 Reason := Null_String_Id;
23598 -- Now proceed with REASON taken care of and eliminated
23600 Check_No_Identifiers;
23602 -- If debug flag -gnatd.i is set, pragma is ignored
23604 if Debug_Flag_Dot_I then
23608 -- Process various forms of the pragma
23611 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23612 Shifted_Args : List_Id;
23615 -- See if first argument is a tool name, currently either
23616 -- GNAT or GNATprove. If so, either ignore the pragma if the
23617 -- tool used does not match, or continue as if no tool name
23618 -- was given otherwise, by shifting the arguments.
23620 if Nkind (Argx) = N_Identifier
23621 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23623 if Chars (Argx) = Name_Gnat then
23624 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23625 Rewrite (N, Make_Null_Statement (Loc));
23630 elsif Chars (Argx) = Name_Gnatprove then
23631 if not GNATprove_Mode then
23632 Rewrite (N, Make_Null_Statement (Loc));
23638 raise Program_Error;
23641 -- At this point, the pragma Warnings applies to the tool,
23642 -- so continue with shifted arguments.
23644 Arg_Count := Arg_Count - 1;
23646 if Arg_Count = 1 then
23647 Shifted_Args := New_List (New_Copy (Arg2));
23648 elsif Arg_Count = 2 then
23649 Shifted_Args := New_List (New_Copy (Arg2),
23651 elsif Arg_Count = 3 then
23652 Shifted_Args := New_List (New_Copy (Arg2),
23656 raise Program_Error;
23661 Chars => Name_Warnings,
23662 Pragma_Argument_Associations => Shifted_Args));
23667 -- One argument case
23669 if Arg_Count = 1 then
23671 -- On/Off one argument case was processed by parser
23673 if Nkind (Argx) = N_Identifier
23674 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23678 -- One argument case must be ON/OFF or static string expr
23680 elsif not Is_Static_String_Expression (Arg1) then
23682 ("argument of pragma% must be On/Off or static string "
23683 & "expression", Arg1);
23685 -- One argument string expression case
23689 Lit : constant Node_Id := Expr_Value_S (Argx);
23690 Str : constant String_Id := Strval (Lit);
23691 Len : constant Nat := String_Length (Str);
23699 while J <= Len loop
23700 C := Get_String_Char (Str, J);
23701 OK := In_Character_Range (C);
23704 Chr := Get_Character (C);
23706 -- Dash case: only -Wxxx is accepted
23713 C := Get_String_Char (Str, J);
23714 Chr := Get_Character (C);
23715 exit when Chr = 'W';
23720 elsif J < Len and then Chr = '.' then
23722 C := Get_String_Char (Str, J);
23723 Chr := Get_Character (C);
23725 if not Set_Dot_Warning_Switch (Chr) then
23727 ("invalid warning switch character "
23728 & '.' & Chr, Arg1);
23734 OK := Set_Warning_Switch (Chr);
23740 ("invalid warning switch character " & Chr,
23749 -- Two or more arguments (must be two)
23752 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23753 Check_Arg_Count (2);
23761 E_Id := Get_Pragma_Arg (Arg2);
23764 -- In the expansion of an inlined body, a reference to
23765 -- the formal may be wrapped in a conversion if the
23766 -- actual is a conversion. Retrieve the real entity name.
23768 if (In_Instance_Body or In_Inlined_Body)
23769 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23771 E_Id := Expression (E_Id);
23774 -- Entity name case
23776 if Is_Entity_Name (E_Id) then
23777 E := Entity (E_Id);
23784 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23787 -- For OFF case, make entry in warnings off
23788 -- pragma table for later processing. But we do
23789 -- not do that within an instance, since these
23790 -- warnings are about what is needed in the
23791 -- template, not an instance of it.
23793 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23794 and then Warn_On_Warnings_Off
23795 and then not In_Instance
23797 Warnings_Off_Pragmas.Append ((N, E, Reason));
23800 if Is_Enumeration_Type (E) then
23804 Lit := First_Literal (E);
23805 while Present (Lit) loop
23806 Set_Warnings_Off (Lit);
23807 Next_Literal (Lit);
23812 exit when No (Homonym (E));
23817 -- Error if not entity or static string expression case
23819 elsif not Is_Static_String_Expression (Arg2) then
23821 ("second argument of pragma% must be entity name "
23822 & "or static string expression", Arg2);
23824 -- Static string expression case
23827 Acquire_Warning_Match_String (Arg2);
23829 -- Note on configuration pragma case: If this is a
23830 -- configuration pragma, then for an OFF pragma, we
23831 -- just set Config True in the call, which is all
23832 -- that needs to be done. For the case of ON, this
23833 -- is normally an error, unless it is canceling the
23834 -- effect of a previous OFF pragma in the same file.
23835 -- In any other case, an error will be signalled (ON
23836 -- with no matching OFF).
23838 -- Note: We set Used if we are inside a generic to
23839 -- disable the test that the non-config case actually
23840 -- cancels a warning. That's because we can't be sure
23841 -- there isn't an instantiation in some other unit
23842 -- where a warning is suppressed.
23844 -- We could do a little better here by checking if the
23845 -- generic unit we are inside is public, but for now
23846 -- we don't bother with that refinement.
23848 if Chars (Argx) = Name_Off then
23849 Set_Specific_Warning_Off
23850 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23851 Config => Is_Configuration_Pragma,
23852 Used => Inside_A_Generic or else In_Instance);
23854 elsif Chars (Argx) = Name_On then
23855 Set_Specific_Warning_On
23856 (Loc, Name_Buffer (1 .. Name_Len), Err);
23860 ("??pragma Warnings On with no matching "
23861 & "Warnings Off", Loc);
23870 -------------------
23871 -- Weak_External --
23872 -------------------
23874 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23876 when Pragma_Weak_External => Weak_External : declare
23881 Check_Arg_Count (1);
23882 Check_Optional_Identifier (Arg1, Name_Entity);
23883 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23884 Ent := Entity (Get_Pragma_Arg (Arg1));
23886 if Rep_Item_Too_Early (Ent, N) then
23889 Ent := Underlying_Type (Ent);
23892 -- The only processing required is to link this item on to the
23893 -- list of rep items for the given entity. This is accomplished
23894 -- by the call to Rep_Item_Too_Late (when no error is detected
23895 -- and False is returned).
23897 if Rep_Item_Too_Late (Ent, N) then
23900 Set_Has_Gigi_Rep_Item (Ent);
23904 -----------------------------
23905 -- Wide_Character_Encoding --
23906 -----------------------------
23908 -- pragma Wide_Character_Encoding (IDENTIFIER);
23910 when Pragma_Wide_Character_Encoding =>
23913 -- Nothing to do, handled in parser. Note that we do not enforce
23914 -- configuration pragma placement, this pragma can appear at any
23915 -- place in the source, allowing mixed encodings within a single
23920 --------------------
23921 -- Unknown_Pragma --
23922 --------------------
23924 -- Should be impossible, since the case of an unknown pragma is
23925 -- separately processed before the case statement is entered.
23927 when Unknown_Pragma =>
23928 raise Program_Error;
23931 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23932 -- until AI is formally approved.
23934 -- Check_Order_Dependence;
23937 when Pragma_Exit => null;
23938 end Analyze_Pragma;
23940 ---------------------------------------------
23941 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23942 ---------------------------------------------
23944 -- WARNING: This routine manages Ghost regions. Return statements must be
23945 -- replaced by gotos which jump to the end of the routine and restore the
23948 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23950 Freeze_Id : Entity_Id := Empty)
23952 Disp_Typ : Entity_Id;
23953 -- The dispatching type of the subprogram subject to the pre- or
23956 function Check_References (Nod : Node_Id) return Traverse_Result;
23957 -- Check that expression Nod does not mention non-primitives of the
23958 -- type, global objects of the type, or other illegalities described
23959 -- and implied by AI12-0113.
23961 ----------------------
23962 -- Check_References --
23963 ----------------------
23965 function Check_References (Nod : Node_Id) return Traverse_Result is
23967 if Nkind (Nod) = N_Function_Call
23968 and then Is_Entity_Name (Name (Nod))
23971 Func : constant Entity_Id := Entity (Name (Nod));
23975 -- An operation of the type must be a primitive
23977 if No (Find_Dispatching_Type (Func)) then
23978 Form := First_Formal (Func);
23979 while Present (Form) loop
23980 if Etype (Form) = Disp_Typ then
23982 ("operation in class-wide condition must be "
23983 & "primitive of &", Nod, Disp_Typ);
23986 Next_Formal (Form);
23989 -- A return object of the type is illegal as well
23991 if Etype (Func) = Disp_Typ
23992 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23995 ("operation in class-wide condition must be primitive "
23996 & "of &", Nod, Disp_Typ);
24001 elsif Is_Entity_Name (Nod)
24003 (Etype (Nod) = Disp_Typ
24004 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24005 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24008 ("object in class-wide condition must be formal of type &",
24011 elsif Nkind (Nod) = N_Explicit_Dereference
24012 and then (Etype (Nod) = Disp_Typ
24013 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24014 and then (not Is_Entity_Name (Prefix (Nod))
24015 or else not Is_Formal (Entity (Prefix (Nod))))
24018 ("operation in class-wide condition must be primitive of &",
24023 end Check_References;
24025 procedure Check_Class_Wide_Condition is
24026 new Traverse_Proc (Check_References);
24030 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24031 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24032 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24034 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24035 -- Save the Ghost mode to restore on exit
24038 Restore_Scope : Boolean := False;
24040 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24043 -- Do not analyze the pragma multiple times
24045 if Is_Analyzed_Pragma (N) then
24049 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24050 -- analysis of the pragma, the Ghost mode at point of declaration and
24051 -- point of analysis may not necessarily be the same. Use the mode in
24052 -- effect at the point of declaration.
24054 Set_Ghost_Mode (N);
24056 -- Ensure that the subprogram and its formals are visible when analyzing
24057 -- the expression of the pragma.
24059 if not In_Open_Scopes (Spec_Id) then
24060 Restore_Scope := True;
24061 Push_Scope (Spec_Id);
24063 if Is_Generic_Subprogram (Spec_Id) then
24064 Install_Generic_Formals (Spec_Id);
24066 Install_Formals (Spec_Id);
24070 Errors := Serious_Errors_Detected;
24071 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24073 -- Emit a clarification message when the expression contains at least
24074 -- one undefined reference, possibly due to contract "freezing".
24076 if Errors /= Serious_Errors_Detected
24077 and then Present (Freeze_Id)
24078 and then Has_Undefined_Reference (Expr)
24080 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24083 if Class_Present (N) then
24085 -- Verify that a class-wide condition is legal, i.e. the operation is
24086 -- a primitive of a tagged type. Note that a generic subprogram is
24087 -- not a primitive operation.
24089 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24091 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24092 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24094 if From_Aspect_Specification (N) then
24096 ("aspect % can only be specified for a primitive operation "
24097 & "of a tagged type", Corresponding_Aspect (N));
24099 -- The pragma is a source construct
24103 ("pragma % can only be specified for a primitive operation "
24104 & "of a tagged type", N);
24107 -- Remaining semantic checks require a full tree traversal
24110 Check_Class_Wide_Condition (Expr);
24115 if Restore_Scope then
24119 -- Currently it is not possible to inline pre/postconditions on a
24120 -- subprogram subject to pragma Inline_Always.
24122 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24123 Set_Is_Analyzed_Pragma (N);
24125 Restore_Ghost_Mode (Saved_GM);
24126 end Analyze_Pre_Post_Condition_In_Decl_Part;
24128 ------------------------------------------
24129 -- Analyze_Refined_Depends_In_Decl_Part --
24130 ------------------------------------------
24132 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24133 procedure Check_Dependency_Clause
24134 (Spec_Id : Entity_Id;
24135 Dep_Clause : Node_Id;
24136 Dep_States : Elist_Id;
24137 Refinements : List_Id;
24138 Matched_Items : in out Elist_Id);
24139 -- Try to match a single dependency clause Dep_Clause against one or
24140 -- more refinement clauses found in list Refinements. Each successful
24141 -- match eliminates at least one refinement clause from Refinements.
24142 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24143 -- denotes the entities of all abstract states which appear in pragma
24144 -- Depends. Matched_Items contains the entities of all successfully
24145 -- matched items found in pragma Depends.
24147 procedure Check_Output_States
24148 (Spec_Id : Entity_Id;
24149 Spec_Inputs : Elist_Id;
24150 Spec_Outputs : Elist_Id;
24151 Body_Inputs : Elist_Id;
24152 Body_Outputs : Elist_Id);
24153 -- Determine whether pragma Depends contains an output state with a
24154 -- visible refinement and if so, ensure that pragma Refined_Depends
24155 -- mentions all its constituents as outputs. Spec_Id is the entity of
24156 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24157 -- inputs and outputs of the subprogram spec synthesized from pragma
24158 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24159 -- of the subprogram body synthesized from pragma Refined_Depends.
24161 function Collect_States (Clauses : List_Id) return Elist_Id;
24162 -- Given a normalized list of dependencies obtained from calling
24163 -- Normalize_Clauses, return a list containing the entities of all
24164 -- states appearing in dependencies. It helps in checking refinements
24165 -- involving a state and a corresponding constituent which is not a
24166 -- direct constituent of the state.
24168 procedure Normalize_Clauses (Clauses : List_Id);
24169 -- Given a list of dependence or refinement clauses Clauses, normalize
24170 -- each clause by creating multiple dependencies with exactly one input
24173 procedure Remove_Extra_Clauses
24174 (Clauses : List_Id;
24175 Matched_Items : Elist_Id);
24176 -- Given a list of refinement clauses Clauses, remove all clauses whose
24177 -- inputs and/or outputs have been previously matched. See the body for
24178 -- all special cases. Matched_Items contains the entities of all matched
24179 -- items found in pragma Depends.
24181 procedure Report_Extra_Clauses
24182 (Spec_Id : Entity_Id;
24183 Clauses : List_Id);
24184 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24185 -- denotes the entity of the related subprogram.
24187 -----------------------------
24188 -- Check_Dependency_Clause --
24189 -----------------------------
24191 procedure Check_Dependency_Clause
24192 (Spec_Id : Entity_Id;
24193 Dep_Clause : Node_Id;
24194 Dep_States : Elist_Id;
24195 Refinements : List_Id;
24196 Matched_Items : in out Elist_Id)
24198 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24199 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24201 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24202 -- Determine whether dependency item Dep_Item has been matched in a
24203 -- previous clause.
24205 function Is_In_Out_State_Clause return Boolean;
24206 -- Determine whether dependence clause Dep_Clause denotes an abstract
24207 -- state that depends on itself (State => State).
24209 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24210 -- Determine whether item Item denotes an abstract state with visible
24211 -- null refinement.
24213 procedure Match_Items
24214 (Dep_Item : Node_Id;
24215 Ref_Item : Node_Id;
24216 Matched : out Boolean);
24217 -- Try to match dependence item Dep_Item against refinement item
24218 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24219 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24220 -- the following conformance scenarios is in effect:
24221 -- 1) Both items denote null
24222 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24223 -- 3) Both items denote attribute 'Result
24224 -- 4) Both items denote the same object
24225 -- 5) Both items denote the same formal parameter
24226 -- 6) Both items denote the same current instance of a type
24227 -- 7) Both items denote the same discriminant
24228 -- 8) Dep_Item is an abstract state with visible null refinement
24229 -- and Ref_Item denotes null.
24230 -- 9) Dep_Item is an abstract state with visible null refinement
24231 -- and Ref_Item is Empty (special case).
24232 -- 10) Dep_Item is an abstract state with full or partial visible
24233 -- non-null refinement and Ref_Item denotes one of its
24235 -- 11) Dep_Item is an abstract state without a full visible
24236 -- refinement and Ref_Item denotes the same state.
24237 -- When scenario 10 is in effect, the entity of the abstract state
24238 -- denoted by Dep_Item is added to list Refined_States.
24240 procedure Record_Item (Item_Id : Entity_Id);
24241 -- Store the entity of an item denoted by Item_Id in Matched_Items
24243 ------------------------
24244 -- Is_Already_Matched --
24245 ------------------------
24247 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
24248 Item_Id : Entity_Id := Empty;
24251 -- When the dependency item denotes attribute 'Result, check for
24252 -- the entity of the related subprogram.
24254 if Is_Attribute_Result (Dep_Item) then
24255 Item_Id := Spec_Id;
24257 elsif Is_Entity_Name (Dep_Item) then
24258 Item_Id := Available_View (Entity_Of (Dep_Item));
24262 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
24263 end Is_Already_Matched;
24265 ----------------------------
24266 -- Is_In_Out_State_Clause --
24267 ----------------------------
24269 function Is_In_Out_State_Clause return Boolean is
24270 Dep_Input_Id : Entity_Id;
24271 Dep_Output_Id : Entity_Id;
24274 -- Detect the following clause:
24277 if Is_Entity_Name (Dep_Input)
24278 and then Is_Entity_Name (Dep_Output)
24280 -- Handle abstract views generated for limited with clauses
24282 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
24283 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
24286 Ekind (Dep_Input_Id) = E_Abstract_State
24287 and then Dep_Input_Id = Dep_Output_Id;
24291 end Is_In_Out_State_Clause;
24293 ---------------------------
24294 -- Is_Null_Refined_State --
24295 ---------------------------
24297 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
24298 Item_Id : Entity_Id;
24301 if Is_Entity_Name (Item) then
24303 -- Handle abstract views generated for limited with clauses
24305 Item_Id := Available_View (Entity_Of (Item));
24308 Ekind (Item_Id) = E_Abstract_State
24309 and then Has_Null_Visible_Refinement (Item_Id);
24313 end Is_Null_Refined_State;
24319 procedure Match_Items
24320 (Dep_Item : Node_Id;
24321 Ref_Item : Node_Id;
24322 Matched : out Boolean)
24324 Dep_Item_Id : Entity_Id;
24325 Ref_Item_Id : Entity_Id;
24328 -- Assume that the two items do not match
24332 -- A null matches null or Empty (special case)
24334 if Nkind (Dep_Item) = N_Null
24335 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24339 -- Attribute 'Result matches attribute 'Result
24341 elsif Is_Attribute_Result (Dep_Item)
24342 and then Is_Attribute_Result (Ref_Item)
24344 -- Put the entity of the related function on the list of
24345 -- matched items because attribute 'Result does not carry
24346 -- an entity similar to states and constituents.
24348 Record_Item (Spec_Id);
24351 -- Abstract states, current instances of concurrent types,
24352 -- discriminants, formal parameters and objects.
24354 elsif Is_Entity_Name (Dep_Item) then
24356 -- Handle abstract views generated for limited with clauses
24358 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
24360 if Ekind (Dep_Item_Id) = E_Abstract_State then
24362 -- An abstract state with visible null refinement matches
24363 -- null or Empty (special case).
24365 if Has_Null_Visible_Refinement (Dep_Item_Id)
24366 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24368 Record_Item (Dep_Item_Id);
24371 -- An abstract state with visible non-null refinement
24372 -- matches one of its constituents, or itself for an
24373 -- abstract state with partial visible refinement.
24375 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
24376 if Is_Entity_Name (Ref_Item) then
24377 Ref_Item_Id := Entity_Of (Ref_Item);
24379 if Ekind_In (Ref_Item_Id, E_Abstract_State,
24382 and then Present (Encapsulating_State (Ref_Item_Id))
24383 and then Find_Encapsulating_State
24384 (Dep_States, Ref_Item_Id) = Dep_Item_Id
24386 Record_Item (Dep_Item_Id);
24389 elsif not Has_Visible_Refinement (Dep_Item_Id)
24390 and then Ref_Item_Id = Dep_Item_Id
24392 Record_Item (Dep_Item_Id);
24397 -- An abstract state without a visible refinement matches
24400 elsif Is_Entity_Name (Ref_Item)
24401 and then Entity_Of (Ref_Item) = Dep_Item_Id
24403 Record_Item (Dep_Item_Id);
24407 -- A current instance of a concurrent type, discriminant,
24408 -- formal parameter or an object matches itself.
24410 elsif Is_Entity_Name (Ref_Item)
24411 and then Entity_Of (Ref_Item) = Dep_Item_Id
24413 Record_Item (Dep_Item_Id);
24423 procedure Record_Item (Item_Id : Entity_Id) is
24425 if No (Matched_Items) then
24426 Matched_Items := New_Elmt_List;
24429 Append_Unique_Elmt (Item_Id, Matched_Items);
24434 Clause_Matched : Boolean := False;
24435 Dummy : Boolean := False;
24436 Inputs_Match : Boolean;
24437 Next_Ref_Clause : Node_Id;
24438 Outputs_Match : Boolean;
24439 Ref_Clause : Node_Id;
24440 Ref_Input : Node_Id;
24441 Ref_Output : Node_Id;
24443 -- Start of processing for Check_Dependency_Clause
24446 -- Do not perform this check in an instance because it was already
24447 -- performed successfully in the generic template.
24449 if Is_Generic_Instance (Spec_Id) then
24453 -- Examine all refinement clauses and compare them against the
24454 -- dependence clause.
24456 Ref_Clause := First (Refinements);
24457 while Present (Ref_Clause) loop
24458 Next_Ref_Clause := Next (Ref_Clause);
24460 -- Obtain the attributes of the current refinement clause
24462 Ref_Input := Expression (Ref_Clause);
24463 Ref_Output := First (Choices (Ref_Clause));
24465 -- The current refinement clause matches the dependence clause
24466 -- when both outputs match and both inputs match. See routine
24467 -- Match_Items for all possible conformance scenarios.
24469 -- Depends Dep_Output => Dep_Input
24473 -- Refined_Depends Ref_Output => Ref_Input
24476 (Dep_Item => Dep_Input,
24477 Ref_Item => Ref_Input,
24478 Matched => Inputs_Match);
24481 (Dep_Item => Dep_Output,
24482 Ref_Item => Ref_Output,
24483 Matched => Outputs_Match);
24485 -- An In_Out state clause may be matched against a refinement with
24486 -- a null input or null output as long as the non-null side of the
24487 -- relation contains a valid constituent of the In_Out_State.
24489 if Is_In_Out_State_Clause then
24491 -- Depends => (State => State)
24492 -- Refined_Depends => (null => Constit) -- OK
24495 and then not Outputs_Match
24496 and then Nkind (Ref_Output) = N_Null
24498 Outputs_Match := True;
24501 -- Depends => (State => State)
24502 -- Refined_Depends => (Constit => null) -- OK
24504 if not Inputs_Match
24505 and then Outputs_Match
24506 and then Nkind (Ref_Input) = N_Null
24508 Inputs_Match := True;
24512 -- The current refinement clause is legally constructed following
24513 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24514 -- the pool of candidates. The seach continues because a single
24515 -- dependence clause may have multiple matching refinements.
24517 if Inputs_Match and Outputs_Match then
24518 Clause_Matched := True;
24519 Remove (Ref_Clause);
24522 Ref_Clause := Next_Ref_Clause;
24525 -- Depending on the order or composition of refinement clauses, an
24526 -- In_Out state clause may not be directly refinable.
24528 -- Refined_State => (State => (Constit_1, Constit_2))
24529 -- Depends => ((Output, State) => (Input, State))
24530 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24532 -- Matching normalized clause (State => State) fails because there is
24533 -- no direct refinement capable of satisfying this relation. Another
24534 -- similar case arises when clauses (Constit_1 => Input) and (Output
24535 -- => Constit_2) are matched first, leaving no candidates for clause
24536 -- (State => State). Both scenarios are legal as long as one of the
24537 -- previous clauses mentioned a valid constituent of State.
24539 if not Clause_Matched
24540 and then Is_In_Out_State_Clause
24541 and then Is_Already_Matched (Dep_Input)
24543 Clause_Matched := True;
24546 -- A clause where the input is an abstract state with visible null
24547 -- refinement or a 'Result attribute is implicitly matched when the
24548 -- output has already been matched in a previous clause.
24550 -- Refined_State => (State => null)
24551 -- Depends => (Output => State) -- implicitly OK
24552 -- Refined_Depends => (Output => ...)
24553 -- Depends => (...'Result => State) -- implicitly OK
24554 -- Refined_Depends => (...'Result => ...)
24556 if not Clause_Matched
24557 and then Is_Null_Refined_State (Dep_Input)
24558 and then Is_Already_Matched (Dep_Output)
24560 Clause_Matched := True;
24563 -- A clause where the output is an abstract state with visible null
24564 -- refinement is implicitly matched when the input has already been
24565 -- matched in a previous clause.
24567 -- Refined_State => (State => null)
24568 -- Depends => (State => Input) -- implicitly OK
24569 -- Refined_Depends => (... => Input)
24571 if not Clause_Matched
24572 and then Is_Null_Refined_State (Dep_Output)
24573 and then Is_Already_Matched (Dep_Input)
24575 Clause_Matched := True;
24578 -- At this point either all refinement clauses have been examined or
24579 -- pragma Refined_Depends contains a solitary null. Only an abstract
24580 -- state with null refinement can possibly match these cases.
24582 -- Refined_State => (State => null)
24583 -- Depends => (State => null)
24584 -- Refined_Depends => null -- OK
24586 if not Clause_Matched then
24588 (Dep_Item => Dep_Input,
24590 Matched => Inputs_Match);
24593 (Dep_Item => Dep_Output,
24595 Matched => Outputs_Match);
24597 Clause_Matched := Inputs_Match and Outputs_Match;
24600 -- If the contents of Refined_Depends are legal, then the current
24601 -- dependence clause should be satisfied either by an explicit match
24602 -- or by one of the special cases.
24604 if not Clause_Matched then
24606 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24607 & "matching refinement in body"), Dep_Clause, Spec_Id);
24609 end Check_Dependency_Clause;
24611 -------------------------
24612 -- Check_Output_States --
24613 -------------------------
24615 procedure Check_Output_States
24616 (Spec_Id : Entity_Id;
24617 Spec_Inputs : Elist_Id;
24618 Spec_Outputs : Elist_Id;
24619 Body_Inputs : Elist_Id;
24620 Body_Outputs : Elist_Id)
24622 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24623 -- Determine whether all constituents of state State_Id with full
24624 -- visible refinement are used as outputs in pragma Refined_Depends.
24625 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24627 -----------------------------
24628 -- Check_Constituent_Usage --
24629 -----------------------------
24631 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24632 Constits : constant Elist_Id :=
24633 Partial_Refinement_Constituents (State_Id);
24634 Constit_Elmt : Elmt_Id;
24635 Constit_Id : Entity_Id;
24636 Only_Partial : constant Boolean :=
24637 not Has_Visible_Refinement (State_Id);
24638 Posted : Boolean := False;
24641 if Present (Constits) then
24642 Constit_Elmt := First_Elmt (Constits);
24643 while Present (Constit_Elmt) loop
24644 Constit_Id := Node (Constit_Elmt);
24646 -- Issue an error when a constituent of State_Id is used,
24647 -- and State_Id has only partial visible refinement
24648 -- (SPARK RM 7.2.4(3d)).
24650 if Only_Partial then
24651 if (Present (Body_Inputs)
24652 and then Appears_In (Body_Inputs, Constit_Id))
24654 (Present (Body_Outputs)
24655 and then Appears_In (Body_Outputs, Constit_Id))
24657 Error_Msg_Name_1 := Chars (State_Id);
24659 ("constituent & of state % cannot be used in "
24660 & "dependence refinement", N, Constit_Id);
24661 Error_Msg_Name_1 := Chars (State_Id);
24662 SPARK_Msg_N ("\use state % instead", N);
24665 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24667 elsif Present (Body_Inputs)
24668 and then Appears_In (Body_Inputs, Constit_Id)
24670 Error_Msg_Name_1 := Chars (State_Id);
24672 ("constituent & of state % must act as output in "
24673 & "dependence refinement", N, Constit_Id);
24675 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24677 elsif No (Body_Outputs)
24678 or else not Appears_In (Body_Outputs, Constit_Id)
24683 ("output state & must be replaced by all its "
24684 & "constituents in dependence refinement",
24689 ("\constituent & is missing in output list",
24693 Next_Elmt (Constit_Elmt);
24696 end Check_Constituent_Usage;
24701 Item_Elmt : Elmt_Id;
24702 Item_Id : Entity_Id;
24704 -- Start of processing for Check_Output_States
24707 -- Do not perform this check in an instance because it was already
24708 -- performed successfully in the generic template.
24710 if Is_Generic_Instance (Spec_Id) then
24713 -- Inspect the outputs of pragma Depends looking for a state with a
24714 -- visible refinement.
24716 elsif Present (Spec_Outputs) then
24717 Item_Elmt := First_Elmt (Spec_Outputs);
24718 while Present (Item_Elmt) loop
24719 Item := Node (Item_Elmt);
24721 -- Deal with the mixed nature of the input and output lists
24723 if Nkind (Item) = N_Defining_Identifier then
24726 Item_Id := Available_View (Entity_Of (Item));
24729 if Ekind (Item_Id) = E_Abstract_State then
24731 -- The state acts as an input-output, skip it
24733 if Present (Spec_Inputs)
24734 and then Appears_In (Spec_Inputs, Item_Id)
24738 -- Ensure that all of the constituents are utilized as
24739 -- outputs in pragma Refined_Depends.
24741 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24742 Check_Constituent_Usage (Item_Id);
24746 Next_Elmt (Item_Elmt);
24749 end Check_Output_States;
24751 --------------------
24752 -- Collect_States --
24753 --------------------
24755 function Collect_States (Clauses : List_Id) return Elist_Id is
24756 procedure Collect_State
24758 States : in out Elist_Id);
24759 -- Add the entity of Item to list States when it denotes to a state
24761 -------------------
24762 -- Collect_State --
24763 -------------------
24765 procedure Collect_State
24767 States : in out Elist_Id)
24772 if Is_Entity_Name (Item) then
24773 Id := Entity_Of (Item);
24775 if Ekind (Id) = E_Abstract_State then
24776 if No (States) then
24777 States := New_Elmt_List;
24780 Append_Unique_Elmt (Id, States);
24790 States : Elist_Id := No_Elist;
24792 -- Start of processing for Collect_States
24795 Clause := First (Clauses);
24796 while Present (Clause) loop
24797 Input := Expression (Clause);
24798 Output := First (Choices (Clause));
24800 Collect_State (Input, States);
24801 Collect_State (Output, States);
24807 end Collect_States;
24809 -----------------------
24810 -- Normalize_Clauses --
24811 -----------------------
24813 procedure Normalize_Clauses (Clauses : List_Id) is
24814 procedure Normalize_Inputs (Clause : Node_Id);
24815 -- Normalize clause Clause by creating multiple clauses for each
24816 -- input item of Clause. It is assumed that Clause has exactly one
24817 -- output. The transformation is as follows:
24819 -- Output => (Input_1, Input_2) -- original
24821 -- Output => Input_1 -- normalizations
24822 -- Output => Input_2
24824 procedure Normalize_Outputs (Clause : Node_Id);
24825 -- Normalize clause Clause by creating multiple clause for each
24826 -- output item of Clause. The transformation is as follows:
24828 -- (Output_1, Output_2) => Input -- original
24830 -- Output_1 => Input -- normalization
24831 -- Output_2 => Input
24833 ----------------------
24834 -- Normalize_Inputs --
24835 ----------------------
24837 procedure Normalize_Inputs (Clause : Node_Id) is
24838 Inputs : constant Node_Id := Expression (Clause);
24839 Loc : constant Source_Ptr := Sloc (Clause);
24840 Output : constant List_Id := Choices (Clause);
24841 Last_Input : Node_Id;
24843 New_Clause : Node_Id;
24844 Next_Input : Node_Id;
24847 -- Normalization is performed only when the original clause has
24848 -- more than one input. Multiple inputs appear as an aggregate.
24850 if Nkind (Inputs) = N_Aggregate then
24851 Last_Input := Last (Expressions (Inputs));
24853 -- Create a new clause for each input
24855 Input := First (Expressions (Inputs));
24856 while Present (Input) loop
24857 Next_Input := Next (Input);
24859 -- Unhook the current input from the original input list
24860 -- because it will be relocated to a new clause.
24864 -- Special processing for the last input. At this point the
24865 -- original aggregate has been stripped down to one element.
24866 -- Replace the aggregate by the element itself.
24868 if Input = Last_Input then
24869 Rewrite (Inputs, Input);
24871 -- Generate a clause of the form:
24876 Make_Component_Association (Loc,
24877 Choices => New_Copy_List_Tree (Output),
24878 Expression => Input);
24880 -- The new clause contains replicated content that has
24881 -- already been analyzed, mark the clause as analyzed.
24883 Set_Analyzed (New_Clause);
24884 Insert_After (Clause, New_Clause);
24887 Input := Next_Input;
24890 end Normalize_Inputs;
24892 -----------------------
24893 -- Normalize_Outputs --
24894 -----------------------
24896 procedure Normalize_Outputs (Clause : Node_Id) is
24897 Inputs : constant Node_Id := Expression (Clause);
24898 Loc : constant Source_Ptr := Sloc (Clause);
24899 Outputs : constant Node_Id := First (Choices (Clause));
24900 Last_Output : Node_Id;
24901 New_Clause : Node_Id;
24902 Next_Output : Node_Id;
24906 -- Multiple outputs appear as an aggregate. Nothing to do when
24907 -- the clause has exactly one output.
24909 if Nkind (Outputs) = N_Aggregate then
24910 Last_Output := Last (Expressions (Outputs));
24912 -- Create a clause for each output. Note that each time a new
24913 -- clause is created, the original output list slowly shrinks
24914 -- until there is one item left.
24916 Output := First (Expressions (Outputs));
24917 while Present (Output) loop
24918 Next_Output := Next (Output);
24920 -- Unhook the output from the original output list as it
24921 -- will be relocated to a new clause.
24925 -- Special processing for the last output. At this point
24926 -- the original aggregate has been stripped down to one
24927 -- element. Replace the aggregate by the element itself.
24929 if Output = Last_Output then
24930 Rewrite (Outputs, Output);
24933 -- Generate a clause of the form:
24934 -- (Output => Inputs)
24937 Make_Component_Association (Loc,
24938 Choices => New_List (Output),
24939 Expression => New_Copy_Tree (Inputs));
24941 -- The new clause contains replicated content that has
24942 -- already been analyzed. There is not need to reanalyze
24945 Set_Analyzed (New_Clause);
24946 Insert_After (Clause, New_Clause);
24949 Output := Next_Output;
24952 end Normalize_Outputs;
24958 -- Start of processing for Normalize_Clauses
24961 Clause := First (Clauses);
24962 while Present (Clause) loop
24963 Normalize_Outputs (Clause);
24967 Clause := First (Clauses);
24968 while Present (Clause) loop
24969 Normalize_Inputs (Clause);
24972 end Normalize_Clauses;
24974 --------------------------
24975 -- Remove_Extra_Clauses --
24976 --------------------------
24978 procedure Remove_Extra_Clauses
24979 (Clauses : List_Id;
24980 Matched_Items : Elist_Id)
24984 Input_Id : Entity_Id;
24985 Next_Clause : Node_Id;
24987 State_Id : Entity_Id;
24990 Clause := First (Clauses);
24991 while Present (Clause) loop
24992 Next_Clause := Next (Clause);
24994 Input := Expression (Clause);
24995 Output := First (Choices (Clause));
24997 -- Recognize a clause of the form
25001 -- where Input is a constituent of a state which was already
25002 -- successfully matched. This clause must be removed because it
25003 -- simply indicates that some of the constituents of the state
25006 -- Refined_State => (State => (Constit_1, Constit_2))
25007 -- Depends => (Output => State)
25008 -- Refined_Depends => ((Output => Constit_1), -- State matched
25009 -- (null => Constit_2)) -- OK
25011 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
25013 -- Handle abstract views generated for limited with clauses
25015 Input_Id := Available_View (Entity_Of (Input));
25017 -- The input must be a constituent of a state
25019 if Ekind_In (Input_Id, E_Abstract_State,
25022 and then Present (Encapsulating_State (Input_Id))
25024 State_Id := Encapsulating_State (Input_Id);
25026 -- The state must have a non-null visible refinement and be
25027 -- matched in a previous clause.
25029 if Has_Non_Null_Visible_Refinement (State_Id)
25030 and then Contains (Matched_Items, State_Id)
25036 -- Recognize a clause of the form
25040 -- where Output is an arbitrary item. This clause must be removed
25041 -- because a null input legitimately matches anything.
25043 elsif Nkind (Input) = N_Null then
25047 Clause := Next_Clause;
25049 end Remove_Extra_Clauses;
25051 --------------------------
25052 -- Report_Extra_Clauses --
25053 --------------------------
25055 procedure Report_Extra_Clauses
25056 (Spec_Id : Entity_Id;
25062 -- Do not perform this check in an instance because it was already
25063 -- performed successfully in the generic template.
25065 if Is_Generic_Instance (Spec_Id) then
25068 elsif Present (Clauses) then
25069 Clause := First (Clauses);
25070 while Present (Clause) loop
25072 ("unmatched or extra clause in dependence refinement",
25078 end Report_Extra_Clauses;
25082 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25083 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25084 Errors : constant Nat := Serious_Errors_Detected;
25091 Body_Inputs : Elist_Id := No_Elist;
25092 Body_Outputs : Elist_Id := No_Elist;
25093 -- The inputs and outputs of the subprogram body synthesized from pragma
25094 -- Refined_Depends.
25096 Dependencies : List_Id := No_List;
25098 -- The corresponding Depends pragma along with its clauses
25100 Matched_Items : Elist_Id := No_Elist;
25101 -- A list containing the entities of all successfully matched items
25102 -- found in pragma Depends.
25104 Refinements : List_Id := No_List;
25105 -- The clauses of pragma Refined_Depends
25107 Spec_Id : Entity_Id;
25108 -- The entity of the subprogram subject to pragma Refined_Depends
25110 Spec_Inputs : Elist_Id := No_Elist;
25111 Spec_Outputs : Elist_Id := No_Elist;
25112 -- The inputs and outputs of the subprogram spec synthesized from pragma
25115 States : Elist_Id := No_Elist;
25116 -- A list containing the entities of all states whose constituents
25117 -- appear in pragma Depends.
25119 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25122 -- Do not analyze the pragma multiple times
25124 if Is_Analyzed_Pragma (N) then
25128 Spec_Id := Unique_Defining_Entity (Body_Decl);
25130 -- Use the anonymous object as the proper spec when Refined_Depends
25131 -- applies to the body of a single task type. The object carries the
25132 -- proper Chars as well as all non-refined versions of pragmas.
25134 if Is_Single_Concurrent_Type (Spec_Id) then
25135 Spec_Id := Anonymous_Object (Spec_Id);
25138 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
25140 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25141 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25143 if No (Depends) then
25145 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25146 & "& lacks aspect or pragma Depends"), N, Spec_Id);
25150 Deps := Expression (Get_Argument (Depends, Spec_Id));
25152 -- A null dependency relation renders the refinement useless because it
25153 -- cannot possibly mention abstract states with visible refinement. Note
25154 -- that the inverse is not true as states may be refined to null
25155 -- (SPARK RM 7.2.5(2)).
25157 if Nkind (Deps) = N_Null then
25159 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25160 & "depend on abstract state with visible refinement"), N, Spec_Id);
25164 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25165 -- This ensures that the categorization of all refined dependency items
25166 -- is consistent with their role.
25168 Analyze_Depends_In_Decl_Part (N);
25170 -- Do not match dependencies against refinements if Refined_Depends is
25171 -- illegal to avoid emitting misleading error.
25173 if Serious_Errors_Detected = Errors then
25175 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25176 -- the inputs and outputs of the subprogram spec and body to verify
25177 -- the use of states with visible refinement and their constituents.
25179 if No (Get_Pragma (Spec_Id, Pragma_Global))
25180 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
25182 Collect_Subprogram_Inputs_Outputs
25183 (Subp_Id => Spec_Id,
25184 Synthesize => True,
25185 Subp_Inputs => Spec_Inputs,
25186 Subp_Outputs => Spec_Outputs,
25187 Global_Seen => Dummy);
25189 Collect_Subprogram_Inputs_Outputs
25190 (Subp_Id => Body_Id,
25191 Synthesize => True,
25192 Subp_Inputs => Body_Inputs,
25193 Subp_Outputs => Body_Outputs,
25194 Global_Seen => Dummy);
25196 -- For an output state with a visible refinement, ensure that all
25197 -- constituents appear as outputs in the dependency refinement.
25199 Check_Output_States
25200 (Spec_Id => Spec_Id,
25201 Spec_Inputs => Spec_Inputs,
25202 Spec_Outputs => Spec_Outputs,
25203 Body_Inputs => Body_Inputs,
25204 Body_Outputs => Body_Outputs);
25207 -- Matching is disabled in ASIS because clauses are not normalized as
25208 -- this is a tree altering activity similar to expansion.
25214 -- Multiple dependency clauses appear as component associations of an
25215 -- aggregate. Note that the clauses are copied because the algorithm
25216 -- modifies them and this should not be visible in Depends.
25218 pragma Assert (Nkind (Deps) = N_Aggregate);
25219 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
25220 Normalize_Clauses (Dependencies);
25222 -- Gather all states which appear in Depends
25224 States := Collect_States (Dependencies);
25226 Refs := Expression (Get_Argument (N, Spec_Id));
25228 if Nkind (Refs) = N_Null then
25229 Refinements := No_List;
25231 -- Multiple dependency clauses appear as component associations of an
25232 -- aggregate. Note that the clauses are copied because the algorithm
25233 -- modifies them and this should not be visible in Refined_Depends.
25235 else pragma Assert (Nkind (Refs) = N_Aggregate);
25236 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
25237 Normalize_Clauses (Refinements);
25240 -- At this point the clauses of pragmas Depends and Refined_Depends
25241 -- have been normalized into simple dependencies between one output
25242 -- and one input. Examine all clauses of pragma Depends looking for
25243 -- matching clauses in pragma Refined_Depends.
25245 Clause := First (Dependencies);
25246 while Present (Clause) loop
25247 Check_Dependency_Clause
25248 (Spec_Id => Spec_Id,
25249 Dep_Clause => Clause,
25250 Dep_States => States,
25251 Refinements => Refinements,
25252 Matched_Items => Matched_Items);
25257 -- Pragma Refined_Depends may contain multiple clarification clauses
25258 -- which indicate that certain constituents do not influence the data
25259 -- flow in any way. Such clauses must be removed as long as the state
25260 -- has been matched, otherwise they will be incorrectly flagged as
25263 -- Refined_State => (State => (Constit_1, Constit_2))
25264 -- Depends => (Output => State)
25265 -- Refined_Depends => ((Output => Constit_1), -- State matched
25266 -- (null => Constit_2)) -- must be removed
25268 Remove_Extra_Clauses (Refinements, Matched_Items);
25270 if Serious_Errors_Detected = Errors then
25271 Report_Extra_Clauses (Spec_Id, Refinements);
25276 Set_Is_Analyzed_Pragma (N);
25277 end Analyze_Refined_Depends_In_Decl_Part;
25279 -----------------------------------------
25280 -- Analyze_Refined_Global_In_Decl_Part --
25281 -----------------------------------------
25283 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
25285 -- The corresponding Global pragma
25287 Has_In_State : Boolean := False;
25288 Has_In_Out_State : Boolean := False;
25289 Has_Out_State : Boolean := False;
25290 Has_Proof_In_State : Boolean := False;
25291 -- These flags are set when the corresponding Global pragma has a state
25292 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25295 Has_Null_State : Boolean := False;
25296 -- This flag is set when the corresponding Global pragma has at least
25297 -- one state with a null refinement.
25299 In_Constits : Elist_Id := No_Elist;
25300 In_Out_Constits : Elist_Id := No_Elist;
25301 Out_Constits : Elist_Id := No_Elist;
25302 Proof_In_Constits : Elist_Id := No_Elist;
25303 -- These lists contain the entities of all Input, In_Out, Output and
25304 -- Proof_In constituents that appear in Refined_Global and participate
25305 -- in state refinement.
25307 In_Items : Elist_Id := No_Elist;
25308 In_Out_Items : Elist_Id := No_Elist;
25309 Out_Items : Elist_Id := No_Elist;
25310 Proof_In_Items : Elist_Id := No_Elist;
25311 -- These lists contain the entities of all Input, In_Out, Output and
25312 -- Proof_In items defined in the corresponding Global pragma.
25314 Repeat_Items : Elist_Id := No_Elist;
25315 -- A list of all global items without full visible refinement found
25316 -- in pragma Global. These states should be repeated in the global
25317 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25318 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25320 Spec_Id : Entity_Id;
25321 -- The entity of the subprogram subject to pragma Refined_Global
25323 States : Elist_Id := No_Elist;
25324 -- A list of all states with full or partial visible refinement found in
25327 procedure Check_In_Out_States;
25328 -- Determine whether the corresponding Global pragma mentions In_Out
25329 -- states with visible refinement and if so, ensure that one of the
25330 -- following completions apply to the constituents of the state:
25331 -- 1) there is at least one constituent of mode In_Out
25332 -- 2) there is at least one Input and one Output constituent
25333 -- 3) not all constituents are present and one of them is of mode
25335 -- This routine may remove elements from In_Constits, In_Out_Constits,
25336 -- Out_Constits and Proof_In_Constits.
25338 procedure Check_Input_States;
25339 -- Determine whether the corresponding Global pragma mentions Input
25340 -- states with visible refinement and if so, ensure that at least one of
25341 -- its constituents appears as an Input item in Refined_Global.
25342 -- This routine may remove elements from In_Constits, In_Out_Constits,
25343 -- Out_Constits and Proof_In_Constits.
25345 procedure Check_Output_States;
25346 -- Determine whether the corresponding Global pragma mentions Output
25347 -- states with visible refinement and if so, ensure that all of its
25348 -- constituents appear as Output items in Refined_Global.
25349 -- This routine may remove elements from In_Constits, In_Out_Constits,
25350 -- Out_Constits and Proof_In_Constits.
25352 procedure Check_Proof_In_States;
25353 -- Determine whether the corresponding Global pragma mentions Proof_In
25354 -- states with visible refinement and if so, ensure that at least one of
25355 -- its constituents appears as a Proof_In item in Refined_Global.
25356 -- This routine may remove elements from In_Constits, In_Out_Constits,
25357 -- Out_Constits and Proof_In_Constits.
25359 procedure Check_Refined_Global_List
25361 Global_Mode : Name_Id := Name_Input);
25362 -- Verify the legality of a single global list declaration. Global_Mode
25363 -- denotes the current mode in effect.
25365 procedure Collect_Global_Items
25367 Mode : Name_Id := Name_Input);
25368 -- Gather all Input, In_Out, Output and Proof_In items from node List
25369 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25370 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25371 -- and Has_Proof_In_State are set when there is at least one abstract
25372 -- state with full or partial visible refinement available in the
25373 -- corresponding mode. Flag Has_Null_State is set when at least state
25374 -- has a null refinement. Mode denotes the current global mode in
25377 function Present_Then_Remove
25379 Item : Entity_Id) return Boolean;
25380 -- Search List for a particular entity Item. If Item has been found,
25381 -- remove it from List. This routine is used to strip lists In_Constits,
25382 -- In_Out_Constits and Out_Constits of valid constituents.
25384 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
25385 -- Same as function Present_Then_Remove, but do not report the presence
25386 -- of Item in List.
25388 procedure Report_Extra_Constituents;
25389 -- Emit an error for each constituent found in lists In_Constits,
25390 -- In_Out_Constits and Out_Constits.
25392 procedure Report_Missing_Items;
25393 -- Emit an error for each global item not repeated found in list
25396 -------------------------
25397 -- Check_In_Out_States --
25398 -------------------------
25400 procedure Check_In_Out_States is
25401 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25402 -- Determine whether one of the following coverage scenarios is in
25404 -- 1) there is at least one constituent of mode In_Out or Output
25405 -- 2) there is at least one pair of constituents with modes Input
25406 -- and Output, or Proof_In and Output.
25407 -- 3) there is at least one constituent of mode Output and not all
25408 -- constituents are present.
25409 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25411 -----------------------------
25412 -- Check_Constituent_Usage --
25413 -----------------------------
25415 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25416 Constits : constant Elist_Id :=
25417 Partial_Refinement_Constituents (State_Id);
25418 Constit_Elmt : Elmt_Id;
25419 Constit_Id : Entity_Id;
25420 Has_Missing : Boolean := False;
25421 In_Out_Seen : Boolean := False;
25422 Input_Seen : Boolean := False;
25423 Output_Seen : Boolean := False;
25424 Proof_In_Seen : Boolean := False;
25427 -- Process all the constituents of the state and note their modes
25428 -- within the global refinement.
25430 if Present (Constits) then
25431 Constit_Elmt := First_Elmt (Constits);
25432 while Present (Constit_Elmt) loop
25433 Constit_Id := Node (Constit_Elmt);
25435 if Present_Then_Remove (In_Constits, Constit_Id) then
25436 Input_Seen := True;
25438 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
25439 In_Out_Seen := True;
25441 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25442 Output_Seen := True;
25444 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25446 Proof_In_Seen := True;
25449 Has_Missing := True;
25452 Next_Elmt (Constit_Elmt);
25456 -- An In_Out constituent is a valid completion
25458 if In_Out_Seen then
25461 -- A pair of one Input/Proof_In and one Output constituent is a
25462 -- valid completion.
25464 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
25467 elsif Output_Seen then
25469 -- A single Output constituent is a valid completion only when
25470 -- some of the other constituents are missing.
25472 if Has_Missing then
25475 -- Otherwise all constituents are of mode Output
25479 ("global refinement of state & must include at least one "
25480 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25484 -- The state lacks a completion. When full refinement is visible,
25485 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25486 -- refinement is visible, emit an error if the abstract state
25487 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25488 -- both are utilized, Check_State_And_Constituent_Use. will issue
25491 elsif not Input_Seen
25492 and then not In_Out_Seen
25493 and then not Output_Seen
25494 and then not Proof_In_Seen
25496 if Has_Visible_Refinement (State_Id)
25497 or else Contains (Repeat_Items, State_Id)
25500 ("missing global refinement of state &", N, State_Id);
25503 -- Otherwise the state has a malformed completion where at least
25504 -- one of the constituents has a different mode.
25508 ("global refinement of state & redefines the mode of its "
25509 & "constituents", N, State_Id);
25511 end Check_Constituent_Usage;
25515 Item_Elmt : Elmt_Id;
25516 Item_Id : Entity_Id;
25518 -- Start of processing for Check_In_Out_States
25521 -- Do not perform this check in an instance because it was already
25522 -- performed successfully in the generic template.
25524 if Is_Generic_Instance (Spec_Id) then
25527 -- Inspect the In_Out items of the corresponding Global pragma
25528 -- looking for a state with a visible refinement.
25530 elsif Has_In_Out_State and then Present (In_Out_Items) then
25531 Item_Elmt := First_Elmt (In_Out_Items);
25532 while Present (Item_Elmt) loop
25533 Item_Id := Node (Item_Elmt);
25535 -- Ensure that one of the three coverage variants is satisfied
25537 if Ekind (Item_Id) = E_Abstract_State
25538 and then Has_Non_Null_Visible_Refinement (Item_Id)
25540 Check_Constituent_Usage (Item_Id);
25543 Next_Elmt (Item_Elmt);
25546 end Check_In_Out_States;
25548 ------------------------
25549 -- Check_Input_States --
25550 ------------------------
25552 procedure Check_Input_States is
25553 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25554 -- Determine whether at least one constituent of state State_Id with
25555 -- full or partial visible refinement is used and has mode Input.
25556 -- Ensure that the remaining constituents do not have In_Out or
25557 -- Output modes. Emit an error if this is not the case
25558 -- (SPARK RM 7.2.4(5)).
25560 -----------------------------
25561 -- Check_Constituent_Usage --
25562 -----------------------------
25564 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25565 Constits : constant Elist_Id :=
25566 Partial_Refinement_Constituents (State_Id);
25567 Constit_Elmt : Elmt_Id;
25568 Constit_Id : Entity_Id;
25569 In_Seen : Boolean := False;
25572 if Present (Constits) then
25573 Constit_Elmt := First_Elmt (Constits);
25574 while Present (Constit_Elmt) loop
25575 Constit_Id := Node (Constit_Elmt);
25577 -- At least one of the constituents appears as an Input
25579 if Present_Then_Remove (In_Constits, Constit_Id) then
25582 -- A Proof_In constituent can refine an Input state as long
25583 -- as there is at least one Input constituent present.
25585 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25589 -- The constituent appears in the global refinement, but has
25590 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25592 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
25593 or else Present_Then_Remove (Out_Constits, Constit_Id)
25595 Error_Msg_Name_1 := Chars (State_Id);
25597 ("constituent & of state % must have mode `Input` in "
25598 & "global refinement", N, Constit_Id);
25601 Next_Elmt (Constit_Elmt);
25605 -- Not one of the constituents appeared as Input. Always emit an
25606 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25607 -- When only partial refinement is visible, emit an error if the
25608 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25609 -- the case where both are utilized, an error will be issued in
25610 -- Check_State_And_Constituent_Use.
25613 and then (Has_Visible_Refinement (State_Id)
25614 or else Contains (Repeat_Items, State_Id))
25617 ("global refinement of state & must include at least one "
25618 & "constituent of mode `Input`", N, State_Id);
25620 end Check_Constituent_Usage;
25624 Item_Elmt : Elmt_Id;
25625 Item_Id : Entity_Id;
25627 -- Start of processing for Check_Input_States
25630 -- Do not perform this check in an instance because it was already
25631 -- performed successfully in the generic template.
25633 if Is_Generic_Instance (Spec_Id) then
25636 -- Inspect the Input items of the corresponding Global pragma looking
25637 -- for a state with a visible refinement.
25639 elsif Has_In_State and then Present (In_Items) then
25640 Item_Elmt := First_Elmt (In_Items);
25641 while Present (Item_Elmt) loop
25642 Item_Id := Node (Item_Elmt);
25644 -- When full refinement is visible, ensure that at least one of
25645 -- the constituents is utilized and is of mode Input. When only
25646 -- partial refinement is visible, ensure that either one of
25647 -- the constituents is utilized and is of mode Input, or the
25648 -- abstract state is repeated and no constituent is utilized.
25650 if Ekind (Item_Id) = E_Abstract_State
25651 and then Has_Non_Null_Visible_Refinement (Item_Id)
25653 Check_Constituent_Usage (Item_Id);
25656 Next_Elmt (Item_Elmt);
25659 end Check_Input_States;
25661 -------------------------
25662 -- Check_Output_States --
25663 -------------------------
25665 procedure Check_Output_States is
25666 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25667 -- Determine whether all constituents of state State_Id with full
25668 -- visible refinement are used and have mode Output. Emit an error
25669 -- if this is not the case (SPARK RM 7.2.4(5)).
25671 -----------------------------
25672 -- Check_Constituent_Usage --
25673 -----------------------------
25675 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25676 Constits : constant Elist_Id :=
25677 Partial_Refinement_Constituents (State_Id);
25678 Only_Partial : constant Boolean :=
25679 not Has_Visible_Refinement (State_Id);
25680 Constit_Elmt : Elmt_Id;
25681 Constit_Id : Entity_Id;
25682 Posted : Boolean := False;
25685 if Present (Constits) then
25686 Constit_Elmt := First_Elmt (Constits);
25687 while Present (Constit_Elmt) loop
25688 Constit_Id := Node (Constit_Elmt);
25690 -- Issue an error when a constituent of State_Id is utilized
25691 -- and State_Id has only partial visible refinement
25692 -- (SPARK RM 7.2.4(3d)).
25694 if Only_Partial then
25695 if Present_Then_Remove (Out_Constits, Constit_Id)
25696 or else Present_Then_Remove (In_Constits, Constit_Id)
25698 Present_Then_Remove (In_Out_Constits, Constit_Id)
25700 Present_Then_Remove (Proof_In_Constits, Constit_Id)
25702 Error_Msg_Name_1 := Chars (State_Id);
25704 ("constituent & of state % cannot be used in global "
25705 & "refinement", N, Constit_Id);
25706 Error_Msg_Name_1 := Chars (State_Id);
25707 SPARK_Msg_N ("\use state % instead", N);
25710 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25713 -- The constituent appears in the global refinement, but has
25714 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25716 elsif Present_Then_Remove (In_Constits, Constit_Id)
25717 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25718 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
25720 Error_Msg_Name_1 := Chars (State_Id);
25722 ("constituent & of state % must have mode `Output` in "
25723 & "global refinement", N, Constit_Id);
25725 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25731 ("`Output` state & must be replaced by all its "
25732 & "constituents in global refinement", N, State_Id);
25736 ("\constituent & is missing in output list",
25740 Next_Elmt (Constit_Elmt);
25743 end Check_Constituent_Usage;
25747 Item_Elmt : Elmt_Id;
25748 Item_Id : Entity_Id;
25750 -- Start of processing for Check_Output_States
25753 -- Do not perform this check in an instance because it was already
25754 -- performed successfully in the generic template.
25756 if Is_Generic_Instance (Spec_Id) then
25759 -- Inspect the Output items of the corresponding Global pragma
25760 -- looking for a state with a visible refinement.
25762 elsif Has_Out_State and then Present (Out_Items) then
25763 Item_Elmt := First_Elmt (Out_Items);
25764 while Present (Item_Elmt) loop
25765 Item_Id := Node (Item_Elmt);
25767 -- When full refinement is visible, ensure that all of the
25768 -- constituents are utilized and they have mode Output. When
25769 -- only partial refinement is visible, ensure that no
25770 -- constituent is utilized.
25772 if Ekind (Item_Id) = E_Abstract_State
25773 and then Has_Non_Null_Visible_Refinement (Item_Id)
25775 Check_Constituent_Usage (Item_Id);
25778 Next_Elmt (Item_Elmt);
25781 end Check_Output_States;
25783 ---------------------------
25784 -- Check_Proof_In_States --
25785 ---------------------------
25787 procedure Check_Proof_In_States is
25788 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25789 -- Determine whether at least one constituent of state State_Id with
25790 -- full or partial visible refinement is used and has mode Proof_In.
25791 -- Ensure that the remaining constituents do not have Input, In_Out,
25792 -- or Output modes. Emit an error if this is not the case
25793 -- (SPARK RM 7.2.4(5)).
25795 -----------------------------
25796 -- Check_Constituent_Usage --
25797 -----------------------------
25799 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25800 Constits : constant Elist_Id :=
25801 Partial_Refinement_Constituents (State_Id);
25802 Constit_Elmt : Elmt_Id;
25803 Constit_Id : Entity_Id;
25804 Proof_In_Seen : Boolean := False;
25807 if Present (Constits) then
25808 Constit_Elmt := First_Elmt (Constits);
25809 while Present (Constit_Elmt) loop
25810 Constit_Id := Node (Constit_Elmt);
25812 -- At least one of the constituents appears as Proof_In
25814 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
25815 Proof_In_Seen := True;
25817 -- The constituent appears in the global refinement, but has
25818 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25820 elsif Present_Then_Remove (In_Constits, Constit_Id)
25821 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25822 or else Present_Then_Remove (Out_Constits, Constit_Id)
25824 Error_Msg_Name_1 := Chars (State_Id);
25826 ("constituent & of state % must have mode `Proof_In` "
25827 & "in global refinement", N, Constit_Id);
25830 Next_Elmt (Constit_Elmt);
25834 -- Not one of the constituents appeared as Proof_In. Always emit
25835 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25836 -- When only partial refinement is visible, emit an error if the
25837 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25838 -- the case where both are utilized, an error will be issued by
25839 -- Check_State_And_Constituent_Use.
25841 if not Proof_In_Seen
25842 and then (Has_Visible_Refinement (State_Id)
25843 or else Contains (Repeat_Items, State_Id))
25846 ("global refinement of state & must include at least one "
25847 & "constituent of mode `Proof_In`", N, State_Id);
25849 end Check_Constituent_Usage;
25853 Item_Elmt : Elmt_Id;
25854 Item_Id : Entity_Id;
25856 -- Start of processing for Check_Proof_In_States
25859 -- Do not perform this check in an instance because it was already
25860 -- performed successfully in the generic template.
25862 if Is_Generic_Instance (Spec_Id) then
25865 -- Inspect the Proof_In items of the corresponding Global pragma
25866 -- looking for a state with a visible refinement.
25868 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25869 Item_Elmt := First_Elmt (Proof_In_Items);
25870 while Present (Item_Elmt) loop
25871 Item_Id := Node (Item_Elmt);
25873 -- Ensure that at least one of the constituents is utilized
25874 -- and is of mode Proof_In. When only partial refinement is
25875 -- visible, ensure that either one of the constituents is
25876 -- utilized and is of mode Proof_In, or the abstract state
25877 -- is repeated and no constituent is utilized.
25879 if Ekind (Item_Id) = E_Abstract_State
25880 and then Has_Non_Null_Visible_Refinement (Item_Id)
25882 Check_Constituent_Usage (Item_Id);
25885 Next_Elmt (Item_Elmt);
25888 end Check_Proof_In_States;
25890 -------------------------------
25891 -- Check_Refined_Global_List --
25892 -------------------------------
25894 procedure Check_Refined_Global_List
25896 Global_Mode : Name_Id := Name_Input)
25898 procedure Check_Refined_Global_Item
25900 Global_Mode : Name_Id);
25901 -- Verify the legality of a single global item declaration. Parameter
25902 -- Global_Mode denotes the current mode in effect.
25904 -------------------------------
25905 -- Check_Refined_Global_Item --
25906 -------------------------------
25908 procedure Check_Refined_Global_Item
25910 Global_Mode : Name_Id)
25912 Item_Id : constant Entity_Id := Entity_Of (Item);
25914 procedure Inconsistent_Mode_Error (Expect : Name_Id);
25915 -- Issue a common error message for all mode mismatches. Expect
25916 -- denotes the expected mode.
25918 -----------------------------
25919 -- Inconsistent_Mode_Error --
25920 -----------------------------
25922 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
25925 ("global item & has inconsistent modes", Item, Item_Id);
25927 Error_Msg_Name_1 := Global_Mode;
25928 Error_Msg_Name_2 := Expect;
25929 SPARK_Msg_N ("\expected mode %, found mode %", Item);
25930 end Inconsistent_Mode_Error;
25934 Enc_State : Entity_Id := Empty;
25935 -- Encapsulating state for constituent, Empty otherwise
25937 -- Start of processing for Check_Refined_Global_Item
25940 if Ekind_In (Item_Id, E_Abstract_State,
25944 Enc_State := Find_Encapsulating_State (States, Item_Id);
25947 -- When the state or object acts as a constituent of another
25948 -- state with a visible refinement, collect it for the state
25949 -- completeness checks performed later on. Note that the item
25950 -- acts as a constituent only when the encapsulating state is
25951 -- present in pragma Global.
25953 if Present (Enc_State)
25954 and then (Has_Visible_Refinement (Enc_State)
25955 or else Has_Partial_Visible_Refinement (Enc_State))
25956 and then Contains (States, Enc_State)
25958 -- If the state has only partial visible refinement, remove it
25959 -- from the list of items that should be repeated from pragma
25962 if not Has_Visible_Refinement (Enc_State) then
25963 Present_Then_Remove (Repeat_Items, Enc_State);
25966 if Global_Mode = Name_Input then
25967 Append_New_Elmt (Item_Id, In_Constits);
25969 elsif Global_Mode = Name_In_Out then
25970 Append_New_Elmt (Item_Id, In_Out_Constits);
25972 elsif Global_Mode = Name_Output then
25973 Append_New_Elmt (Item_Id, Out_Constits);
25975 elsif Global_Mode = Name_Proof_In then
25976 Append_New_Elmt (Item_Id, Proof_In_Constits);
25979 -- When not a constituent, ensure that both occurrences of the
25980 -- item in pragmas Global and Refined_Global match. Also remove
25981 -- it when present from the list of items that should be repeated
25982 -- from pragma Global.
25985 Present_Then_Remove (Repeat_Items, Item_Id);
25987 if Contains (In_Items, Item_Id) then
25988 if Global_Mode /= Name_Input then
25989 Inconsistent_Mode_Error (Name_Input);
25992 elsif Contains (In_Out_Items, Item_Id) then
25993 if Global_Mode /= Name_In_Out then
25994 Inconsistent_Mode_Error (Name_In_Out);
25997 elsif Contains (Out_Items, Item_Id) then
25998 if Global_Mode /= Name_Output then
25999 Inconsistent_Mode_Error (Name_Output);
26002 elsif Contains (Proof_In_Items, Item_Id) then
26005 -- The item does not appear in the corresponding Global pragma,
26006 -- it must be an extra (SPARK RM 7.2.4(3)).
26009 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
26012 end Check_Refined_Global_Item;
26018 -- Start of processing for Check_Refined_Global_List
26021 -- Do not perform this check in an instance because it was already
26022 -- performed successfully in the generic template.
26024 if Is_Generic_Instance (Spec_Id) then
26027 elsif Nkind (List) = N_Null then
26030 -- Single global item declaration
26032 elsif Nkind_In (List, N_Expanded_Name,
26034 N_Selected_Component)
26036 Check_Refined_Global_Item (List, Global_Mode);
26038 -- Simple global list or moded global list declaration
26040 elsif Nkind (List) = N_Aggregate then
26042 -- The declaration of a simple global list appear as a collection
26045 if Present (Expressions (List)) then
26046 Item := First (Expressions (List));
26047 while Present (Item) loop
26048 Check_Refined_Global_Item (Item, Global_Mode);
26052 -- The declaration of a moded global list appears as a collection
26053 -- of component associations where individual choices denote
26056 elsif Present (Component_Associations (List)) then
26057 Item := First (Component_Associations (List));
26058 while Present (Item) loop
26059 Check_Refined_Global_List
26060 (List => Expression (Item),
26061 Global_Mode => Chars (First (Choices (Item))));
26069 raise Program_Error;
26075 raise Program_Error;
26077 end Check_Refined_Global_List;
26079 --------------------------
26080 -- Collect_Global_Items --
26081 --------------------------
26083 procedure Collect_Global_Items
26085 Mode : Name_Id := Name_Input)
26087 procedure Collect_Global_Item
26089 Item_Mode : Name_Id);
26090 -- Add a single item to the appropriate list. Item_Mode denotes the
26091 -- current mode in effect.
26093 -------------------------
26094 -- Collect_Global_Item --
26095 -------------------------
26097 procedure Collect_Global_Item
26099 Item_Mode : Name_Id)
26101 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
26102 -- The above handles abstract views of variables and states built
26103 -- for limited with clauses.
26106 -- Signal that the global list contains at least one abstract
26107 -- state with a visible refinement. Note that the refinement may
26108 -- be null in which case there are no constituents.
26110 if Ekind (Item_Id) = E_Abstract_State then
26111 if Has_Null_Visible_Refinement (Item_Id) then
26112 Has_Null_State := True;
26114 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26115 Append_New_Elmt (Item_Id, States);
26117 if Item_Mode = Name_Input then
26118 Has_In_State := True;
26119 elsif Item_Mode = Name_In_Out then
26120 Has_In_Out_State := True;
26121 elsif Item_Mode = Name_Output then
26122 Has_Out_State := True;
26123 elsif Item_Mode = Name_Proof_In then
26124 Has_Proof_In_State := True;
26129 -- Record global items without full visible refinement found in
26130 -- pragma Global which should be repeated in the global refinement
26131 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26133 if Ekind (Item_Id) /= E_Abstract_State
26134 or else not Has_Visible_Refinement (Item_Id)
26136 Append_New_Elmt (Item_Id, Repeat_Items);
26139 -- Add the item to the proper list
26141 if Item_Mode = Name_Input then
26142 Append_New_Elmt (Item_Id, In_Items);
26143 elsif Item_Mode = Name_In_Out then
26144 Append_New_Elmt (Item_Id, In_Out_Items);
26145 elsif Item_Mode = Name_Output then
26146 Append_New_Elmt (Item_Id, Out_Items);
26147 elsif Item_Mode = Name_Proof_In then
26148 Append_New_Elmt (Item_Id, Proof_In_Items);
26150 end Collect_Global_Item;
26156 -- Start of processing for Collect_Global_Items
26159 if Nkind (List) = N_Null then
26162 -- Single global item declaration
26164 elsif Nkind_In (List, N_Expanded_Name,
26166 N_Selected_Component)
26168 Collect_Global_Item (List, Mode);
26170 -- Single global list or moded global list declaration
26172 elsif Nkind (List) = N_Aggregate then
26174 -- The declaration of a simple global list appear as a collection
26177 if Present (Expressions (List)) then
26178 Item := First (Expressions (List));
26179 while Present (Item) loop
26180 Collect_Global_Item (Item, Mode);
26184 -- The declaration of a moded global list appears as a collection
26185 -- of component associations where individual choices denote mode.
26187 elsif Present (Component_Associations (List)) then
26188 Item := First (Component_Associations (List));
26189 while Present (Item) loop
26190 Collect_Global_Items
26191 (List => Expression (Item),
26192 Mode => Chars (First (Choices (Item))));
26200 raise Program_Error;
26203 -- To accommodate partial decoration of disabled SPARK features, this
26204 -- routine may be called with illegal input. If this is the case, do
26205 -- not raise Program_Error.
26210 end Collect_Global_Items;
26212 -------------------------
26213 -- Present_Then_Remove --
26214 -------------------------
26216 function Present_Then_Remove
26218 Item : Entity_Id) return Boolean
26223 if Present (List) then
26224 Elmt := First_Elmt (List);
26225 while Present (Elmt) loop
26226 if Node (Elmt) = Item then
26227 Remove_Elmt (List, Elmt);
26236 end Present_Then_Remove;
26238 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
26241 Ignore := Present_Then_Remove (List, Item);
26242 end Present_Then_Remove;
26244 -------------------------------
26245 -- Report_Extra_Constituents --
26246 -------------------------------
26248 procedure Report_Extra_Constituents is
26249 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
26250 -- Emit an error for every element of List
26252 ---------------------------------------
26253 -- Report_Extra_Constituents_In_List --
26254 ---------------------------------------
26256 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
26257 Constit_Elmt : Elmt_Id;
26260 if Present (List) then
26261 Constit_Elmt := First_Elmt (List);
26262 while Present (Constit_Elmt) loop
26263 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
26264 Next_Elmt (Constit_Elmt);
26267 end Report_Extra_Constituents_In_List;
26269 -- Start of processing for Report_Extra_Constituents
26272 -- Do not perform this check in an instance because it was already
26273 -- performed successfully in the generic template.
26275 if Is_Generic_Instance (Spec_Id) then
26279 Report_Extra_Constituents_In_List (In_Constits);
26280 Report_Extra_Constituents_In_List (In_Out_Constits);
26281 Report_Extra_Constituents_In_List (Out_Constits);
26282 Report_Extra_Constituents_In_List (Proof_In_Constits);
26284 end Report_Extra_Constituents;
26286 --------------------------
26287 -- Report_Missing_Items --
26288 --------------------------
26290 procedure Report_Missing_Items is
26291 Item_Elmt : Elmt_Id;
26292 Item_Id : Entity_Id;
26295 -- Do not perform this check in an instance because it was already
26296 -- performed successfully in the generic template.
26298 if Is_Generic_Instance (Spec_Id) then
26302 if Present (Repeat_Items) then
26303 Item_Elmt := First_Elmt (Repeat_Items);
26304 while Present (Item_Elmt) loop
26305 Item_Id := Node (Item_Elmt);
26306 SPARK_Msg_NE ("missing global item &", N, Item_Id);
26307 Next_Elmt (Item_Elmt);
26311 end Report_Missing_Items;
26315 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26316 Errors : constant Nat := Serious_Errors_Detected;
26318 No_Constit : Boolean;
26320 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26323 -- Do not analyze the pragma multiple times
26325 if Is_Analyzed_Pragma (N) then
26329 Spec_Id := Unique_Defining_Entity (Body_Decl);
26331 -- Use the anonymous object as the proper spec when Refined_Global
26332 -- applies to the body of a single task type. The object carries the
26333 -- proper Chars as well as all non-refined versions of pragmas.
26335 if Is_Single_Concurrent_Type (Spec_Id) then
26336 Spec_Id := Anonymous_Object (Spec_Id);
26339 Global := Get_Pragma (Spec_Id, Pragma_Global);
26340 Items := Expression (Get_Argument (N, Spec_Id));
26342 -- The subprogram declaration lacks pragma Global. This renders
26343 -- Refined_Global useless as there is nothing to refine.
26345 if No (Global) then
26347 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26348 & "& lacks aspect or pragma Global"), N, Spec_Id);
26352 -- Extract all relevant items from the corresponding Global pragma
26354 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
26356 -- Package and subprogram bodies are instantiated individually in
26357 -- a separate compiler pass. Due to this mode of instantiation, the
26358 -- refinement of a state may no longer be visible when a subprogram
26359 -- body contract is instantiated. Since the generic template is legal,
26360 -- do not perform this check in the instance to circumvent this oddity.
26362 if Is_Generic_Instance (Spec_Id) then
26365 -- Non-instance case
26368 -- The corresponding Global pragma must mention at least one
26369 -- state with a visible refinement at the point Refined_Global
26370 -- is processed. States with null refinements need Refined_Global
26371 -- pragma (SPARK RM 7.2.4(2)).
26373 if not Has_In_State
26374 and then not Has_In_Out_State
26375 and then not Has_Out_State
26376 and then not Has_Proof_In_State
26377 and then not Has_Null_State
26380 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26381 & "depend on abstract state with visible refinement"),
26385 -- The global refinement of inputs and outputs cannot be null when
26386 -- the corresponding Global pragma contains at least one item except
26387 -- in the case where we have states with null refinements.
26389 elsif Nkind (Items) = N_Null
26391 (Present (In_Items)
26392 or else Present (In_Out_Items)
26393 or else Present (Out_Items)
26394 or else Present (Proof_In_Items))
26395 and then not Has_Null_State
26398 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
26399 & "global items"), N, Spec_Id);
26404 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26405 -- This ensures that the categorization of all refined global items is
26406 -- consistent with their role.
26408 Analyze_Global_In_Decl_Part (N);
26410 -- Perform all refinement checks with respect to completeness and mode
26413 if Serious_Errors_Detected = Errors then
26414 Check_Refined_Global_List (Items);
26417 -- Store the information that no constituent is used in the global
26418 -- refinement, prior to calling checking procedures which remove items
26419 -- from the list of constituents.
26423 and then No (In_Out_Constits)
26424 and then No (Out_Constits)
26425 and then No (Proof_In_Constits);
26427 -- For Input states with visible refinement, at least one constituent
26428 -- must be used as an Input in the global refinement.
26430 if Serious_Errors_Detected = Errors then
26431 Check_Input_States;
26434 -- Verify all possible completion variants for In_Out states with
26435 -- visible refinement.
26437 if Serious_Errors_Detected = Errors then
26438 Check_In_Out_States;
26441 -- For Output states with visible refinement, all constituents must be
26442 -- used as Outputs in the global refinement.
26444 if Serious_Errors_Detected = Errors then
26445 Check_Output_States;
26448 -- For Proof_In states with visible refinement, at least one constituent
26449 -- must be used as Proof_In in the global refinement.
26451 if Serious_Errors_Detected = Errors then
26452 Check_Proof_In_States;
26455 -- Emit errors for all constituents that belong to other states with
26456 -- visible refinement that do not appear in Global.
26458 if Serious_Errors_Detected = Errors then
26459 Report_Extra_Constituents;
26462 -- Emit errors for all items in Global that are not repeated in the
26463 -- global refinement and for which there is no full visible refinement
26464 -- and, in the case of states with partial visible refinement, no
26465 -- constituent is mentioned in the global refinement.
26467 if Serious_Errors_Detected = Errors then
26468 Report_Missing_Items;
26471 -- Emit an error if no constituent is used in the global refinement
26472 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26473 -- one may be issued by the checking procedures. Do not perform this
26474 -- check in an instance because it was already performed successfully
26475 -- in the generic template.
26477 if Serious_Errors_Detected = Errors
26478 and then not Is_Generic_Instance (Spec_Id)
26479 and then not Has_Null_State
26480 and then No_Constit
26482 SPARK_Msg_N ("missing refinement", N);
26486 Set_Is_Analyzed_Pragma (N);
26487 end Analyze_Refined_Global_In_Decl_Part;
26489 ----------------------------------------
26490 -- Analyze_Refined_State_In_Decl_Part --
26491 ----------------------------------------
26493 procedure Analyze_Refined_State_In_Decl_Part
26495 Freeze_Id : Entity_Id := Empty)
26497 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
26498 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26499 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
26501 Available_States : Elist_Id := No_Elist;
26502 -- A list of all abstract states defined in the package declaration that
26503 -- are available for refinement. The list is used to report unrefined
26506 Body_States : Elist_Id := No_Elist;
26507 -- A list of all hidden states that appear in the body of the related
26508 -- package. The list is used to report unused hidden states.
26510 Constituents_Seen : Elist_Id := No_Elist;
26511 -- A list that contains all constituents processed so far. The list is
26512 -- used to detect multiple uses of the same constituent.
26514 Freeze_Posted : Boolean := False;
26515 -- A flag that controls the output of a freezing-related error (see use
26518 Refined_States_Seen : Elist_Id := No_Elist;
26519 -- A list that contains all refined states processed so far. The list is
26520 -- used to detect duplicate refinements.
26522 procedure Analyze_Refinement_Clause (Clause : Node_Id);
26523 -- Perform full analysis of a single refinement clause
26525 procedure Report_Unrefined_States (States : Elist_Id);
26526 -- Emit errors for all unrefined abstract states found in list States
26528 -------------------------------
26529 -- Analyze_Refinement_Clause --
26530 -------------------------------
26532 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
26533 AR_Constit : Entity_Id := Empty;
26534 AW_Constit : Entity_Id := Empty;
26535 ER_Constit : Entity_Id := Empty;
26536 EW_Constit : Entity_Id := Empty;
26537 -- The entities of external constituents that contain one of the
26538 -- following enabled properties: Async_Readers, Async_Writers,
26539 -- Effective_Reads and Effective_Writes.
26541 External_Constit_Seen : Boolean := False;
26542 -- Flag used to mark when at least one external constituent is part
26543 -- of the state refinement.
26545 Non_Null_Seen : Boolean := False;
26546 Null_Seen : Boolean := False;
26547 -- Flags used to detect multiple uses of null in a single clause or a
26548 -- mixture of null and non-null constituents.
26550 Part_Of_Constits : Elist_Id := No_Elist;
26551 -- A list of all candidate constituents subject to indicator Part_Of
26552 -- where the encapsulating state is the current state.
26555 State_Id : Entity_Id;
26556 -- The current state being refined
26558 procedure Analyze_Constituent (Constit : Node_Id);
26559 -- Perform full analysis of a single constituent
26561 procedure Check_External_Property
26562 (Prop_Nam : Name_Id;
26564 Constit : Entity_Id);
26565 -- Determine whether a property denoted by name Prop_Nam is present
26566 -- in the refined state. Emit an error if this is not the case. Flag
26567 -- Enabled should be set when the property applies to the refined
26568 -- state. Constit denotes the constituent (if any) which introduces
26569 -- the property in the refinement.
26571 procedure Match_State;
26572 -- Determine whether the state being refined appears in list
26573 -- Available_States. Emit an error when attempting to re-refine the
26574 -- state or when the state is not defined in the package declaration,
26575 -- otherwise remove the state from Available_States.
26577 procedure Report_Unused_Constituents (Constits : Elist_Id);
26578 -- Emit errors for all unused Part_Of constituents in list Constits
26580 -------------------------
26581 -- Analyze_Constituent --
26582 -------------------------
26584 procedure Analyze_Constituent (Constit : Node_Id) is
26585 procedure Match_Constituent (Constit_Id : Entity_Id);
26586 -- Determine whether constituent Constit denoted by its entity
26587 -- Constit_Id appears in Body_States. Emit an error when the
26588 -- constituent is not a valid hidden state of the related package
26589 -- or when it is used more than once. Otherwise remove the
26590 -- constituent from Body_States.
26592 -----------------------
26593 -- Match_Constituent --
26594 -----------------------
26596 procedure Match_Constituent (Constit_Id : Entity_Id) is
26597 procedure Collect_Constituent;
26598 -- Verify the legality of constituent Constit_Id and add it to
26599 -- the refinements of State_Id.
26601 -------------------------
26602 -- Collect_Constituent --
26603 -------------------------
26605 procedure Collect_Constituent is
26606 Constits : Elist_Id;
26609 -- The Ghost policy in effect at the point of abstract state
26610 -- declaration and constituent must match (SPARK RM 6.9(15))
26612 Check_Ghost_Refinement
26613 (State, State_Id, Constit, Constit_Id);
26615 -- A synchronized state must be refined by a synchronized
26616 -- object or another synchronized state (SPARK RM 9.6).
26618 if Is_Synchronized_State (State_Id)
26619 and then not Is_Synchronized_Object (Constit_Id)
26620 and then not Is_Synchronized_State (Constit_Id)
26623 ("constituent of synchronized state & must be "
26624 & "synchronized", Constit, State_Id);
26627 -- Add the constituent to the list of processed items to aid
26628 -- with the detection of duplicates.
26630 Append_New_Elmt (Constit_Id, Constituents_Seen);
26632 -- Collect the constituent in the list of refinement items
26633 -- and establish a relation between the refined state and
26636 Constits := Refinement_Constituents (State_Id);
26638 if No (Constits) then
26639 Constits := New_Elmt_List;
26640 Set_Refinement_Constituents (State_Id, Constits);
26643 Append_Elmt (Constit_Id, Constits);
26644 Set_Encapsulating_State (Constit_Id, State_Id);
26646 -- The state has at least one legal constituent, mark the
26647 -- start of the refinement region. The region ends when the
26648 -- body declarations end (see routine Analyze_Declarations).
26650 Set_Has_Visible_Refinement (State_Id);
26652 -- When the constituent is external, save its relevant
26653 -- property for further checks.
26655 if Async_Readers_Enabled (Constit_Id) then
26656 AR_Constit := Constit_Id;
26657 External_Constit_Seen := True;
26660 if Async_Writers_Enabled (Constit_Id) then
26661 AW_Constit := Constit_Id;
26662 External_Constit_Seen := True;
26665 if Effective_Reads_Enabled (Constit_Id) then
26666 ER_Constit := Constit_Id;
26667 External_Constit_Seen := True;
26670 if Effective_Writes_Enabled (Constit_Id) then
26671 EW_Constit := Constit_Id;
26672 External_Constit_Seen := True;
26674 end Collect_Constituent;
26678 State_Elmt : Elmt_Id;
26680 -- Start of processing for Match_Constituent
26683 -- Detect a duplicate use of a constituent
26685 if Contains (Constituents_Seen, Constit_Id) then
26687 ("duplicate use of constituent &", Constit, Constit_Id);
26691 -- The constituent is subject to a Part_Of indicator
26693 if Present (Encapsulating_State (Constit_Id)) then
26694 if Encapsulating_State (Constit_Id) = State_Id then
26695 Remove (Part_Of_Constits, Constit_Id);
26696 Collect_Constituent;
26698 -- The constituent is part of another state and is used
26699 -- incorrectly in the refinement of the current state.
26702 Error_Msg_Name_1 := Chars (State_Id);
26704 ("& cannot act as constituent of state %",
26705 Constit, Constit_Id);
26707 ("\Part_Of indicator specifies encapsulator &",
26708 Constit, Encapsulating_State (Constit_Id));
26711 -- The only other source of legal constituents is the body
26712 -- state space of the related package.
26715 if Present (Body_States) then
26716 State_Elmt := First_Elmt (Body_States);
26717 while Present (State_Elmt) loop
26719 -- Consume a valid constituent to signal that it has
26720 -- been encountered.
26722 if Node (State_Elmt) = Constit_Id then
26723 Remove_Elmt (Body_States, State_Elmt);
26724 Collect_Constituent;
26728 Next_Elmt (State_Elmt);
26732 -- Constants are part of the hidden state of a package, but
26733 -- the compiler cannot determine whether they have variable
26734 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26735 -- hidden state. Accept the constant quietly even if it is
26736 -- a visible state or lacks a Part_Of indicator.
26738 if Ekind (Constit_Id) = E_Constant then
26739 Collect_Constituent;
26741 -- If we get here, then the constituent is not a hidden
26742 -- state of the related package and may not be used in a
26743 -- refinement (SPARK RM 7.2.2(9)).
26746 Error_Msg_Name_1 := Chars (Spec_Id);
26748 ("cannot use & in refinement, constituent is not a "
26749 & "hidden state of package %", Constit, Constit_Id);
26752 end Match_Constituent;
26756 Constit_Id : Entity_Id;
26757 Constits : Elist_Id;
26759 -- Start of processing for Analyze_Constituent
26762 -- Detect multiple uses of null in a single refinement clause or a
26763 -- mixture of null and non-null constituents.
26765 if Nkind (Constit) = N_Null then
26768 ("multiple null constituents not allowed", Constit);
26770 elsif Non_Null_Seen then
26772 ("cannot mix null and non-null constituents", Constit);
26777 -- Collect the constituent in the list of refinement items
26779 Constits := Refinement_Constituents (State_Id);
26781 if No (Constits) then
26782 Constits := New_Elmt_List;
26783 Set_Refinement_Constituents (State_Id, Constits);
26786 Append_Elmt (Constit, Constits);
26788 -- The state has at least one legal constituent, mark the
26789 -- start of the refinement region. The region ends when the
26790 -- body declarations end (see Analyze_Declarations).
26792 Set_Has_Visible_Refinement (State_Id);
26795 -- Non-null constituents
26798 Non_Null_Seen := True;
26802 ("cannot mix null and non-null constituents", Constit);
26806 Resolve_State (Constit);
26808 -- Ensure that the constituent denotes a valid state or a
26809 -- whole object (SPARK RM 7.2.2(5)).
26811 if Is_Entity_Name (Constit) then
26812 Constit_Id := Entity_Of (Constit);
26814 -- When a constituent is declared after a subprogram body
26815 -- that caused "freezing" of the related contract where
26816 -- pragma Refined_State resides, the constituent appears
26817 -- undefined and carries Any_Id as its entity.
26819 -- package body Pack
26820 -- with Refined_State => (State => Constit)
26823 -- with Refined_Global => (Input => Constit)
26831 if Constit_Id = Any_Id then
26832 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
26834 -- Emit a specialized info message when the contract of
26835 -- the related package body was "frozen" by another body.
26836 -- Note that it is not possible to precisely identify why
26837 -- the constituent is undefined because it is not visible
26838 -- when pragma Refined_State is analyzed. This message is
26839 -- a reasonable approximation.
26841 if Present (Freeze_Id) and then not Freeze_Posted then
26842 Freeze_Posted := True;
26844 Error_Msg_Name_1 := Chars (Body_Id);
26845 Error_Msg_Sloc := Sloc (Freeze_Id);
26847 ("body & declared # freezes the contract of %",
26850 ("\all constituents must be declared before body #",
26853 -- A misplaced constituent is a critical error because
26854 -- pragma Refined_Depends or Refined_Global depends on
26855 -- the proper link between a state and a constituent.
26856 -- Stop the compilation, as this leads to a multitude
26857 -- of misleading cascaded errors.
26859 raise Program_Error;
26862 -- The constituent is a valid state or object
26864 elsif Ekind_In (Constit_Id, E_Abstract_State,
26868 Match_Constituent (Constit_Id);
26870 -- The variable may eventually become a constituent of a
26871 -- single protected/task type. Record the reference now
26872 -- and verify its legality when analyzing the contract of
26873 -- the variable (SPARK RM 9.3).
26875 if Ekind (Constit_Id) = E_Variable then
26876 Record_Possible_Part_Of_Reference
26877 (Var_Id => Constit_Id,
26881 -- Otherwise the constituent is illegal
26885 ("constituent & must denote object or state",
26886 Constit, Constit_Id);
26889 -- The constituent is illegal
26892 SPARK_Msg_N ("malformed constituent", Constit);
26895 end Analyze_Constituent;
26897 -----------------------------
26898 -- Check_External_Property --
26899 -----------------------------
26901 procedure Check_External_Property
26902 (Prop_Nam : Name_Id;
26904 Constit : Entity_Id)
26907 -- The property is missing in the declaration of the state, but
26908 -- a constituent is introducing it in the state refinement
26909 -- (SPARK RM 7.2.8(2)).
26911 if not Enabled and then Present (Constit) then
26912 Error_Msg_Name_1 := Prop_Nam;
26913 Error_Msg_Name_2 := Chars (State_Id);
26915 ("constituent & introduces external property % in refinement "
26916 & "of state %", State, Constit);
26918 Error_Msg_Sloc := Sloc (State_Id);
26920 ("\property is missing in abstract state declaration #",
26923 end Check_External_Property;
26929 procedure Match_State is
26930 State_Elmt : Elmt_Id;
26933 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26935 if Contains (Refined_States_Seen, State_Id) then
26937 ("duplicate refinement of state &", State, State_Id);
26941 -- Inspect the abstract states defined in the package declaration
26942 -- looking for a match.
26944 State_Elmt := First_Elmt (Available_States);
26945 while Present (State_Elmt) loop
26947 -- A valid abstract state is being refined in the body. Add
26948 -- the state to the list of processed refined states to aid
26949 -- with the detection of duplicate refinements. Remove the
26950 -- state from Available_States to signal that it has already
26953 if Node (State_Elmt) = State_Id then
26954 Append_New_Elmt (State_Id, Refined_States_Seen);
26955 Remove_Elmt (Available_States, State_Elmt);
26959 Next_Elmt (State_Elmt);
26962 -- If we get here, we are refining a state that is not defined in
26963 -- the package declaration.
26965 Error_Msg_Name_1 := Chars (Spec_Id);
26967 ("cannot refine state, & is not defined in package %",
26971 --------------------------------
26972 -- Report_Unused_Constituents --
26973 --------------------------------
26975 procedure Report_Unused_Constituents (Constits : Elist_Id) is
26976 Constit_Elmt : Elmt_Id;
26977 Constit_Id : Entity_Id;
26978 Posted : Boolean := False;
26981 if Present (Constits) then
26982 Constit_Elmt := First_Elmt (Constits);
26983 while Present (Constit_Elmt) loop
26984 Constit_Id := Node (Constit_Elmt);
26986 -- Generate an error message of the form:
26988 -- state ... has unused Part_Of constituents
26989 -- abstract state ... defined at ...
26990 -- constant ... defined at ...
26991 -- variable ... defined at ...
26996 ("state & has unused Part_Of constituents",
27000 Error_Msg_Sloc := Sloc (Constit_Id);
27002 if Ekind (Constit_Id) = E_Abstract_State then
27004 ("\abstract state & defined #", State, Constit_Id);
27006 elsif Ekind (Constit_Id) = E_Constant then
27008 ("\constant & defined #", State, Constit_Id);
27011 pragma Assert (Ekind (Constit_Id) = E_Variable);
27012 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
27015 Next_Elmt (Constit_Elmt);
27018 end Report_Unused_Constituents;
27020 -- Local declarations
27022 Body_Ref : Node_Id;
27023 Body_Ref_Elmt : Elmt_Id;
27025 Extra_State : Node_Id;
27027 -- Start of processing for Analyze_Refinement_Clause
27030 -- A refinement clause appears as a component association where the
27031 -- sole choice is the state and the expressions are the constituents.
27032 -- This is a syntax error, always report.
27034 if Nkind (Clause) /= N_Component_Association then
27035 Error_Msg_N ("malformed state refinement clause", Clause);
27039 -- Analyze the state name of a refinement clause
27041 State := First (Choices (Clause));
27044 Resolve_State (State);
27046 -- Ensure that the state name denotes a valid abstract state that is
27047 -- defined in the spec of the related package.
27049 if Is_Entity_Name (State) then
27050 State_Id := Entity_Of (State);
27052 -- When the abstract state is undefined, it appears as Any_Id. Do
27053 -- not continue with the analysis of the clause.
27055 if State_Id = Any_Id then
27058 -- Catch any attempts to re-refine a state or refine a state that
27059 -- is not defined in the package declaration.
27061 elsif Ekind (State_Id) = E_Abstract_State then
27065 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
27069 -- References to a state with visible refinement are illegal.
27070 -- When nested packages are involved, detecting such references is
27071 -- tricky because pragma Refined_State is analyzed later than the
27072 -- offending pragma Depends or Global. References that occur in
27073 -- such nested context are stored in a list. Emit errors for all
27074 -- references found in Body_References (SPARK RM 6.1.4(8)).
27076 if Present (Body_References (State_Id)) then
27077 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
27078 while Present (Body_Ref_Elmt) loop
27079 Body_Ref := Node (Body_Ref_Elmt);
27081 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
27082 Error_Msg_Sloc := Sloc (State);
27083 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
27085 Next_Elmt (Body_Ref_Elmt);
27089 -- The state name is illegal. This is a syntax error, always report.
27092 Error_Msg_N ("malformed state name in refinement clause", State);
27096 -- A refinement clause may only refine one state at a time
27098 Extra_State := Next (State);
27100 if Present (Extra_State) then
27102 ("refinement clause cannot cover multiple states", Extra_State);
27105 -- Replicate the Part_Of constituents of the refined state because
27106 -- the algorithm will consume items.
27108 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
27110 -- Analyze all constituents of the refinement. Multiple constituents
27111 -- appear as an aggregate.
27113 Constit := Expression (Clause);
27115 if Nkind (Constit) = N_Aggregate then
27116 if Present (Component_Associations (Constit)) then
27118 ("constituents of refinement clause must appear in "
27119 & "positional form", Constit);
27121 else pragma Assert (Present (Expressions (Constit)));
27122 Constit := First (Expressions (Constit));
27123 while Present (Constit) loop
27124 Analyze_Constituent (Constit);
27129 -- Various forms of a single constituent. Note that these may include
27130 -- malformed constituents.
27133 Analyze_Constituent (Constit);
27136 -- Verify that external constituents do not introduce new external
27137 -- property in the state refinement (SPARK RM 7.2.8(2)).
27139 if Is_External_State (State_Id) then
27140 Check_External_Property
27141 (Prop_Nam => Name_Async_Readers,
27142 Enabled => Async_Readers_Enabled (State_Id),
27143 Constit => AR_Constit);
27145 Check_External_Property
27146 (Prop_Nam => Name_Async_Writers,
27147 Enabled => Async_Writers_Enabled (State_Id),
27148 Constit => AW_Constit);
27150 Check_External_Property
27151 (Prop_Nam => Name_Effective_Reads,
27152 Enabled => Effective_Reads_Enabled (State_Id),
27153 Constit => ER_Constit);
27155 Check_External_Property
27156 (Prop_Nam => Name_Effective_Writes,
27157 Enabled => Effective_Writes_Enabled (State_Id),
27158 Constit => EW_Constit);
27160 -- When a refined state is not external, it should not have external
27161 -- constituents (SPARK RM 7.2.8(1)).
27163 elsif External_Constit_Seen then
27165 ("non-external state & cannot contain external constituents in "
27166 & "refinement", State, State_Id);
27169 -- Ensure that all Part_Of candidate constituents have been mentioned
27170 -- in the refinement clause.
27172 Report_Unused_Constituents (Part_Of_Constits);
27173 end Analyze_Refinement_Clause;
27175 -----------------------------
27176 -- Report_Unrefined_States --
27177 -----------------------------
27179 procedure Report_Unrefined_States (States : Elist_Id) is
27180 State_Elmt : Elmt_Id;
27183 if Present (States) then
27184 State_Elmt := First_Elmt (States);
27185 while Present (State_Elmt) loop
27187 ("abstract state & must be refined", Node (State_Elmt));
27189 Next_Elmt (State_Elmt);
27192 end Report_Unrefined_States;
27194 -- Local declarations
27196 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27199 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27202 -- Do not analyze the pragma multiple times
27204 if Is_Analyzed_Pragma (N) then
27208 -- Replicate the abstract states declared by the package because the
27209 -- matching algorithm will consume states.
27211 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
27213 -- Gather all abstract states and objects declared in the visible
27214 -- state space of the package body. These items must be utilized as
27215 -- constituents in a state refinement.
27217 Body_States := Collect_Body_States (Body_Id);
27219 -- Multiple non-null state refinements appear as an aggregate
27221 if Nkind (Clauses) = N_Aggregate then
27222 if Present (Expressions (Clauses)) then
27224 ("state refinements must appear as component associations",
27227 else pragma Assert (Present (Component_Associations (Clauses)));
27228 Clause := First (Component_Associations (Clauses));
27229 while Present (Clause) loop
27230 Analyze_Refinement_Clause (Clause);
27235 -- Various forms of a single state refinement. Note that these may
27236 -- include malformed refinements.
27239 Analyze_Refinement_Clause (Clauses);
27242 -- List all abstract states that were left unrefined
27244 Report_Unrefined_States (Available_States);
27246 Set_Is_Analyzed_Pragma (N);
27247 end Analyze_Refined_State_In_Decl_Part;
27249 ------------------------------------
27250 -- Analyze_Test_Case_In_Decl_Part --
27251 ------------------------------------
27253 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
27254 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27255 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27257 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
27258 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27259 -- denoted by Arg_Nam.
27261 ------------------------------
27262 -- Preanalyze_Test_Case_Arg --
27263 ------------------------------
27265 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
27269 -- Preanalyze the original aspect argument for ASIS or for a generic
27270 -- subprogram to properly capture global references.
27272 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
27276 Arg_Nam => Arg_Nam,
27277 From_Aspect => True);
27279 if Present (Arg) then
27280 Preanalyze_Assert_Expression
27281 (Expression (Arg), Standard_Boolean);
27285 Arg := Test_Case_Arg (N, Arg_Nam);
27287 if Present (Arg) then
27288 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
27290 end Preanalyze_Test_Case_Arg;
27294 Restore_Scope : Boolean := False;
27296 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27299 -- Do not analyze the pragma multiple times
27301 if Is_Analyzed_Pragma (N) then
27305 -- Ensure that the formal parameters are visible when analyzing all
27306 -- clauses. This falls out of the general rule of aspects pertaining
27307 -- to subprogram declarations.
27309 if not In_Open_Scopes (Spec_Id) then
27310 Restore_Scope := True;
27311 Push_Scope (Spec_Id);
27313 if Is_Generic_Subprogram (Spec_Id) then
27314 Install_Generic_Formals (Spec_Id);
27316 Install_Formals (Spec_Id);
27320 Preanalyze_Test_Case_Arg (Name_Requires);
27321 Preanalyze_Test_Case_Arg (Name_Ensures);
27323 if Restore_Scope then
27327 -- Currently it is not possible to inline pre/postconditions on a
27328 -- subprogram subject to pragma Inline_Always.
27330 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27332 Set_Is_Analyzed_Pragma (N);
27333 end Analyze_Test_Case_In_Decl_Part;
27339 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
27344 if Present (List) then
27345 Elmt := First_Elmt (List);
27346 while Present (Elmt) loop
27347 if Nkind (Node (Elmt)) = N_Defining_Identifier then
27350 Id := Entity_Of (Node (Elmt));
27353 if Id = Item_Id then
27364 -----------------------------------
27365 -- Build_Pragma_Check_Equivalent --
27366 -----------------------------------
27368 function Build_Pragma_Check_Equivalent
27370 Subp_Id : Entity_Id := Empty;
27371 Inher_Id : Entity_Id := Empty;
27372 Keep_Pragma_Id : Boolean := False) return Node_Id
27374 function Suppress_Reference (N : Node_Id) return Traverse_Result;
27375 -- Detect whether node N references a formal parameter subject to
27376 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27377 -- to False to suppress the generation of a reference when analyzing
27380 ------------------------
27381 -- Suppress_Reference --
27382 ------------------------
27384 function Suppress_Reference (N : Node_Id) return Traverse_Result is
27385 Formal : Entity_Id;
27388 if Is_Entity_Name (N) and then Present (Entity (N)) then
27389 Formal := Entity (N);
27391 -- The formal parameter is subject to pragma Unreferenced. Prevent
27392 -- the generation of references by resetting the Comes_From_Source
27395 if Is_Formal (Formal)
27396 and then Has_Pragma_Unreferenced (Formal)
27398 Set_Comes_From_Source (N, False);
27403 end Suppress_Reference;
27405 procedure Suppress_References is
27406 new Traverse_Proc (Suppress_Reference);
27410 Loc : constant Source_Ptr := Sloc (Prag);
27411 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27412 Check_Prag : Node_Id;
27416 Needs_Wrapper : Boolean;
27417 pragma Unreferenced (Needs_Wrapper);
27419 -- Start of processing for Build_Pragma_Check_Equivalent
27422 -- When the pre- or postcondition is inherited, map the formals of the
27423 -- inherited subprogram to those of the current subprogram. In addition,
27424 -- map primitive operations of the parent type into the corresponding
27425 -- primitive operations of the descendant.
27427 if Present (Inher_Id) then
27428 pragma Assert (Present (Subp_Id));
27430 Update_Primitives_Mapping (Inher_Id, Subp_Id);
27432 -- Use generic machinery to copy inherited pragma, as if it were an
27433 -- instantiation, resetting source locations appropriately, so that
27434 -- expressions inside the inherited pragma use chained locations.
27435 -- This is used in particular in GNATprove to locate precisely
27436 -- messages on a given inherited pragma.
27438 Set_Copied_Sloc_For_Inherited_Pragma
27439 (Unit_Declaration_Node (Subp_Id), Inher_Id);
27440 Check_Prag := New_Copy_Tree (Source => Prag);
27442 -- Build the inherited class-wide condition
27444 Build_Class_Wide_Expression
27445 (Prag => Check_Prag,
27447 Par_Subp => Inher_Id,
27448 Adjust_Sloc => True,
27449 Needs_Wrapper => Needs_Wrapper);
27451 -- If not an inherited condition simply copy the original pragma
27454 Check_Prag := New_Copy_Tree (Source => Prag);
27457 -- Mark the pragma as being internally generated and reset the Analyzed
27460 Set_Analyzed (Check_Prag, False);
27461 Set_Comes_From_Source (Check_Prag, False);
27463 -- The tree of the original pragma may contain references to the
27464 -- formal parameters of the related subprogram. At the same time
27465 -- the corresponding body may mark the formals as unreferenced:
27467 -- procedure Proc (Formal : ...)
27468 -- with Pre => Formal ...;
27470 -- procedure Proc (Formal : ...) is
27471 -- pragma Unreferenced (Formal);
27474 -- This creates problems because all pragma Check equivalents are
27475 -- analyzed at the end of the body declarations. Since all source
27476 -- references have already been accounted for, reset any references
27477 -- to such formals in the generated pragma Check equivalent.
27479 Suppress_References (Check_Prag);
27481 if Present (Corresponding_Aspect (Prag)) then
27482 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
27487 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27488 -- the copied pragma in the newly created pragma, convert the copy into
27489 -- pragma Check by correcting the name and adding a check_kind argument.
27491 if not Keep_Pragma_Id then
27492 Set_Class_Present (Check_Prag, False);
27494 Set_Pragma_Identifier
27495 (Check_Prag, Make_Identifier (Loc, Name_Check));
27497 Prepend_To (Pragma_Argument_Associations (Check_Prag),
27498 Make_Pragma_Argument_Association (Loc,
27499 Expression => Make_Identifier (Loc, Nam)));
27502 -- Update the error message when the pragma is inherited
27504 if Present (Inher_Id) then
27505 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
27507 if Chars (Msg_Arg) = Name_Message then
27508 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
27510 -- Insert "inherited" to improve the error message
27512 if Name_Buffer (1 .. 8) = "failed p" then
27513 Insert_Str_In_Name_Buffer ("inherited ", 8);
27514 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
27520 end Build_Pragma_Check_Equivalent;
27522 -----------------------------
27523 -- Check_Applicable_Policy --
27524 -----------------------------
27526 procedure Check_Applicable_Policy (N : Node_Id) is
27530 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
27533 -- No effect if not valid assertion kind name
27535 if not Is_Valid_Assertion_Kind (Ename) then
27539 -- Loop through entries in check policy list
27541 PP := Opt.Check_Policy_List;
27542 while Present (PP) loop
27544 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27545 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27549 or else Pnm = Name_Assertion
27550 or else (Pnm = Name_Statement_Assertions
27551 and then Nam_In (Ename, Name_Assert,
27552 Name_Assert_And_Cut,
27554 Name_Loop_Invariant,
27555 Name_Loop_Variant))
27557 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
27563 Set_Is_Ignored (N, True);
27564 Set_Is_Checked (N, False);
27569 Set_Is_Checked (N, True);
27570 Set_Is_Ignored (N, False);
27572 when Name_Disable =>
27573 Set_Is_Ignored (N, True);
27574 Set_Is_Checked (N, False);
27575 Set_Is_Disabled (N, True);
27577 -- That should be exhaustive, the null here is a defence
27578 -- against a malformed tree from previous errors.
27587 PP := Next_Pragma (PP);
27591 -- If there are no specific entries that matched, then we let the
27592 -- setting of assertions govern. Note that this provides the needed
27593 -- compatibility with the RM for the cases of assertion, invariant,
27594 -- precondition, predicate, and postcondition.
27596 if Assertions_Enabled then
27597 Set_Is_Checked (N, True);
27598 Set_Is_Ignored (N, False);
27600 Set_Is_Checked (N, False);
27601 Set_Is_Ignored (N, True);
27603 end Check_Applicable_Policy;
27605 -------------------------------
27606 -- Check_External_Properties --
27607 -------------------------------
27609 procedure Check_External_Properties
27617 -- All properties enabled
27619 if AR and AW and ER and EW then
27622 -- Async_Readers + Effective_Writes
27623 -- Async_Readers + Async_Writers + Effective_Writes
27625 elsif AR and EW and not ER then
27628 -- Async_Writers + Effective_Reads
27629 -- Async_Readers + Async_Writers + Effective_Reads
27631 elsif AW and ER and not EW then
27634 -- Async_Readers + Async_Writers
27636 elsif AR and AW and not ER and not EW then
27641 elsif AR and not AW and not ER and not EW then
27646 elsif AW and not AR and not ER and not EW then
27651 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27654 end Check_External_Properties;
27660 function Check_Kind (Nam : Name_Id) return Name_Id is
27664 -- Loop through entries in check policy list
27666 PP := Opt.Check_Policy_List;
27667 while Present (PP) loop
27669 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27670 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27674 or else (Pnm = Name_Assertion
27675 and then Is_Valid_Assertion_Kind (Nam))
27676 or else (Pnm = Name_Statement_Assertions
27677 and then Nam_In (Nam, Name_Assert,
27678 Name_Assert_And_Cut,
27680 Name_Loop_Invariant,
27681 Name_Loop_Variant))
27683 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
27692 return Name_Ignore;
27694 when Name_Disable =>
27695 return Name_Disable;
27698 raise Program_Error;
27702 PP := Next_Pragma (PP);
27707 -- If there are no specific entries that matched, then we let the
27708 -- setting of assertions govern. Note that this provides the needed
27709 -- compatibility with the RM for the cases of assertion, invariant,
27710 -- precondition, predicate, and postcondition.
27712 if Assertions_Enabled then
27715 return Name_Ignore;
27719 ---------------------------
27720 -- Check_Missing_Part_Of --
27721 ---------------------------
27723 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
27724 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
27725 -- Determine whether a package denoted by Pack_Id declares at least one
27728 -----------------------
27729 -- Has_Visible_State --
27730 -----------------------
27732 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
27733 Item_Id : Entity_Id;
27736 -- Traverse the entity chain of the package trying to find at least
27737 -- one visible abstract state, variable or a package [instantiation]
27738 -- that declares a visible state.
27740 Item_Id := First_Entity (Pack_Id);
27741 while Present (Item_Id)
27742 and then not In_Private_Part (Item_Id)
27744 -- Do not consider internally generated items
27746 if not Comes_From_Source (Item_Id) then
27749 -- A visible state has been found
27751 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
27754 -- Recursively peek into nested packages and instantiations
27756 elsif Ekind (Item_Id) = E_Package
27757 and then Has_Visible_State (Item_Id)
27762 Next_Entity (Item_Id);
27766 end Has_Visible_State;
27770 Pack_Id : Entity_Id;
27771 Placement : State_Space_Kind;
27773 -- Start of processing for Check_Missing_Part_Of
27776 -- Do not consider abstract states, variables or package instantiations
27777 -- coming from an instance as those always inherit the Part_Of indicator
27778 -- of the instance itself.
27780 if In_Instance then
27783 -- Do not consider internally generated entities as these can never
27784 -- have a Part_Of indicator.
27786 elsif not Comes_From_Source (Item_Id) then
27789 -- Perform these checks only when SPARK_Mode is enabled as they will
27790 -- interfere with standard Ada rules and produce false positives.
27792 elsif SPARK_Mode /= On then
27795 -- Do not consider constants, because the compiler cannot accurately
27796 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27797 -- act as a hidden state of a package.
27799 elsif Ekind (Item_Id) = E_Constant then
27803 -- Find where the abstract state, variable or package instantiation
27804 -- lives with respect to the state space.
27806 Find_Placement_In_State_Space
27807 (Item_Id => Item_Id,
27808 Placement => Placement,
27809 Pack_Id => Pack_Id);
27811 -- Items that appear in a non-package construct (subprogram, block, etc)
27812 -- do not require a Part_Of indicator because they can never act as a
27815 if Placement = Not_In_Package then
27818 -- An item declared in the body state space of a package always act as a
27819 -- constituent and does not need explicit Part_Of indicator.
27821 elsif Placement = Body_State_Space then
27824 -- In general an item declared in the visible state space of a package
27825 -- does not require a Part_Of indicator. The only exception is when the
27826 -- related package is a private child unit in which case Part_Of must
27827 -- denote a state in the parent unit or in one of its descendants.
27829 elsif Placement = Visible_State_Space then
27830 if Is_Child_Unit (Pack_Id)
27831 and then Is_Private_Descendant (Pack_Id)
27833 -- A package instantiation does not need a Part_Of indicator when
27834 -- the related generic template has no visible state.
27836 if Ekind (Item_Id) = E_Package
27837 and then Is_Generic_Instance (Item_Id)
27838 and then not Has_Visible_State (Item_Id)
27842 -- All other cases require Part_Of
27846 ("indicator Part_Of is required in this context "
27847 & "(SPARK RM 7.2.6(3))", Item_Id);
27848 Error_Msg_Name_1 := Chars (Pack_Id);
27850 ("\& is declared in the visible part of private child "
27851 & "unit %", Item_Id);
27855 -- When the item appears in the private state space of a packge, it must
27856 -- be a part of some state declared by the said package.
27858 else pragma Assert (Placement = Private_State_Space);
27860 -- The related package does not declare a state, the item cannot act
27861 -- as a Part_Of constituent.
27863 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
27866 -- A package instantiation does not need a Part_Of indicator when the
27867 -- related generic template has no visible state.
27869 elsif Ekind (Pack_Id) = E_Package
27870 and then Is_Generic_Instance (Pack_Id)
27871 and then not Has_Visible_State (Pack_Id)
27875 -- All other cases require Part_Of
27879 ("indicator Part_Of is required in this context "
27880 & "(SPARK RM 7.2.6(2))", Item_Id);
27881 Error_Msg_Name_1 := Chars (Pack_Id);
27883 ("\& is declared in the private part of package %", Item_Id);
27886 end Check_Missing_Part_Of;
27888 ---------------------------------------------------
27889 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27890 ---------------------------------------------------
27892 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27894 Spec_Id : Entity_Id)
27897 if Warn_On_Redundant_Constructs
27898 and then Has_Pragma_Inline_Always (Spec_Id)
27900 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27902 if From_Aspect_Specification (Prag) then
27904 ("aspect % not enforced on inlined subprogram &?r?",
27905 Corresponding_Aspect (Prag), Spec_Id);
27908 ("pragma % not enforced on inlined subprogram &?r?",
27912 end Check_Postcondition_Use_In_Inlined_Subprogram;
27914 -------------------------------------
27915 -- Check_State_And_Constituent_Use --
27916 -------------------------------------
27918 procedure Check_State_And_Constituent_Use
27919 (States : Elist_Id;
27920 Constits : Elist_Id;
27923 Constit_Elmt : Elmt_Id;
27924 Constit_Id : Entity_Id;
27925 State_Id : Entity_Id;
27928 -- Nothing to do if there are no states or constituents
27930 if No (States) or else No (Constits) then
27934 -- Inspect the list of constituents and try to determine whether its
27935 -- encapsulating state is in list States.
27937 Constit_Elmt := First_Elmt (Constits);
27938 while Present (Constit_Elmt) loop
27939 Constit_Id := Node (Constit_Elmt);
27941 -- Determine whether the constituent is part of an encapsulating
27942 -- state that appears in the same context and if this is the case,
27943 -- emit an error (SPARK RM 7.2.6(7)).
27945 State_Id := Find_Encapsulating_State (States, Constit_Id);
27947 if Present (State_Id) then
27948 Error_Msg_Name_1 := Chars (Constit_Id);
27950 ("cannot mention state & and its constituent % in the same "
27951 & "context", Context, State_Id);
27955 Next_Elmt (Constit_Elmt);
27957 end Check_State_And_Constituent_Use;
27959 ---------------------------------------------
27960 -- Collect_Inherited_Class_Wide_Conditions --
27961 ---------------------------------------------
27963 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27964 Parent_Subp : constant Entity_Id :=
27965 Ultimate_Alias (Overridden_Operation (Subp));
27966 -- The Overridden_Operation may itself be inherited and as such have no
27967 -- explicit contract.
27969 Prags : constant Node_Id := Contract (Parent_Subp);
27970 In_Spec_Expr : Boolean;
27971 Installed : Boolean;
27973 New_Prag : Node_Id;
27976 Installed := False;
27978 -- Iterate over the contract of the overridden subprogram to find all
27979 -- inherited class-wide pre- and postconditions.
27981 if Present (Prags) then
27982 Prag := Pre_Post_Conditions (Prags);
27984 while Present (Prag) loop
27985 if Nam_In (Pragma_Name_Unmapped (Prag),
27986 Name_Precondition, Name_Postcondition)
27987 and then Class_Present (Prag)
27989 -- The generated pragma must be analyzed in the context of
27990 -- the subprogram, to make its formals visible. In addition,
27991 -- we must inhibit freezing and full analysis because the
27992 -- controlling type of the subprogram is not frozen yet, and
27993 -- may have further primitives.
27995 if not Installed then
27998 Install_Formals (Subp);
27999 In_Spec_Expr := In_Spec_Expression;
28000 In_Spec_Expression := True;
28004 Build_Pragma_Check_Equivalent
28005 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
28007 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
28008 Preanalyze (New_Prag);
28010 -- Prevent further analysis in subsequent processing of the
28011 -- current list of declarations
28013 Set_Analyzed (New_Prag);
28016 Prag := Next_Pragma (Prag);
28020 In_Spec_Expression := In_Spec_Expr;
28024 end Collect_Inherited_Class_Wide_Conditions;
28026 ---------------------------------------
28027 -- Collect_Subprogram_Inputs_Outputs --
28028 ---------------------------------------
28030 procedure Collect_Subprogram_Inputs_Outputs
28031 (Subp_Id : Entity_Id;
28032 Synthesize : Boolean := False;
28033 Subp_Inputs : in out Elist_Id;
28034 Subp_Outputs : in out Elist_Id;
28035 Global_Seen : out Boolean)
28037 procedure Collect_Dependency_Clause (Clause : Node_Id);
28038 -- Collect all relevant items from a dependency clause
28040 procedure Collect_Global_List
28042 Mode : Name_Id := Name_Input);
28043 -- Collect all relevant items from a global list
28045 -------------------------------
28046 -- Collect_Dependency_Clause --
28047 -------------------------------
28049 procedure Collect_Dependency_Clause (Clause : Node_Id) is
28050 procedure Collect_Dependency_Item
28052 Is_Input : Boolean);
28053 -- Add an item to the proper subprogram input or output collection
28055 -----------------------------
28056 -- Collect_Dependency_Item --
28057 -----------------------------
28059 procedure Collect_Dependency_Item
28061 Is_Input : Boolean)
28066 -- Nothing to collect when the item is null
28068 if Nkind (Item) = N_Null then
28071 -- Ditto for attribute 'Result
28073 elsif Is_Attribute_Result (Item) then
28076 -- Multiple items appear as an aggregate
28078 elsif Nkind (Item) = N_Aggregate then
28079 Extra := First (Expressions (Item));
28080 while Present (Extra) loop
28081 Collect_Dependency_Item (Extra, Is_Input);
28085 -- Otherwise this is a solitary item
28089 Append_New_Elmt (Item, Subp_Inputs);
28091 Append_New_Elmt (Item, Subp_Outputs);
28094 end Collect_Dependency_Item;
28096 -- Start of processing for Collect_Dependency_Clause
28099 if Nkind (Clause) = N_Null then
28102 -- A dependency cause appears as component association
28104 elsif Nkind (Clause) = N_Component_Association then
28105 Collect_Dependency_Item
28106 (Item => Expression (Clause),
28109 Collect_Dependency_Item
28110 (Item => First (Choices (Clause)),
28111 Is_Input => False);
28113 -- To accommodate partial decoration of disabled SPARK features, this
28114 -- routine may be called with illegal input. If this is the case, do
28115 -- not raise Program_Error.
28120 end Collect_Dependency_Clause;
28122 -------------------------
28123 -- Collect_Global_List --
28124 -------------------------
28126 procedure Collect_Global_List
28128 Mode : Name_Id := Name_Input)
28130 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
28131 -- Add an item to the proper subprogram input or output collection
28133 -------------------------
28134 -- Collect_Global_Item --
28135 -------------------------
28137 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
28139 if Nam_In (Mode, Name_In_Out, Name_Input) then
28140 Append_New_Elmt (Item, Subp_Inputs);
28143 if Nam_In (Mode, Name_In_Out, Name_Output) then
28144 Append_New_Elmt (Item, Subp_Outputs);
28146 end Collect_Global_Item;
28153 -- Start of processing for Collect_Global_List
28156 if Nkind (List) = N_Null then
28159 -- Single global item declaration
28161 elsif Nkind_In (List, N_Expanded_Name,
28163 N_Selected_Component)
28165 Collect_Global_Item (List, Mode);
28167 -- Simple global list or moded global list declaration
28169 elsif Nkind (List) = N_Aggregate then
28170 if Present (Expressions (List)) then
28171 Item := First (Expressions (List));
28172 while Present (Item) loop
28173 Collect_Global_Item (Item, Mode);
28178 Assoc := First (Component_Associations (List));
28179 while Present (Assoc) loop
28180 Collect_Global_List
28181 (List => Expression (Assoc),
28182 Mode => Chars (First (Choices (Assoc))));
28187 -- To accommodate partial decoration of disabled SPARK features, this
28188 -- routine may be called with illegal input. If this is the case, do
28189 -- not raise Program_Error.
28194 end Collect_Global_List;
28201 Formal : Entity_Id;
28203 Spec_Id : Entity_Id;
28204 Subp_Decl : Node_Id;
28207 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28210 Global_Seen := False;
28212 -- Process all formal parameters of entries, [generic] subprograms, and
28215 if Ekind_In (Subp_Id, E_Entry,
28218 E_Generic_Function,
28219 E_Generic_Procedure,
28223 Subp_Decl := Unit_Declaration_Node (Subp_Id);
28224 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28226 -- Process all [generic] formal parameters
28228 Formal := First_Entity (Spec_Id);
28229 while Present (Formal) loop
28230 if Ekind_In (Formal, E_Generic_In_Parameter,
28231 E_In_Out_Parameter,
28234 Append_New_Elmt (Formal, Subp_Inputs);
28237 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
28238 E_In_Out_Parameter,
28241 Append_New_Elmt (Formal, Subp_Outputs);
28243 -- Out parameters can act as inputs when the related type is
28244 -- tagged, unconstrained array, unconstrained record, or record
28245 -- with unconstrained components.
28247 if Ekind (Formal) = E_Out_Parameter
28248 and then Is_Unconstrained_Or_Tagged_Item (Formal)
28250 Append_New_Elmt (Formal, Subp_Inputs);
28254 Next_Entity (Formal);
28257 -- Otherwise the input denotes a task type, a task body, or the
28258 -- anonymous object created for a single task type.
28260 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
28261 or else Is_Single_Task_Object (Subp_Id)
28263 Subp_Decl := Declaration_Node (Subp_Id);
28264 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28267 -- When processing an entry, subprogram or task body, look for pragmas
28268 -- Refined_Depends and Refined_Global as they specify the inputs and
28271 if Is_Entry_Body (Subp_Id)
28272 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
28274 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
28275 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
28277 -- Subprogram declaration or stand alone body case, look for pragmas
28278 -- Depends and Global
28281 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
28282 Global := Get_Pragma (Spec_Id, Pragma_Global);
28285 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28286 -- because it provides finer granularity of inputs and outputs.
28288 if Present (Global) then
28289 Global_Seen := True;
28290 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
28292 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28293 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28294 -- the inputs and outputs from [Refined_]Depends.
28296 elsif Synthesize and then Present (Depends) then
28297 Clauses := Expression (Get_Argument (Depends, Spec_Id));
28299 -- Multiple dependency clauses appear as an aggregate
28301 if Nkind (Clauses) = N_Aggregate then
28302 Clause := First (Component_Associations (Clauses));
28303 while Present (Clause) loop
28304 Collect_Dependency_Clause (Clause);
28308 -- Otherwise this is a single dependency clause
28311 Collect_Dependency_Clause (Clauses);
28315 -- The current instance of a protected type acts as a formal parameter
28316 -- of mode IN for functions and IN OUT for entries and procedures
28317 -- (SPARK RM 6.1.4).
28319 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
28320 Typ := Scope (Spec_Id);
28322 -- Use the anonymous object when the type is single protected
28324 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28325 Typ := Anonymous_Object (Typ);
28328 Append_New_Elmt (Typ, Subp_Inputs);
28330 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
28331 Append_New_Elmt (Typ, Subp_Outputs);
28334 -- The current instance of a task type acts as a formal parameter of
28335 -- mode IN OUT (SPARK RM 6.1.4).
28337 elsif Ekind (Spec_Id) = E_Task_Type then
28340 -- Use the anonymous object when the type is single task
28342 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28343 Typ := Anonymous_Object (Typ);
28346 Append_New_Elmt (Typ, Subp_Inputs);
28347 Append_New_Elmt (Typ, Subp_Outputs);
28349 elsif Is_Single_Task_Object (Spec_Id) then
28350 Append_New_Elmt (Spec_Id, Subp_Inputs);
28351 Append_New_Elmt (Spec_Id, Subp_Outputs);
28353 end Collect_Subprogram_Inputs_Outputs;
28355 ---------------------------
28356 -- Contract_Freeze_Error --
28357 ---------------------------
28359 procedure Contract_Freeze_Error
28360 (Contract_Id : Entity_Id;
28361 Freeze_Id : Entity_Id)
28364 Error_Msg_Name_1 := Chars (Contract_Id);
28365 Error_Msg_Sloc := Sloc (Freeze_Id);
28368 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
28370 ("\all contractual items must be declared before body #", Contract_Id);
28371 end Contract_Freeze_Error;
28373 ---------------------------------
28374 -- Delay_Config_Pragma_Analyze --
28375 ---------------------------------
28377 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
28379 return Nam_In (Pragma_Name_Unmapped (N),
28380 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
28381 end Delay_Config_Pragma_Analyze;
28383 -----------------------
28384 -- Duplication_Error --
28385 -----------------------
28387 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
28388 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
28389 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
28392 Error_Msg_Sloc := Sloc (Prev);
28393 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
28395 -- Emit a precise message to distinguish between source pragmas and
28396 -- pragmas generated from aspects. The ordering of the two pragmas is
28400 -- Prag -- duplicate
28402 -- No error is emitted when both pragmas come from aspects because this
28403 -- is already detected by the general aspect analysis mechanism.
28405 if Prag_From_Asp and Prev_From_Asp then
28407 elsif Prag_From_Asp then
28408 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
28409 elsif Prev_From_Asp then
28410 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
28412 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
28414 end Duplication_Error;
28416 ------------------------------
28417 -- Find_Encapsulating_State --
28418 ------------------------------
28420 function Find_Encapsulating_State
28421 (States : Elist_Id;
28422 Constit_Id : Entity_Id) return Entity_Id
28424 State_Id : Entity_Id;
28427 -- Since a constituent may be part of a larger constituent set, climb
28428 -- the encapsulating state chain looking for a state that appears in
28431 State_Id := Encapsulating_State (Constit_Id);
28432 while Present (State_Id) loop
28433 if Contains (States, State_Id) then
28437 State_Id := Encapsulating_State (State_Id);
28441 end Find_Encapsulating_State;
28443 --------------------------
28444 -- Find_Related_Context --
28445 --------------------------
28447 function Find_Related_Context
28449 Do_Checks : Boolean := False) return Node_Id
28454 Stmt := Prev (Prag);
28455 while Present (Stmt) loop
28457 -- Skip prior pragmas, but check for duplicates
28459 if Nkind (Stmt) = N_Pragma then
28461 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
28468 -- Skip internally generated code
28470 elsif not Comes_From_Source (Stmt) then
28472 -- The anonymous object created for a single concurrent type is a
28473 -- suitable context.
28475 if Nkind (Stmt) = N_Object_Declaration
28476 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28481 -- Return the current source construct
28491 end Find_Related_Context;
28493 --------------------------------------
28494 -- Find_Related_Declaration_Or_Body --
28495 --------------------------------------
28497 function Find_Related_Declaration_Or_Body
28499 Do_Checks : Boolean := False) return Node_Id
28501 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
28503 procedure Expression_Function_Error;
28504 -- Emit an error concerning pragma Prag that illegaly applies to an
28505 -- expression function.
28507 -------------------------------
28508 -- Expression_Function_Error --
28509 -------------------------------
28511 procedure Expression_Function_Error is
28513 Error_Msg_Name_1 := Prag_Nam;
28515 -- Emit a precise message to distinguish between source pragmas and
28516 -- pragmas generated from aspects.
28518 if From_Aspect_Specification (Prag) then
28520 ("aspect % cannot apply to a stand alone expression function",
28524 ("pragma % cannot apply to a stand alone expression function",
28527 end Expression_Function_Error;
28531 Context : constant Node_Id := Parent (Prag);
28534 Look_For_Body : constant Boolean :=
28535 Nam_In (Prag_Nam, Name_Refined_Depends,
28536 Name_Refined_Global,
28537 Name_Refined_Post);
28538 -- Refinement pragmas must be associated with a subprogram body [stub]
28540 -- Start of processing for Find_Related_Declaration_Or_Body
28543 Stmt := Prev (Prag);
28544 while Present (Stmt) loop
28546 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28547 -- by splitting a complex pre/postcondition are not considered to
28550 if Nkind (Stmt) = N_Pragma then
28552 and then not Split_PPC (Stmt)
28553 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
28560 -- Emit an error when a refinement pragma appears on an expression
28561 -- function without a completion.
28564 and then Look_For_Body
28565 and then Nkind (Stmt) = N_Subprogram_Declaration
28566 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
28567 and then not Has_Completion (Defining_Entity (Stmt))
28569 Expression_Function_Error;
28572 -- The refinement pragma applies to a subprogram body stub
28574 elsif Look_For_Body
28575 and then Nkind (Stmt) = N_Subprogram_Body_Stub
28579 -- Skip internally generated code
28581 elsif not Comes_From_Source (Stmt) then
28583 -- The anonymous object created for a single concurrent type is a
28584 -- suitable context.
28586 if Nkind (Stmt) = N_Object_Declaration
28587 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28591 elsif Nkind (Stmt) = N_Subprogram_Declaration then
28593 -- The subprogram declaration is an internally generated spec
28594 -- for an expression function.
28596 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28599 -- The subprogram is actually an instance housed within an
28600 -- anonymous wrapper package.
28602 elsif Present (Generic_Parent (Specification (Stmt))) then
28607 -- Return the current construct which is either a subprogram body,
28608 -- a subprogram declaration or is illegal.
28617 -- If we fall through, then the pragma was either the first declaration
28618 -- or it was preceded by other pragmas and no source constructs.
28620 -- The pragma is associated with a library-level subprogram
28622 if Nkind (Context) = N_Compilation_Unit_Aux then
28623 return Unit (Parent (Context));
28625 -- The pragma appears inside the declarations of an entry body
28627 elsif Nkind (Context) = N_Entry_Body then
28630 -- The pragma appears inside the statements of a subprogram body. This
28631 -- placement is the result of subprogram contract expansion.
28633 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
28634 return Parent (Context);
28636 -- The pragma appears inside the declarative part of a subprogram body
28638 elsif Nkind (Context) = N_Subprogram_Body then
28641 -- The pragma appears inside the declarative part of a task body
28643 elsif Nkind (Context) = N_Task_Body then
28646 -- The pragma is a byproduct of aspect expansion, return the related
28647 -- context of the original aspect. This case has a lower priority as
28648 -- the above circuitry pinpoints precisely the related context.
28650 elsif Present (Corresponding_Aspect (Prag)) then
28651 return Parent (Corresponding_Aspect (Prag));
28653 -- No candidate subprogram [body] found
28658 end Find_Related_Declaration_Or_Body;
28660 ----------------------------------
28661 -- Find_Related_Package_Or_Body --
28662 ----------------------------------
28664 function Find_Related_Package_Or_Body
28666 Do_Checks : Boolean := False) return Node_Id
28668 Context : constant Node_Id := Parent (Prag);
28669 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
28673 Stmt := Prev (Prag);
28674 while Present (Stmt) loop
28676 -- Skip prior pragmas, but check for duplicates
28678 if Nkind (Stmt) = N_Pragma then
28679 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
28685 -- Skip internally generated code
28687 elsif not Comes_From_Source (Stmt) then
28688 if Nkind (Stmt) = N_Subprogram_Declaration then
28690 -- The subprogram declaration is an internally generated spec
28691 -- for an expression function.
28693 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28696 -- The subprogram is actually an instance housed within an
28697 -- anonymous wrapper package.
28699 elsif Present (Generic_Parent (Specification (Stmt))) then
28704 -- Return the current source construct which is illegal
28713 -- If we fall through, then the pragma was either the first declaration
28714 -- or it was preceded by other pragmas and no source constructs.
28716 -- The pragma is associated with a package. The immediate context in
28717 -- this case is the specification of the package.
28719 if Nkind (Context) = N_Package_Specification then
28720 return Parent (Context);
28722 -- The pragma appears in the declarations of a package body
28724 elsif Nkind (Context) = N_Package_Body then
28727 -- The pragma appears in the statements of a package body
28729 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
28730 and then Nkind (Parent (Context)) = N_Package_Body
28732 return Parent (Context);
28734 -- The pragma is a byproduct of aspect expansion, return the related
28735 -- context of the original aspect. This case has a lower priority as
28736 -- the above circuitry pinpoints precisely the related context.
28738 elsif Present (Corresponding_Aspect (Prag)) then
28739 return Parent (Corresponding_Aspect (Prag));
28741 -- No candidate packge [body] found
28746 end Find_Related_Package_Or_Body;
28752 function Get_Argument
28754 Context_Id : Entity_Id := Empty) return Node_Id
28756 Args : constant List_Id := Pragma_Argument_Associations (Prag);
28759 -- Use the expression of the original aspect when compiling for ASIS or
28760 -- when analyzing the template of a generic unit. In both cases the
28761 -- aspect's tree must be decorated to allow for ASIS queries or to save
28762 -- the global references in the generic context.
28764 if From_Aspect_Specification (Prag)
28765 and then (ASIS_Mode or else (Present (Context_Id)
28766 and then Is_Generic_Unit (Context_Id)))
28768 return Corresponding_Aspect (Prag);
28770 -- Otherwise use the expression of the pragma
28772 elsif Present (Args) then
28773 return First (Args);
28780 -------------------------
28781 -- Get_Base_Subprogram --
28782 -------------------------
28784 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
28785 Result : Entity_Id;
28788 -- Follow subprogram renaming chain
28792 if Is_Subprogram (Result)
28794 Nkind (Parent (Declaration_Node (Result))) =
28795 N_Subprogram_Renaming_Declaration
28796 and then Present (Alias (Result))
28798 Result := Alias (Result);
28802 end Get_Base_Subprogram;
28804 -----------------------
28805 -- Get_SPARK_Mode_Type --
28806 -----------------------
28808 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
28810 if N = Name_On then
28812 elsif N = Name_Off then
28815 -- Any other argument is illegal
28818 raise Program_Error;
28820 end Get_SPARK_Mode_Type;
28822 ------------------------------------
28823 -- Get_SPARK_Mode_From_Annotation --
28824 ------------------------------------
28826 function Get_SPARK_Mode_From_Annotation
28827 (N : Node_Id) return SPARK_Mode_Type
28832 if Nkind (N) = N_Aspect_Specification then
28833 Mode := Expression (N);
28835 else pragma Assert (Nkind (N) = N_Pragma);
28836 Mode := First (Pragma_Argument_Associations (N));
28838 if Present (Mode) then
28839 Mode := Get_Pragma_Arg (Mode);
28843 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28845 if Present (Mode) then
28846 if Nkind (Mode) = N_Identifier then
28847 return Get_SPARK_Mode_Type (Chars (Mode));
28849 -- In case of a malformed aspect or pragma, return the default None
28855 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28860 end Get_SPARK_Mode_From_Annotation;
28862 ---------------------------
28863 -- Has_Extra_Parentheses --
28864 ---------------------------
28866 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28870 -- The aggregate should not have an expression list because a clause
28871 -- is always interpreted as a component association. The only way an
28872 -- expression list can sneak in is by adding extra parentheses around
28873 -- the individual clauses:
28875 -- Depends (Output => Input) -- proper form
28876 -- Depends ((Output => Input)) -- extra parentheses
28878 -- Since the extra parentheses are not allowed by the syntax of the
28879 -- pragma, flag them now to avoid emitting misleading errors down the
28882 if Nkind (Clause) = N_Aggregate
28883 and then Present (Expressions (Clause))
28885 Expr := First (Expressions (Clause));
28886 while Present (Expr) loop
28888 -- A dependency clause surrounded by extra parentheses appears
28889 -- as an aggregate of component associations with an optional
28890 -- Paren_Count set.
28892 if Nkind (Expr) = N_Aggregate
28893 and then Present (Component_Associations (Expr))
28896 ("dependency clause contains extra parentheses", Expr);
28898 -- Otherwise the expression is a malformed construct
28901 SPARK_Msg_N ("malformed dependency clause", Expr);
28911 end Has_Extra_Parentheses;
28917 procedure Initialize is
28928 Dummy := Dummy + 1;
28931 -----------------------------
28932 -- Is_Config_Static_String --
28933 -----------------------------
28935 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28937 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28938 -- This is an internal recursive function that is just like the outer
28939 -- function except that it adds the string to the name buffer rather
28940 -- than placing the string in the name buffer.
28942 ------------------------------
28943 -- Add_Config_Static_String --
28944 ------------------------------
28946 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28953 if Nkind (N) = N_Op_Concat then
28954 if Add_Config_Static_String (Left_Opnd (N)) then
28955 N := Right_Opnd (N);
28961 if Nkind (N) /= N_String_Literal then
28962 Error_Msg_N ("string literal expected for pragma argument", N);
28966 for J in 1 .. String_Length (Strval (N)) loop
28967 C := Get_String_Char (Strval (N), J);
28969 if not In_Character_Range (C) then
28971 ("string literal contains invalid wide character",
28972 Sloc (N) + 1 + Source_Ptr (J));
28976 Add_Char_To_Name_Buffer (Get_Character (C));
28981 end Add_Config_Static_String;
28983 -- Start of processing for Is_Config_Static_String
28988 return Add_Config_Static_String (Arg);
28989 end Is_Config_Static_String;
28991 ---------------------
28992 -- Is_CCT_Instance --
28993 ---------------------
28995 function Is_CCT_Instance
28996 (Ref_Id : Entity_Id;
28997 Context_Id : Entity_Id) return Boolean
29003 -- When the reference denotes a single protected type, the context is
29004 -- either a protected subprogram or its body.
29006 if Is_Single_Protected_Object (Ref_Id) then
29007 Typ := Scope (Context_Id);
29010 Ekind (Typ) = E_Protected_Type
29011 and then Present (Anonymous_Object (Typ))
29012 and then Anonymous_Object (Typ) = Ref_Id;
29014 -- When the reference denotes a single task type, the context is either
29015 -- the same type or if inside the body, the anonymous task type.
29017 elsif Is_Single_Task_Object (Ref_Id) then
29018 if Ekind (Context_Id) = E_Task_Type then
29020 Present (Anonymous_Object (Context_Id))
29021 and then Anonymous_Object (Context_Id) = Ref_Id;
29023 return Ref_Id = Context_Id;
29026 -- Otherwise the reference denotes a protected or a task type. Climb the
29027 -- scope chain looking for an enclosing concurrent type that matches the
29028 -- referenced entity.
29031 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
29033 S := Current_Scope;
29034 while Present (S) and then S /= Standard_Standard loop
29035 if Ekind_In (S, E_Protected_Type, E_Task_Type)
29036 and then S = Ref_Id
29046 end Is_CCT_Instance;
29048 -------------------------------
29049 -- Is_Elaboration_SPARK_Mode --
29050 -------------------------------
29052 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
29055 (Nkind (N) = N_Pragma
29056 and then Pragma_Name (N) = Name_SPARK_Mode
29057 and then Is_List_Member (N));
29059 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29060 -- appears in the statement part of the body.
29063 Present (Parent (N))
29064 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
29065 and then List_Containing (N) = Statements (Parent (N))
29066 and then Present (Parent (Parent (N)))
29067 and then Nkind (Parent (Parent (N))) = N_Package_Body;
29068 end Is_Elaboration_SPARK_Mode;
29070 -----------------------
29071 -- Is_Enabled_Pragma --
29072 -----------------------
29074 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
29078 if Present (Prag) then
29079 Arg := First (Pragma_Argument_Associations (Prag));
29081 if Present (Arg) then
29082 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
29084 -- The lack of a Boolean argument automatically enables the pragma
29090 -- The pragma is missing, therefore it is not enabled
29095 end Is_Enabled_Pragma;
29097 -----------------------------------------
29098 -- Is_Non_Significant_Pragma_Reference --
29099 -----------------------------------------
29101 -- This function makes use of the following static table which indicates
29102 -- whether appearance of some name in a given pragma is to be considered
29103 -- as a reference for the purposes of warnings about unreferenced objects.
29105 -- -1 indicates that appearence in any argument is significant
29106 -- 0 indicates that appearance in any argument is not significant
29107 -- +n indicates that appearance as argument n is significant, but all
29108 -- other arguments are not significant
29109 -- 9n arguments from n on are significant, before n insignificant
29111 Sig_Flags : constant array (Pragma_Id) of Int :=
29112 (Pragma_Abort_Defer => -1,
29113 Pragma_Abstract_State => -1,
29114 Pragma_Ada_83 => -1,
29115 Pragma_Ada_95 => -1,
29116 Pragma_Ada_05 => -1,
29117 Pragma_Ada_2005 => -1,
29118 Pragma_Ada_12 => -1,
29119 Pragma_Ada_2012 => -1,
29120 Pragma_All_Calls_Remote => -1,
29121 Pragma_Allow_Integer_Address => -1,
29122 Pragma_Annotate => 93,
29123 Pragma_Assert => -1,
29124 Pragma_Assert_And_Cut => -1,
29125 Pragma_Assertion_Policy => 0,
29126 Pragma_Assume => -1,
29127 Pragma_Assume_No_Invalid_Values => 0,
29128 Pragma_Async_Readers => 0,
29129 Pragma_Async_Writers => 0,
29130 Pragma_Asynchronous => 0,
29131 Pragma_Atomic => 0,
29132 Pragma_Atomic_Components => 0,
29133 Pragma_Attach_Handler => -1,
29134 Pragma_Attribute_Definition => 92,
29135 Pragma_Check => -1,
29136 Pragma_Check_Float_Overflow => 0,
29137 Pragma_Check_Name => 0,
29138 Pragma_Check_Policy => 0,
29139 Pragma_CPP_Class => 0,
29140 Pragma_CPP_Constructor => 0,
29141 Pragma_CPP_Virtual => 0,
29142 Pragma_CPP_Vtable => 0,
29144 Pragma_C_Pass_By_Copy => 0,
29145 Pragma_Comment => -1,
29146 Pragma_Common_Object => 0,
29147 Pragma_Compile_Time_Error => -1,
29148 Pragma_Compile_Time_Warning => -1,
29149 Pragma_Compiler_Unit => -1,
29150 Pragma_Compiler_Unit_Warning => -1,
29151 Pragma_Complete_Representation => 0,
29152 Pragma_Complex_Representation => 0,
29153 Pragma_Component_Alignment => 0,
29154 Pragma_Constant_After_Elaboration => 0,
29155 Pragma_Contract_Cases => -1,
29156 Pragma_Controlled => 0,
29157 Pragma_Convention => 0,
29158 Pragma_Convention_Identifier => 0,
29159 Pragma_Deadline_Floor => -1,
29160 Pragma_Debug => -1,
29161 Pragma_Debug_Policy => 0,
29162 Pragma_Detect_Blocking => 0,
29163 Pragma_Default_Initial_Condition => -1,
29164 Pragma_Default_Scalar_Storage_Order => 0,
29165 Pragma_Default_Storage_Pool => 0,
29166 Pragma_Depends => -1,
29167 Pragma_Disable_Atomic_Synchronization => 0,
29168 Pragma_Discard_Names => 0,
29169 Pragma_Dispatching_Domain => -1,
29170 Pragma_Effective_Reads => 0,
29171 Pragma_Effective_Writes => 0,
29172 Pragma_Elaborate => 0,
29173 Pragma_Elaborate_All => 0,
29174 Pragma_Elaborate_Body => 0,
29175 Pragma_Elaboration_Checks => 0,
29176 Pragma_Eliminate => 0,
29177 Pragma_Enable_Atomic_Synchronization => 0,
29178 Pragma_Export => -1,
29179 Pragma_Export_Function => -1,
29180 Pragma_Export_Object => -1,
29181 Pragma_Export_Procedure => -1,
29182 Pragma_Export_Value => -1,
29183 Pragma_Export_Valued_Procedure => -1,
29184 Pragma_Extend_System => -1,
29185 Pragma_Extensions_Allowed => 0,
29186 Pragma_Extensions_Visible => 0,
29187 Pragma_External => -1,
29188 Pragma_Favor_Top_Level => 0,
29189 Pragma_External_Name_Casing => 0,
29190 Pragma_Fast_Math => 0,
29191 Pragma_Finalize_Storage_Only => 0,
29193 Pragma_Global => -1,
29194 Pragma_Ident => -1,
29195 Pragma_Ignore_Pragma => 0,
29196 Pragma_Implementation_Defined => -1,
29197 Pragma_Implemented => -1,
29198 Pragma_Implicit_Packing => 0,
29199 Pragma_Import => 93,
29200 Pragma_Import_Function => 0,
29201 Pragma_Import_Object => 0,
29202 Pragma_Import_Procedure => 0,
29203 Pragma_Import_Valued_Procedure => 0,
29204 Pragma_Independent => 0,
29205 Pragma_Independent_Components => 0,
29206 Pragma_Initial_Condition => -1,
29207 Pragma_Initialize_Scalars => 0,
29208 Pragma_Initializes => -1,
29209 Pragma_Inline => 0,
29210 Pragma_Inline_Always => 0,
29211 Pragma_Inline_Generic => 0,
29212 Pragma_Inspection_Point => -1,
29213 Pragma_Interface => 92,
29214 Pragma_Interface_Name => 0,
29215 Pragma_Interrupt_Handler => -1,
29216 Pragma_Interrupt_Priority => -1,
29217 Pragma_Interrupt_State => -1,
29218 Pragma_Invariant => -1,
29219 Pragma_Keep_Names => 0,
29220 Pragma_License => 0,
29221 Pragma_Link_With => -1,
29222 Pragma_Linker_Alias => -1,
29223 Pragma_Linker_Constructor => -1,
29224 Pragma_Linker_Destructor => -1,
29225 Pragma_Linker_Options => -1,
29226 Pragma_Linker_Section => 0,
29228 Pragma_Lock_Free => 0,
29229 Pragma_Locking_Policy => 0,
29230 Pragma_Loop_Invariant => -1,
29231 Pragma_Loop_Optimize => 0,
29232 Pragma_Loop_Variant => -1,
29233 Pragma_Machine_Attribute => -1,
29235 Pragma_Main_Storage => -1,
29236 Pragma_Max_Queue_Length => 0,
29237 Pragma_Memory_Size => 0,
29238 Pragma_No_Return => 0,
29239 Pragma_No_Body => 0,
29240 Pragma_No_Elaboration_Code_All => 0,
29241 Pragma_No_Heap_Finalization => 0,
29242 Pragma_No_Inline => 0,
29243 Pragma_No_Run_Time => -1,
29244 Pragma_No_Strict_Aliasing => -1,
29245 Pragma_No_Tagged_Streams => 0,
29246 Pragma_Normalize_Scalars => 0,
29247 Pragma_Obsolescent => 0,
29248 Pragma_Optimize => 0,
29249 Pragma_Optimize_Alignment => 0,
29250 Pragma_Overflow_Mode => 0,
29251 Pragma_Overriding_Renamings => 0,
29252 Pragma_Ordered => 0,
29255 Pragma_Part_Of => 0,
29256 Pragma_Partition_Elaboration_Policy => 0,
29257 Pragma_Passive => 0,
29258 Pragma_Persistent_BSS => 0,
29259 Pragma_Polling => 0,
29260 Pragma_Prefix_Exception_Messages => 0,
29262 Pragma_Postcondition => -1,
29263 Pragma_Post_Class => -1,
29265 Pragma_Precondition => -1,
29266 Pragma_Predicate => -1,
29267 Pragma_Predicate_Failure => -1,
29268 Pragma_Preelaborable_Initialization => -1,
29269 Pragma_Preelaborate => 0,
29270 Pragma_Pre_Class => -1,
29271 Pragma_Priority => -1,
29272 Pragma_Priority_Specific_Dispatching => 0,
29273 Pragma_Profile => 0,
29274 Pragma_Profile_Warnings => 0,
29275 Pragma_Propagate_Exceptions => 0,
29276 Pragma_Provide_Shift_Operators => 0,
29277 Pragma_Psect_Object => 0,
29279 Pragma_Pure_Function => 0,
29280 Pragma_Queuing_Policy => 0,
29281 Pragma_Rational => 0,
29282 Pragma_Ravenscar => 0,
29283 Pragma_Refined_Depends => -1,
29284 Pragma_Refined_Global => -1,
29285 Pragma_Refined_Post => -1,
29286 Pragma_Refined_State => -1,
29287 Pragma_Relative_Deadline => 0,
29288 Pragma_Rename_Pragma => 0,
29289 Pragma_Remote_Access_Type => -1,
29290 Pragma_Remote_Call_Interface => -1,
29291 Pragma_Remote_Types => -1,
29292 Pragma_Restricted_Run_Time => 0,
29293 Pragma_Restriction_Warnings => 0,
29294 Pragma_Restrictions => 0,
29295 Pragma_Reviewable => -1,
29296 Pragma_Secondary_Stack_Size => -1,
29297 Pragma_Short_Circuit_And_Or => 0,
29298 Pragma_Share_Generic => 0,
29299 Pragma_Shared => 0,
29300 Pragma_Shared_Passive => 0,
29301 Pragma_Short_Descriptors => 0,
29302 Pragma_Simple_Storage_Pool_Type => 0,
29303 Pragma_Source_File_Name => 0,
29304 Pragma_Source_File_Name_Project => 0,
29305 Pragma_Source_Reference => 0,
29306 Pragma_SPARK_Mode => 0,
29307 Pragma_Storage_Size => -1,
29308 Pragma_Storage_Unit => 0,
29309 Pragma_Static_Elaboration_Desired => 0,
29310 Pragma_Stream_Convert => 0,
29311 Pragma_Style_Checks => 0,
29312 Pragma_Subtitle => 0,
29313 Pragma_Suppress => 0,
29314 Pragma_Suppress_Exception_Locations => 0,
29315 Pragma_Suppress_All => 0,
29316 Pragma_Suppress_Debug_Info => 0,
29317 Pragma_Suppress_Initialization => 0,
29318 Pragma_System_Name => 0,
29319 Pragma_Task_Dispatching_Policy => 0,
29320 Pragma_Task_Info => -1,
29321 Pragma_Task_Name => -1,
29322 Pragma_Task_Storage => -1,
29323 Pragma_Test_Case => -1,
29324 Pragma_Thread_Local_Storage => -1,
29325 Pragma_Time_Slice => -1,
29327 Pragma_Type_Invariant => -1,
29328 Pragma_Type_Invariant_Class => -1,
29329 Pragma_Unchecked_Union => 0,
29330 Pragma_Unevaluated_Use_Of_Old => 0,
29331 Pragma_Unimplemented_Unit => 0,
29332 Pragma_Universal_Aliasing => 0,
29333 Pragma_Universal_Data => 0,
29334 Pragma_Unmodified => 0,
29335 Pragma_Unreferenced => 0,
29336 Pragma_Unreferenced_Objects => 0,
29337 Pragma_Unreserve_All_Interrupts => 0,
29338 Pragma_Unsuppress => 0,
29339 Pragma_Unused => 0,
29340 Pragma_Use_VADS_Size => 0,
29341 Pragma_Validity_Checks => 0,
29342 Pragma_Volatile => 0,
29343 Pragma_Volatile_Components => 0,
29344 Pragma_Volatile_Full_Access => 0,
29345 Pragma_Volatile_Function => 0,
29346 Pragma_Warning_As_Error => 0,
29347 Pragma_Warnings => 0,
29348 Pragma_Weak_External => 0,
29349 Pragma_Wide_Character_Encoding => 0,
29350 Unknown_Pragma => 0);
29352 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
29358 function Arg_No return Nat;
29359 -- Returns an integer showing what argument we are in. A value of
29360 -- zero means we are not in any of the arguments.
29366 function Arg_No return Nat is
29371 A := First (Pragma_Argument_Associations (Parent (P)));
29385 -- Start of processing for Non_Significant_Pragma_Reference
29390 if Nkind (P) /= N_Pragma_Argument_Association then
29394 Id := Get_Pragma_Id (Parent (P));
29395 C := Sig_Flags (Id);
29410 return AN < (C - 90);
29416 end Is_Non_Significant_Pragma_Reference;
29418 ------------------------------
29419 -- Is_Pragma_String_Literal --
29420 ------------------------------
29422 -- This function returns true if the corresponding pragma argument is a
29423 -- static string expression. These are the only cases in which string
29424 -- literals can appear as pragma arguments. We also allow a string literal
29425 -- as the first argument to pragma Assert (although it will of course
29426 -- always generate a type error).
29428 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
29429 Pragn : constant Node_Id := Parent (Par);
29430 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
29431 Pname : constant Name_Id := Pragma_Name (Pragn);
29437 N := First (Assoc);
29444 if Pname = Name_Assert then
29447 elsif Pname = Name_Export then
29450 elsif Pname = Name_Ident then
29453 elsif Pname = Name_Import then
29456 elsif Pname = Name_Interface_Name then
29459 elsif Pname = Name_Linker_Alias then
29462 elsif Pname = Name_Linker_Section then
29465 elsif Pname = Name_Machine_Attribute then
29468 elsif Pname = Name_Source_File_Name then
29471 elsif Pname = Name_Source_Reference then
29474 elsif Pname = Name_Title then
29477 elsif Pname = Name_Subtitle then
29483 end Is_Pragma_String_Literal;
29485 ---------------------------
29486 -- Is_Private_SPARK_Mode --
29487 ---------------------------
29489 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
29492 (Nkind (N) = N_Pragma
29493 and then Pragma_Name (N) = Name_SPARK_Mode
29494 and then Is_List_Member (N));
29496 -- For pragma SPARK_Mode to be private, it has to appear in the private
29497 -- declarations of a package.
29500 Present (Parent (N))
29501 and then Nkind (Parent (N)) = N_Package_Specification
29502 and then List_Containing (N) = Private_Declarations (Parent (N));
29503 end Is_Private_SPARK_Mode;
29505 -------------------------------------
29506 -- Is_Unconstrained_Or_Tagged_Item --
29507 -------------------------------------
29509 function Is_Unconstrained_Or_Tagged_Item
29510 (Item : Entity_Id) return Boolean
29512 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
29513 -- Determine whether record type Typ has at least one unconstrained
29516 ---------------------------------
29517 -- Has_Unconstrained_Component --
29518 ---------------------------------
29520 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
29524 Comp := First_Component (Typ);
29525 while Present (Comp) loop
29526 if Is_Unconstrained_Or_Tagged_Item (Comp) then
29530 Next_Component (Comp);
29534 end Has_Unconstrained_Component;
29538 Typ : constant Entity_Id := Etype (Item);
29540 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29543 if Is_Tagged_Type (Typ) then
29546 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
29549 elsif Is_Record_Type (Typ) then
29550 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
29553 return Has_Unconstrained_Component (Typ);
29556 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
29562 end Is_Unconstrained_Or_Tagged_Item;
29564 -----------------------------
29565 -- Is_Valid_Assertion_Kind --
29566 -----------------------------
29568 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
29575 | Name_Assertion_Policy
29576 | Name_Static_Predicate
29577 | Name_Dynamic_Predicate
29582 | Name_Type_Invariant
29583 | Name_uType_Invariant
29587 | Name_Assert_And_Cut
29589 | Name_Contract_Cases
29591 | Name_Default_Initial_Condition
29593 | Name_Initial_Condition
29596 | Name_Loop_Invariant
29597 | Name_Loop_Variant
29598 | Name_Postcondition
29599 | Name_Precondition
29601 | Name_Refined_Post
29602 | Name_Statement_Assertions
29609 end Is_Valid_Assertion_Kind;
29611 --------------------------------------
29612 -- Process_Compilation_Unit_Pragmas --
29613 --------------------------------------
29615 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
29617 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29618 -- strange because it comes at the end of the unit. Rational has the
29619 -- same name for a pragma, but treats it as a program unit pragma, In
29620 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29621 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29622 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29623 -- the context clause to ensure the correct processing.
29625 if Has_Pragma_Suppress_All (N) then
29626 Prepend_To (Context_Items (N),
29627 Make_Pragma (Sloc (N),
29628 Chars => Name_Suppress,
29629 Pragma_Argument_Associations => New_List (
29630 Make_Pragma_Argument_Association (Sloc (N),
29631 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
29634 -- Nothing else to do at the current time
29636 end Process_Compilation_Unit_Pragmas;
29638 -------------------------------------------
29639 -- Process_Compile_Time_Warning_Or_Error --
29640 -------------------------------------------
29642 procedure Process_Compile_Time_Warning_Or_Error
29646 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
29647 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
29648 Arg2 : constant Node_Id := Next (Arg1);
29651 Analyze_And_Resolve (Arg1x, Standard_Boolean);
29653 if Compile_Time_Known_Value (Arg1x) then
29654 if Is_True (Expr_Value (Arg1x)) then
29656 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
29657 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
29658 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
29659 Str : constant String_Id := Strval (Get_Pragma_Arg (Arg2));
29660 Str_Len : constant Nat := String_Length (Str);
29662 Force : constant Boolean :=
29663 Prag_Id = Pragma_Compile_Time_Warning
29664 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
29665 and then (Ekind (Cent) /= E_Package
29666 or else not In_Private_Part (Cent));
29667 -- Set True if this is the warning case, and we are in the
29668 -- visible part of a package spec, or in a subprogram spec,
29669 -- in which case we want to force the client to see the
29670 -- warning, even though it is not in the main unit.
29678 -- Loop through segments of message separated by line feeds.
29679 -- We output these segments as separate messages with
29680 -- continuation marks for all but the first.
29685 Error_Msg_Strlen := 0;
29687 -- Loop to copy characters from argument to error message
29691 exit when Ptr > Str_Len;
29692 CC := Get_String_Char (Str, Ptr);
29695 -- Ignore wide chars ??? else store character
29697 if In_Character_Range (CC) then
29698 C := Get_Character (CC);
29699 exit when C = ASCII.LF;
29700 Error_Msg_Strlen := Error_Msg_Strlen + 1;
29701 Error_Msg_String (Error_Msg_Strlen) := C;
29705 -- Here with one line ready to go
29707 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
29709 -- If this is a warning in a spec, then we want clients
29710 -- to see the warning, so mark the message with the
29711 -- special sequence !! to force the warning. In the case
29712 -- of a package spec, we do not force this if we are in
29713 -- the private part of the spec.
29716 if Cont = False then
29717 Error_Msg ("<<~!!", Eloc);
29720 Error_Msg ("\<<~!!", Eloc);
29723 -- Error, rather than warning, or in a body, so we do not
29724 -- need to force visibility for client (error will be
29725 -- output in any case, and this is the situation in which
29726 -- we do not want a client to get a warning, since the
29727 -- warning is in the body or the spec private part).
29730 if Cont = False then
29731 Error_Msg ("<<~", Eloc);
29734 Error_Msg ("\<<~", Eloc);
29738 exit when Ptr > Str_Len;
29743 end Process_Compile_Time_Warning_Or_Error;
29745 ------------------------------------
29746 -- Record_Possible_Body_Reference --
29747 ------------------------------------
29749 procedure Record_Possible_Body_Reference
29750 (State_Id : Entity_Id;
29754 Spec_Id : Entity_Id;
29757 -- Ensure that we are dealing with a reference to a state
29759 pragma Assert (Ekind (State_Id) = E_Abstract_State);
29761 -- Climb the tree starting from the reference looking for a package body
29762 -- whose spec declares the referenced state. This criteria automatically
29763 -- excludes references in package specs which are legal. Note that it is
29764 -- not wise to emit an error now as the package body may lack pragma
29765 -- Refined_State or the referenced state may not be mentioned in the
29766 -- refinement. This approach avoids the generation of misleading errors.
29769 while Present (Context) loop
29770 if Nkind (Context) = N_Package_Body then
29771 Spec_Id := Corresponding_Spec (Context);
29773 if Present (Abstract_States (Spec_Id))
29774 and then Contains (Abstract_States (Spec_Id), State_Id)
29776 if No (Body_References (State_Id)) then
29777 Set_Body_References (State_Id, New_Elmt_List);
29780 Append_Elmt (Ref, To => Body_References (State_Id));
29785 Context := Parent (Context);
29787 end Record_Possible_Body_Reference;
29789 ------------------------------------------
29790 -- Relocate_Pragmas_To_Anonymous_Object --
29791 ------------------------------------------
29793 procedure Relocate_Pragmas_To_Anonymous_Object
29794 (Typ_Decl : Node_Id;
29795 Obj_Decl : Node_Id)
29799 Next_Decl : Node_Id;
29802 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
29803 Def := Protected_Definition (Typ_Decl);
29805 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
29806 Def := Task_Definition (Typ_Decl);
29809 -- The concurrent definition has a visible declaration list. Inspect it
29810 -- and relocate all canidate pragmas.
29812 if Present (Def) and then Present (Visible_Declarations (Def)) then
29813 Decl := First (Visible_Declarations (Def));
29814 while Present (Decl) loop
29816 -- Preserve the following declaration for iteration purposes due
29817 -- to possible relocation of a pragma.
29819 Next_Decl := Next (Decl);
29821 if Nkind (Decl) = N_Pragma
29822 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
29825 Insert_After (Obj_Decl, Decl);
29827 -- Skip internally generated code
29829 elsif not Comes_From_Source (Decl) then
29832 -- No candidate pragmas are available for relocation
29841 end Relocate_Pragmas_To_Anonymous_Object;
29843 ------------------------------
29844 -- Relocate_Pragmas_To_Body --
29845 ------------------------------
29847 procedure Relocate_Pragmas_To_Body
29848 (Subp_Body : Node_Id;
29849 Target_Body : Node_Id := Empty)
29851 procedure Relocate_Pragma (Prag : Node_Id);
29852 -- Remove a single pragma from its current list and add it to the
29853 -- declarations of the proper body (either Subp_Body or Target_Body).
29855 ---------------------
29856 -- Relocate_Pragma --
29857 ---------------------
29859 procedure Relocate_Pragma (Prag : Node_Id) is
29864 -- When subprogram stubs or expression functions are involves, the
29865 -- destination declaration list belongs to the proper body.
29867 if Present (Target_Body) then
29868 Target := Target_Body;
29870 Target := Subp_Body;
29873 Decls := Declarations (Target);
29877 Set_Declarations (Target, Decls);
29880 -- Unhook the pragma from its current list
29883 Prepend (Prag, Decls);
29884 end Relocate_Pragma;
29888 Body_Id : constant Entity_Id :=
29889 Defining_Unit_Name (Specification (Subp_Body));
29890 Next_Stmt : Node_Id;
29893 -- Start of processing for Relocate_Pragmas_To_Body
29896 -- Do not process a body that comes from a separate unit as no construct
29897 -- can possibly follow it.
29899 if not Is_List_Member (Subp_Body) then
29902 -- Do not relocate pragmas that follow a stub if the stub does not have
29905 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
29906 and then No (Target_Body)
29910 -- Do not process internally generated routine _Postconditions
29912 elsif Ekind (Body_Id) = E_Procedure
29913 and then Chars (Body_Id) = Name_uPostconditions
29918 -- Look at what is following the body. We are interested in certain kind
29919 -- of pragmas (either from source or byproducts of expansion) that can
29920 -- apply to a body [stub].
29922 Stmt := Next (Subp_Body);
29923 while Present (Stmt) loop
29925 -- Preserve the following statement for iteration purposes due to a
29926 -- possible relocation of a pragma.
29928 Next_Stmt := Next (Stmt);
29930 -- Move a candidate pragma following the body to the declarations of
29933 if Nkind (Stmt) = N_Pragma
29934 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
29936 Relocate_Pragma (Stmt);
29938 -- Skip internally generated code
29940 elsif not Comes_From_Source (Stmt) then
29943 -- No candidate pragmas are available for relocation
29951 end Relocate_Pragmas_To_Body;
29953 -------------------
29954 -- Resolve_State --
29955 -------------------
29957 procedure Resolve_State (N : Node_Id) is
29962 if Is_Entity_Name (N) and then Present (Entity (N)) then
29963 Func := Entity (N);
29965 -- Handle overloading of state names by functions. Traverse the
29966 -- homonym chain looking for an abstract state.
29968 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
29969 State := Homonym (Func);
29970 while Present (State) loop
29972 -- Resolve the overloading by setting the proper entity of the
29973 -- reference to that of the state.
29975 if Ekind (State) = E_Abstract_State then
29976 Set_Etype (N, Standard_Void_Type);
29977 Set_Entity (N, State);
29978 Set_Associated_Node (N, State);
29982 State := Homonym (State);
29985 -- A function can never act as a state. If the homonym chain does
29986 -- not contain a corresponding state, then something went wrong in
29987 -- the overloading mechanism.
29989 raise Program_Error;
29994 ----------------------------
29995 -- Rewrite_Assertion_Kind --
29996 ----------------------------
29998 procedure Rewrite_Assertion_Kind
30000 From_Policy : Boolean := False)
30006 if Nkind (N) = N_Attribute_Reference
30007 and then Attribute_Name (N) = Name_Class
30008 and then Nkind (Prefix (N)) = N_Identifier
30010 case Chars (Prefix (N)) is
30017 when Name_Type_Invariant =>
30018 Nam := Name_uType_Invariant;
30020 when Name_Invariant =>
30021 Nam := Name_uInvariant;
30027 -- Recommend standard use of aspect names Pre/Post
30029 elsif Nkind (N) = N_Identifier
30030 and then From_Policy
30031 and then Serious_Errors_Detected = 0
30032 and then not ASIS_Mode
30034 if Chars (N) = Name_Precondition
30035 or else Chars (N) = Name_Postcondition
30037 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
30039 ("\use Assertion_Policy and aspect names Pre/Post for "
30040 & "Ada2012 conformance?", N);
30046 if Nam /= No_Name then
30047 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
30049 end Rewrite_Assertion_Kind;
30057 Dummy := Dummy + 1;
30060 --------------------------------
30061 -- Set_Encoded_Interface_Name --
30062 --------------------------------
30064 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
30065 Str : constant String_Id := Strval (S);
30066 Len : constant Nat := String_Length (Str);
30071 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
30074 -- Stores encoded value of character code CC. The encoding we use an
30075 -- underscore followed by four lower case hex digits.
30081 procedure Encode is
30083 Store_String_Char (Get_Char_Code ('_'));
30085 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
30087 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
30089 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
30091 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
30094 -- Start of processing for Set_Encoded_Interface_Name
30097 -- If first character is asterisk, this is a link name, and we leave it
30098 -- completely unmodified. We also ignore null strings (the latter case
30099 -- happens only in error cases).
30102 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
30104 Set_Interface_Name (E, S);
30109 CC := Get_String_Char (Str, J);
30111 exit when not In_Character_Range (CC);
30113 C := Get_Character (CC);
30115 exit when C /= '_' and then C /= '$'
30116 and then C not in '0' .. '9'
30117 and then C not in 'a' .. 'z'
30118 and then C not in 'A' .. 'Z';
30121 Set_Interface_Name (E, S);
30129 -- Here we need to encode. The encoding we use as follows:
30130 -- three underscores + four hex digits (lower case)
30134 for J in 1 .. String_Length (Str) loop
30135 CC := Get_String_Char (Str, J);
30137 if not In_Character_Range (CC) then
30140 C := Get_Character (CC);
30142 if C = '_' or else C = '$'
30143 or else C in '0' .. '9'
30144 or else C in 'a' .. 'z'
30145 or else C in 'A' .. 'Z'
30147 Store_String_Char (CC);
30154 Set_Interface_Name (E,
30155 Make_String_Literal (Sloc (S),
30156 Strval => End_String));
30158 end Set_Encoded_Interface_Name;
30160 ------------------------
30161 -- Set_Elab_Unit_Name --
30162 ------------------------
30164 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
30169 if Nkind (N) = N_Identifier
30170 and then Nkind (With_Item) = N_Identifier
30172 Set_Entity (N, Entity (With_Item));
30174 elsif Nkind (N) = N_Selected_Component then
30175 Change_Selected_Component_To_Expanded_Name (N);
30176 Set_Entity (N, Entity (With_Item));
30177 Set_Entity (Selector_Name (N), Entity (N));
30179 Pref := Prefix (N);
30180 Scop := Scope (Entity (N));
30181 while Nkind (Pref) = N_Selected_Component loop
30182 Change_Selected_Component_To_Expanded_Name (Pref);
30183 Set_Entity (Selector_Name (Pref), Scop);
30184 Set_Entity (Pref, Scop);
30185 Pref := Prefix (Pref);
30186 Scop := Scope (Scop);
30189 Set_Entity (Pref, Scop);
30192 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
30193 end Set_Elab_Unit_Name;
30195 -------------------
30196 -- Test_Case_Arg --
30197 -------------------
30199 function Test_Case_Arg
30202 From_Aspect : Boolean := False) return Node_Id
30204 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
30209 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
30214 -- The caller requests the aspect argument
30216 if From_Aspect then
30217 if Present (Aspect)
30218 and then Nkind (Expression (Aspect)) = N_Aggregate
30220 Args := Expression (Aspect);
30222 -- "Name" and "Mode" may appear without an identifier as a
30223 -- positional association.
30225 if Present (Expressions (Args)) then
30226 Arg := First (Expressions (Args));
30228 if Present (Arg) and then Arg_Nam = Name_Name then
30236 if Present (Arg) and then Arg_Nam = Name_Mode then
30241 -- Some or all arguments may appear as component associatons
30243 if Present (Component_Associations (Args)) then
30244 Arg := First (Component_Associations (Args));
30245 while Present (Arg) loop
30246 if Chars (First (Choices (Arg))) = Arg_Nam then
30255 -- Otherwise retrieve the argument directly from the pragma
30258 Arg := First (Pragma_Argument_Associations (Prag));
30260 if Present (Arg) and then Arg_Nam = Name_Name then
30264 -- Skip argument "Name"
30268 if Present (Arg) and then Arg_Nam = Name_Mode then
30272 -- Skip argument "Mode"
30276 -- Arguments "Requires" and "Ensures" are optional and may not be
30279 while Present (Arg) loop
30280 if Chars (Arg) = Arg_Nam then