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,
936 -- Current instances of concurrent types
938 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
943 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
944 E_Generic_In_Parameter,
952 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
954 -- The item denotes a concurrent type. Note that single
955 -- protected/task types are not considered here because
956 -- they behave as objects in the context of pragma
957 -- [Refined_]Depends.
959 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
961 -- This use is legal as long as the concurrent type is
962 -- the current instance of an enclosing type.
964 if Is_CCT_Instance (Item_Id, Spec_Id) then
966 -- The dependence of a task unit on itself is
967 -- implicit and may or may not be explicitly
968 -- specified (SPARK RM 6.1.4).
970 if Ekind (Item_Id) = E_Task_Type then
971 Current_Task_Instance_Seen;
974 -- Otherwise this is not the current instance
978 ("invalid use of subtype mark in dependency "
982 -- The dependency of a task unit on itself is implicit
983 -- and may or may not be explicitly specified
986 elsif Is_Single_Task_Object (Item_Id)
987 and then Is_CCT_Instance (Item_Id, Spec_Id)
989 Current_Task_Instance_Seen;
992 -- Ensure that the item fulfills its role as input and/or
993 -- output as specified by pragma Global or the enclosing
996 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
998 -- Detect multiple uses of the same state, variable or
999 -- formal parameter. If this is not the case, add the
1000 -- item to the list of processed relations.
1002 if Contains (Seen, Item_Id) then
1004 ("duplicate use of item &", Item, Item_Id);
1006 Append_New_Elmt (Item_Id, Seen);
1009 -- Detect illegal use of an input related to a null
1010 -- output. Such input items cannot appear in other
1011 -- input lists (SPARK RM 6.1.5(13)).
1014 and then Null_Output_Seen
1015 and then Contains (All_Inputs_Seen, Item_Id)
1018 ("input of a null output list cannot appear in "
1019 & "multiple input lists", Item);
1022 -- Add an input or a self-referential output to the list
1023 -- of all processed inputs.
1025 if Is_Input or else Self_Ref then
1026 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1029 -- State related checks (SPARK RM 6.1.5(3))
1031 if Ekind (Item_Id) = E_Abstract_State then
1033 -- Package and subprogram bodies are instantiated
1034 -- individually in a separate compiler pass. Due to
1035 -- this mode of instantiation, the refinement of a
1036 -- state may no longer be visible when a subprogram
1037 -- body contract is instantiated. Since the generic
1038 -- template is legal, do not perform this check in
1039 -- the instance to circumvent this oddity.
1041 if Is_Generic_Instance (Spec_Id) then
1044 -- An abstract state with visible refinement cannot
1045 -- appear in pragma [Refined_]Depends as its place
1046 -- must be taken by some of its constituents
1047 -- (SPARK RM 6.1.4(7)).
1049 elsif Has_Visible_Refinement (Item_Id) then
1051 ("cannot mention state & in dependence relation",
1053 SPARK_Msg_N ("\use its constituents instead", Item);
1056 -- If the reference to the abstract state appears in
1057 -- an enclosing package body that will eventually
1058 -- refine the state, record the reference for future
1062 Record_Possible_Body_Reference
1063 (State_Id => Item_Id,
1068 -- When the item renames an entire object, replace the
1069 -- item with a reference to the object.
1071 if Entity (Item) /= Item_Id then
1073 New_Occurrence_Of (Item_Id, Sloc (Item)));
1077 -- Add the entity of the current item to the list of
1080 if Ekind (Item_Id) = E_Abstract_State then
1081 Append_New_Elmt (Item_Id, States_Seen);
1083 -- The variable may eventually become a constituent of a
1084 -- single protected/task type. Record the reference now
1085 -- and verify its legality when analyzing the contract of
1086 -- the variable (SPARK RM 9.3).
1088 elsif Ekind (Item_Id) = E_Variable then
1089 Record_Possible_Part_Of_Reference
1094 if Ekind_In (Item_Id, E_Abstract_State,
1097 and then Present (Encapsulating_State (Item_Id))
1099 Append_New_Elmt (Item_Id, Constits_Seen);
1102 -- All other input/output items are illegal
1103 -- (SPARK RM 6.1.5(1)).
1107 ("item must denote parameter, variable, state or "
1108 & "current instance of concurren type", Item);
1111 -- All other input/output items are illegal
1112 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1116 ("item must denote parameter, variable, state or current "
1117 & "instance of concurrent type", Item);
1120 end Analyze_Input_Output;
1128 Non_Null_Output_Seen : Boolean := False;
1129 -- Flag used to check the legality of an output list
1131 -- Start of processing for Analyze_Dependency_Clause
1134 Inputs := Expression (Clause);
1137 -- An input list with a self-dependency appears as operator "+" where
1138 -- the actuals inputs are the right operand.
1140 if Nkind (Inputs) = N_Op_Plus then
1141 Inputs := Right_Opnd (Inputs);
1145 -- Process the output_list of a dependency_clause
1147 Output := First (Choices (Clause));
1148 while Present (Output) loop
1149 Analyze_Input_Output
1152 Self_Ref => Self_Ref,
1154 Seen => All_Outputs_Seen,
1155 Null_Seen => Null_Output_Seen,
1156 Non_Null_Seen => Non_Null_Output_Seen);
1161 -- Process the input_list of a dependency_clause
1163 Analyze_Input_List (Inputs);
1164 end Analyze_Dependency_Clause;
1166 ---------------------------
1167 -- Check_Function_Return --
1168 ---------------------------
1170 procedure Check_Function_Return is
1172 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1173 and then not Result_Seen
1176 ("result of & must appear in exactly one output list",
1179 end Check_Function_Return;
1185 procedure Check_Role
1187 Item_Id : Entity_Id;
1192 (Item_Is_Input : out Boolean;
1193 Item_Is_Output : out Boolean);
1194 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1195 -- Item_Is_Output are set depending on the role.
1197 procedure Role_Error
1198 (Item_Is_Input : Boolean;
1199 Item_Is_Output : Boolean);
1200 -- Emit an error message concerning the incorrect use of Item in
1201 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1202 -- denote whether the item is an input and/or an output.
1209 (Item_Is_Input : out Boolean;
1210 Item_Is_Output : out Boolean)
1213 Item_Is_Input := False;
1214 Item_Is_Output := False;
1218 if Ekind (Item_Id) = E_Abstract_State then
1220 -- When pragma Global is present, the mode of the state may be
1221 -- further constrained by setting a more restrictive mode.
1224 if Appears_In (Subp_Inputs, Item_Id) then
1225 Item_Is_Input := True;
1228 if Appears_In (Subp_Outputs, Item_Id) then
1229 Item_Is_Output := True;
1232 -- Otherwise the state has a default IN OUT mode
1235 Item_Is_Input := True;
1236 Item_Is_Output := True;
1241 elsif Ekind_In (Item_Id, E_Constant,
1245 Item_Is_Input := True;
1249 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1252 Item_Is_Input := True;
1254 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1257 Item_Is_Input := True;
1258 Item_Is_Output := True;
1260 elsif Ekind (Item_Id) = E_Out_Parameter then
1261 if Scope (Item_Id) = Spec_Id then
1263 -- An OUT parameter of the related subprogram has mode IN
1264 -- if its type is unconstrained or tagged because array
1265 -- bounds, discriminants or tags can be read.
1267 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1268 Item_Is_Input := True;
1271 Item_Is_Output := True;
1273 -- An OUT parameter of an enclosing subprogram behaves as a
1274 -- read-write variable in which case the mode is IN OUT.
1277 Item_Is_Input := True;
1278 Item_Is_Output := True;
1283 elsif Ekind (Item_Id) = E_Protected_Type then
1285 -- A protected type acts as a formal parameter of mode IN when
1286 -- it applies to a protected function.
1288 if Ekind (Spec_Id) = E_Function then
1289 Item_Is_Input := True;
1291 -- Otherwise the protected type acts as a formal of mode IN OUT
1294 Item_Is_Input := True;
1295 Item_Is_Output := True;
1300 elsif Ekind (Item_Id) = E_Task_Type then
1301 Item_Is_Input := True;
1302 Item_Is_Output := True;
1306 else pragma Assert (Ekind (Item_Id) = E_Variable);
1308 -- When pragma Global is present, the mode of the variable may
1309 -- be further constrained by setting a more restrictive mode.
1313 -- A variable has mode IN when its type is unconstrained or
1314 -- tagged because array bounds, discriminants or tags can be
1317 if Appears_In (Subp_Inputs, Item_Id)
1318 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1320 Item_Is_Input := True;
1323 if Appears_In (Subp_Outputs, Item_Id) then
1324 Item_Is_Output := True;
1327 -- Otherwise the variable has a default IN OUT mode
1330 Item_Is_Input := True;
1331 Item_Is_Output := True;
1340 procedure Role_Error
1341 (Item_Is_Input : Boolean;
1342 Item_Is_Output : Boolean)
1344 Error_Msg : Name_Id;
1349 -- When the item is not part of the input and the output set of
1350 -- the related subprogram, then it appears as extra in pragma
1351 -- [Refined_]Depends.
1353 if not Item_Is_Input and then not Item_Is_Output then
1354 Add_Item_To_Name_Buffer (Item_Id);
1355 Add_Str_To_Name_Buffer
1356 (" & cannot appear in dependence relation");
1358 Error_Msg := Name_Find;
1359 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1361 Error_Msg_Name_1 := Chars (Spec_Id);
1363 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1364 & "set of subprogram %"), Item, Item_Id);
1366 -- The mode of the item and its role in pragma [Refined_]Depends
1367 -- are in conflict. Construct a detailed message explaining the
1368 -- illegality (SPARK RM 6.1.5(5-6)).
1371 if Item_Is_Input then
1372 Add_Str_To_Name_Buffer ("read-only");
1374 Add_Str_To_Name_Buffer ("write-only");
1377 Add_Char_To_Name_Buffer (' ');
1378 Add_Item_To_Name_Buffer (Item_Id);
1379 Add_Str_To_Name_Buffer (" & cannot appear as ");
1381 if Item_Is_Input then
1382 Add_Str_To_Name_Buffer ("output");
1384 Add_Str_To_Name_Buffer ("input");
1387 Add_Str_To_Name_Buffer (" in dependence relation");
1388 Error_Msg := Name_Find;
1389 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1395 Item_Is_Input : Boolean;
1396 Item_Is_Output : Boolean;
1398 -- Start of processing for Check_Role
1401 Find_Role (Item_Is_Input, Item_Is_Output);
1406 if not Item_Is_Input then
1407 Role_Error (Item_Is_Input, Item_Is_Output);
1410 -- Self-referential item
1413 if not Item_Is_Input or else not Item_Is_Output then
1414 Role_Error (Item_Is_Input, Item_Is_Output);
1419 elsif not Item_Is_Output then
1420 Role_Error (Item_Is_Input, Item_Is_Output);
1428 procedure Check_Usage
1429 (Subp_Items : Elist_Id;
1430 Used_Items : Elist_Id;
1433 procedure Usage_Error (Item_Id : Entity_Id);
1434 -- Emit an error concerning the illegal usage of an item
1440 procedure Usage_Error (Item_Id : Entity_Id) is
1441 Error_Msg : Name_Id;
1448 -- Unconstrained and tagged items are not part of the explicit
1449 -- input set of the related subprogram, they do not have to be
1450 -- present in a dependence relation and should not be flagged
1451 -- (SPARK RM 6.1.5(8)).
1453 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1456 Add_Item_To_Name_Buffer (Item_Id);
1457 Add_Str_To_Name_Buffer
1458 (" & is missing from input dependence list");
1460 Error_Msg := Name_Find;
1461 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1464 -- Output case (SPARK RM 6.1.5(10))
1469 Add_Item_To_Name_Buffer (Item_Id);
1470 Add_Str_To_Name_Buffer
1471 (" & is missing from output dependence list");
1473 Error_Msg := Name_Find;
1474 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1482 Item_Id : Entity_Id;
1484 -- Start of processing for Check_Usage
1487 if No (Subp_Items) then
1491 -- Each input or output of the subprogram must appear in a dependency
1494 Elmt := First_Elmt (Subp_Items);
1495 while Present (Elmt) loop
1496 Item := Node (Elmt);
1498 if Nkind (Item) = N_Defining_Identifier then
1501 Item_Id := Entity_Of (Item);
1504 -- The item does not appear in a dependency
1506 if Present (Item_Id)
1507 and then not Contains (Used_Items, Item_Id)
1509 if Is_Formal (Item_Id) then
1510 Usage_Error (Item_Id);
1512 -- The current instance of a protected type behaves as a formal
1513 -- parameter (SPARK RM 6.1.4).
1515 elsif Ekind (Item_Id) = E_Protected_Type
1516 or else Is_Single_Protected_Object (Item_Id)
1518 Usage_Error (Item_Id);
1520 -- The current instance of a task type behaves as a formal
1521 -- parameter (SPARK RM 6.1.4).
1523 elsif Ekind (Item_Id) = E_Task_Type
1524 or else Is_Single_Task_Object (Item_Id)
1526 -- The dependence of a task unit on itself is implicit and
1527 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1528 -- Emit an error if only one input/output is present.
1530 if Task_Input_Seen /= Task_Output_Seen then
1531 Usage_Error (Item_Id);
1534 -- States and global objects are not used properly only when
1535 -- the subprogram is subject to pragma Global.
1537 elsif Global_Seen then
1538 Usage_Error (Item_Id);
1546 ----------------------
1547 -- Normalize_Clause --
1548 ----------------------
1550 procedure Normalize_Clause (Clause : Node_Id) is
1551 procedure Create_Or_Modify_Clause
1557 Multiple : Boolean);
1558 -- Create a brand new clause to represent the self-reference or
1559 -- modify the input and/or output lists of an existing clause. Output
1560 -- denotes a self-referencial output. Outputs is the output list of a
1561 -- clause. Inputs is the input list of a clause. After denotes the
1562 -- clause after which the new clause is to be inserted. Flag In_Place
1563 -- should be set when normalizing the last output of an output list.
1564 -- Flag Multiple should be set when Output comes from a list with
1567 -----------------------------
1568 -- Create_Or_Modify_Clause --
1569 -----------------------------
1571 procedure Create_Or_Modify_Clause
1579 procedure Propagate_Output
1582 -- Handle the various cases of output propagation to the input
1583 -- list. Output denotes a self-referencial output item. Inputs
1584 -- is the input list of a clause.
1586 ----------------------
1587 -- Propagate_Output --
1588 ----------------------
1590 procedure Propagate_Output
1594 function In_Input_List
1596 Inputs : List_Id) return Boolean;
1597 -- Determine whether a particulat item appears in the input
1598 -- list of a clause.
1604 function In_Input_List
1606 Inputs : List_Id) return Boolean
1611 Elmt := First (Inputs);
1612 while Present (Elmt) loop
1613 if Entity_Of (Elmt) = Item then
1625 Output_Id : constant Entity_Id := Entity_Of (Output);
1628 -- Start of processing for Propagate_Output
1631 -- The clause is of the form:
1633 -- (Output =>+ null)
1635 -- Remove null input and replace it with a copy of the output:
1637 -- (Output => Output)
1639 if Nkind (Inputs) = N_Null then
1640 Rewrite (Inputs, New_Copy_Tree (Output));
1642 -- The clause is of the form:
1644 -- (Output =>+ (Input1, ..., InputN))
1646 -- Determine whether the output is not already mentioned in the
1647 -- input list and if not, add it to the list of inputs:
1649 -- (Output => (Output, Input1, ..., InputN))
1651 elsif Nkind (Inputs) = N_Aggregate then
1652 Grouped := Expressions (Inputs);
1654 if not In_Input_List
1658 Prepend_To (Grouped, New_Copy_Tree (Output));
1661 -- The clause is of the form:
1663 -- (Output =>+ Input)
1665 -- If the input does not mention the output, group the two
1668 -- (Output => (Output, Input))
1670 elsif Entity_Of (Inputs) /= Output_Id then
1672 Make_Aggregate (Loc,
1673 Expressions => New_List (
1674 New_Copy_Tree (Output),
1675 New_Copy_Tree (Inputs))));
1677 end Propagate_Output;
1681 Loc : constant Source_Ptr := Sloc (Clause);
1682 New_Clause : Node_Id;
1684 -- Start of processing for Create_Or_Modify_Clause
1687 -- A null output depending on itself does not require any
1690 if Nkind (Output) = N_Null then
1693 -- A function result cannot depend on itself because it cannot
1694 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1696 elsif Is_Attribute_Result (Output) then
1697 SPARK_Msg_N ("function result cannot depend on itself", Output);
1701 -- When performing the transformation in place, simply add the
1702 -- output to the list of inputs (if not already there). This
1703 -- case arises when dealing with the last output of an output
1704 -- list. Perform the normalization in place to avoid generating
1705 -- a malformed tree.
1708 Propagate_Output (Output, Inputs);
1710 -- A list with multiple outputs is slowly trimmed until only
1711 -- one element remains. When this happens, replace aggregate
1712 -- with the element itself.
1716 Rewrite (Outputs, Output);
1722 -- Unchain the output from its output list as it will appear in
1723 -- a new clause. Note that we cannot simply rewrite the output
1724 -- as null because this will violate the semantics of pragma
1729 -- Generate a new clause of the form:
1730 -- (Output => Inputs)
1733 Make_Component_Association (Loc,
1734 Choices => New_List (Output),
1735 Expression => New_Copy_Tree (Inputs));
1737 -- The new clause contains replicated content that has already
1738 -- been analyzed. There is not need to reanalyze or renormalize
1741 Set_Analyzed (New_Clause);
1744 (Output => First (Choices (New_Clause)),
1745 Inputs => Expression (New_Clause));
1747 Insert_After (After, New_Clause);
1749 end Create_Or_Modify_Clause;
1753 Outputs : constant Node_Id := First (Choices (Clause));
1755 Last_Output : Node_Id;
1756 Next_Output : Node_Id;
1759 -- Start of processing for Normalize_Clause
1762 -- A self-dependency appears as operator "+". Remove the "+" from the
1763 -- tree by moving the real inputs to their proper place.
1765 if Nkind (Expression (Clause)) = N_Op_Plus then
1766 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1767 Inputs := Expression (Clause);
1769 -- Multiple outputs appear as an aggregate
1771 if Nkind (Outputs) = N_Aggregate then
1772 Last_Output := Last (Expressions (Outputs));
1774 Output := First (Expressions (Outputs));
1775 while Present (Output) loop
1777 -- Normalization may remove an output from its list,
1778 -- preserve the subsequent output now.
1780 Next_Output := Next (Output);
1782 Create_Or_Modify_Clause
1787 In_Place => Output = Last_Output,
1790 Output := Next_Output;
1796 Create_Or_Modify_Clause
1805 end Normalize_Clause;
1809 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1810 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1814 Last_Clause : Node_Id;
1815 Restore_Scope : Boolean := False;
1817 -- Start of processing for Analyze_Depends_In_Decl_Part
1820 -- Do not analyze the pragma multiple times
1822 if Is_Analyzed_Pragma (N) then
1826 -- Empty dependency list
1828 if Nkind (Deps) = N_Null then
1830 -- Gather all states, objects and formal parameters that the
1831 -- subprogram may depend on. These items are obtained from the
1832 -- parameter profile or pragma [Refined_]Global (if available).
1834 Collect_Subprogram_Inputs_Outputs
1835 (Subp_Id => Subp_Id,
1836 Subp_Inputs => Subp_Inputs,
1837 Subp_Outputs => Subp_Outputs,
1838 Global_Seen => Global_Seen);
1840 -- Verify that every input or output of the subprogram appear in a
1843 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1844 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1845 Check_Function_Return;
1847 -- Dependency clauses appear as component associations of an aggregate
1849 elsif Nkind (Deps) = N_Aggregate then
1851 -- Do not attempt to perform analysis of a syntactically illegal
1852 -- clause as this will lead to misleading errors.
1854 if Has_Extra_Parentheses (Deps) then
1858 if Present (Component_Associations (Deps)) then
1859 Last_Clause := Last (Component_Associations (Deps));
1861 -- Gather all states, objects and formal parameters that the
1862 -- subprogram may depend on. These items are obtained from the
1863 -- parameter profile or pragma [Refined_]Global (if available).
1865 Collect_Subprogram_Inputs_Outputs
1866 (Subp_Id => Subp_Id,
1867 Subp_Inputs => Subp_Inputs,
1868 Subp_Outputs => Subp_Outputs,
1869 Global_Seen => Global_Seen);
1871 -- When pragma [Refined_]Depends appears on a single concurrent
1872 -- type, it is relocated to the anonymous object.
1874 if Is_Single_Concurrent_Object (Spec_Id) then
1877 -- Ensure that the formal parameters are visible when analyzing
1878 -- all clauses. This falls out of the general rule of aspects
1879 -- pertaining to subprogram declarations.
1881 elsif not In_Open_Scopes (Spec_Id) then
1882 Restore_Scope := True;
1883 Push_Scope (Spec_Id);
1885 if Ekind (Spec_Id) = E_Task_Type then
1886 if Has_Discriminants (Spec_Id) then
1887 Install_Discriminants (Spec_Id);
1890 elsif Is_Generic_Subprogram (Spec_Id) then
1891 Install_Generic_Formals (Spec_Id);
1894 Install_Formals (Spec_Id);
1898 Clause := First (Component_Associations (Deps));
1899 while Present (Clause) loop
1900 Errors := Serious_Errors_Detected;
1902 -- The normalization mechanism may create extra clauses that
1903 -- contain replicated input and output names. There is no need
1904 -- to reanalyze them.
1906 if not Analyzed (Clause) then
1907 Set_Analyzed (Clause);
1909 Analyze_Dependency_Clause
1911 Is_Last => Clause = Last_Clause);
1914 -- Do not normalize a clause if errors were detected (count
1915 -- of Serious_Errors has increased) because the inputs and/or
1916 -- outputs may denote illegal items. Normalization is disabled
1917 -- in ASIS mode as it alters the tree by introducing new nodes
1918 -- similar to expansion.
1920 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1921 Normalize_Clause (Clause);
1927 if Restore_Scope then
1931 -- Verify that every input or output of the subprogram appear in a
1934 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1935 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1936 Check_Function_Return;
1938 -- The dependency list is malformed. This is a syntax error, always
1942 Error_Msg_N ("malformed dependency relation", Deps);
1946 -- The top level dependency relation is malformed. This is a syntax
1947 -- error, always report.
1950 Error_Msg_N ("malformed dependency relation", Deps);
1954 -- Ensure that a state and a corresponding constituent do not appear
1955 -- together in pragma [Refined_]Depends.
1957 Check_State_And_Constituent_Use
1958 (States => States_Seen,
1959 Constits => Constits_Seen,
1963 Set_Is_Analyzed_Pragma (N);
1964 end Analyze_Depends_In_Decl_Part;
1966 --------------------------------------------
1967 -- Analyze_External_Property_In_Decl_Part --
1968 --------------------------------------------
1970 procedure Analyze_External_Property_In_Decl_Part
1972 Expr_Val : out Boolean)
1974 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1975 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1976 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1982 -- Do not analyze the pragma multiple times
1984 if Is_Analyzed_Pragma (N) then
1988 Error_Msg_Name_1 := Pragma_Name (N);
1990 -- An external property pragma must apply to an effectively volatile
1991 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1992 -- The check is performed at the end of the declarative region due to a
1993 -- possible out-of-order arrangement of pragmas:
1996 -- pragma Async_Readers (Obj);
1997 -- pragma Volatile (Obj);
1999 if not Is_Effectively_Volatile (Obj_Id) then
2001 ("external property % must apply to a volatile object", N);
2004 -- Ensure that the Boolean expression (if present) is static. A missing
2005 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2009 if Present (Arg1) then
2010 Expr := Get_Pragma_Arg (Arg1);
2012 if Is_OK_Static_Expression (Expr) then
2013 Expr_Val := Is_True (Expr_Value (Expr));
2017 Set_Is_Analyzed_Pragma (N);
2018 end Analyze_External_Property_In_Decl_Part;
2020 ---------------------------------
2021 -- Analyze_Global_In_Decl_Part --
2022 ---------------------------------
2024 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2025 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2026 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2027 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2029 Constits_Seen : Elist_Id := No_Elist;
2030 -- A list containing the entities of all constituents processed so far.
2031 -- It aids in detecting illegal usage of a state and a corresponding
2032 -- constituent in pragma [Refinde_]Global.
2034 Seen : Elist_Id := No_Elist;
2035 -- A list containing the entities of all the items processed so far. It
2036 -- plays a role in detecting distinct entities.
2038 States_Seen : Elist_Id := No_Elist;
2039 -- A list containing the entities of all states processed so far. It
2040 -- helps in detecting illegal usage of a state and a corresponding
2041 -- constituent in pragma [Refined_]Global.
2043 In_Out_Seen : Boolean := False;
2044 Input_Seen : Boolean := False;
2045 Output_Seen : Boolean := False;
2046 Proof_Seen : Boolean := False;
2047 -- Flags used to verify the consistency of modes
2049 procedure Analyze_Global_List
2051 Global_Mode : Name_Id := Name_Input);
2052 -- Verify the legality of a single global list declaration. Global_Mode
2053 -- denotes the current mode in effect.
2055 -------------------------
2056 -- Analyze_Global_List --
2057 -------------------------
2059 procedure Analyze_Global_List
2061 Global_Mode : Name_Id := Name_Input)
2063 procedure Analyze_Global_Item
2065 Global_Mode : Name_Id);
2066 -- Verify the legality of a single global item declaration denoted by
2067 -- Item. Global_Mode denotes the current mode in effect.
2069 procedure Check_Duplicate_Mode
2071 Status : in out Boolean);
2072 -- Flag Status denotes whether a particular mode has been seen while
2073 -- processing a global list. This routine verifies that Mode is not a
2074 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2076 procedure Check_Mode_Restriction_In_Enclosing_Context
2078 Item_Id : Entity_Id);
2079 -- Verify that an item of mode In_Out or Output does not appear as an
2080 -- input in the Global aspect of an enclosing subprogram. If this is
2081 -- the case, emit an error. Item and Item_Id are respectively the
2082 -- item and its entity.
2084 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2085 -- Mode denotes either In_Out or Output. Depending on the kind of the
2086 -- related subprogram, emit an error if those two modes apply to a
2087 -- function (SPARK RM 6.1.4(10)).
2089 -------------------------
2090 -- Analyze_Global_Item --
2091 -------------------------
2093 procedure Analyze_Global_Item
2095 Global_Mode : Name_Id)
2097 Item_Id : Entity_Id;
2100 -- Detect one of the following cases
2102 -- with Global => (null, Name)
2103 -- with Global => (Name_1, null, Name_2)
2104 -- with Global => (Name, null)
2106 if Nkind (Item) = N_Null then
2107 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2112 Resolve_State (Item);
2114 -- Find the entity of the item. If this is a renaming, climb the
2115 -- renaming chain to reach the root object. Renamings of non-
2116 -- entire objects do not yield an entity (Empty).
2118 Item_Id := Entity_Of (Item);
2120 if Present (Item_Id) then
2122 -- A global item may denote a formal parameter of an enclosing
2123 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2124 -- provide a better error diagnostic.
2126 if Is_Formal (Item_Id) then
2127 if Scope (Item_Id) = Spec_Id then
2129 (Fix_Msg (Spec_Id, "global item cannot reference "
2130 & "parameter of subprogram &"), Item, Spec_Id);
2134 -- A global item may denote a concurrent type as long as it is
2135 -- the current instance of an enclosing protected or task type
2136 -- (SPARK RM 6.1.4).
2138 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2139 if Is_CCT_Instance (Item_Id, Spec_Id) then
2141 -- Pragma [Refined_]Global associated with a protected
2142 -- subprogram cannot mention the current instance of a
2143 -- protected type because the instance behaves as a
2144 -- formal parameter.
2146 if Ekind (Item_Id) = E_Protected_Type then
2147 Error_Msg_Name_1 := Chars (Item_Id);
2149 (Fix_Msg (Spec_Id, "global item of subprogram & "
2150 & "cannot reference current instance of protected "
2151 & "type %"), Item, Spec_Id);
2154 -- Pragma [Refined_]Global associated with a task type
2155 -- cannot mention the current instance of a task type
2156 -- because the instance behaves as a formal parameter.
2158 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2159 Error_Msg_Name_1 := Chars (Item_Id);
2161 (Fix_Msg (Spec_Id, "global item of subprogram & "
2162 & "cannot reference current instance of task type "
2163 & "%"), Item, Spec_Id);
2167 -- Otherwise the global item denotes a subtype mark that is
2168 -- not a current instance.
2172 ("invalid use of subtype mark in global list", Item);
2176 -- A global item may denote the anonymous object created for a
2177 -- single protected/task type as long as the current instance
2178 -- is the same single type (SPARK RM 6.1.4).
2180 elsif Is_Single_Concurrent_Object (Item_Id)
2181 and then Is_CCT_Instance (Item_Id, Spec_Id)
2183 -- Pragma [Refined_]Global associated with a protected
2184 -- subprogram cannot mention the current instance of a
2185 -- protected type because the instance behaves as a formal
2188 if Is_Single_Protected_Object (Item_Id) then
2189 Error_Msg_Name_1 := Chars (Item_Id);
2191 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2192 & "reference current instance of protected type %"),
2196 -- Pragma [Refined_]Global associated with a task type
2197 -- cannot mention the current instance of a task type
2198 -- because the instance behaves as a formal parameter.
2200 else pragma Assert (Is_Single_Task_Object (Item_Id));
2201 Error_Msg_Name_1 := Chars (Item_Id);
2203 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2204 & "reference current instance of task type %"),
2209 -- A formal object may act as a global item inside a generic
2211 elsif Is_Formal_Object (Item_Id) then
2214 -- The only legal references are those to abstract states,
2215 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2217 elsif not Ekind_In (Item_Id, E_Abstract_State,
2224 ("global item must denote object, state or current "
2225 & "instance of concurrent type", Item);
2229 -- State related checks
2231 if Ekind (Item_Id) = E_Abstract_State then
2233 -- Package and subprogram bodies are instantiated
2234 -- individually in a separate compiler pass. Due to this
2235 -- mode of instantiation, the refinement of a state may
2236 -- no longer be visible when a subprogram body contract
2237 -- is instantiated. Since the generic template is legal,
2238 -- do not perform this check in the instance to circumvent
2241 if Is_Generic_Instance (Spec_Id) then
2244 -- An abstract state with visible refinement cannot appear
2245 -- in pragma [Refined_]Global as its place must be taken by
2246 -- some of its constituents (SPARK RM 6.1.4(7)).
2248 elsif Has_Visible_Refinement (Item_Id) then
2250 ("cannot mention state & in global refinement",
2252 SPARK_Msg_N ("\use its constituents instead", Item);
2255 -- An external state cannot appear as a global item of a
2256 -- nonvolatile function (SPARK RM 7.1.3(8)).
2258 elsif Is_External_State (Item_Id)
2259 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2260 and then not Is_Volatile_Function (Spec_Id)
2263 ("external state & cannot act as global item of "
2264 & "nonvolatile function", Item, Item_Id);
2267 -- If the reference to the abstract state appears in an
2268 -- enclosing package body that will eventually refine the
2269 -- state, record the reference for future checks.
2272 Record_Possible_Body_Reference
2273 (State_Id => Item_Id,
2277 -- Constant related checks
2279 elsif Ekind (Item_Id) = E_Constant then
2281 -- A constant is a read-only item, therefore it cannot act
2284 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2286 ("constant & cannot act as output", Item, Item_Id);
2290 -- Discriminant related checks
2292 elsif Ekind (Item_Id) = E_Discriminant then
2294 -- A discriminant is a read-only item, therefore it cannot
2295 -- act as an output.
2297 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2299 ("discriminant & cannot act as output", Item, Item_Id);
2303 -- Loop parameter related checks
2305 elsif Ekind (Item_Id) = E_Loop_Parameter then
2307 -- A loop parameter is a read-only item, therefore it cannot
2308 -- act as an output.
2310 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2312 ("loop parameter & cannot act as output",
2317 -- Variable related checks. These are only relevant when
2318 -- SPARK_Mode is on as they are not standard Ada legality
2321 elsif SPARK_Mode = On
2322 and then Ekind (Item_Id) = E_Variable
2323 and then Is_Effectively_Volatile (Item_Id)
2325 -- An effectively volatile object cannot appear as a global
2326 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2328 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2329 and then not Is_Volatile_Function (Spec_Id)
2332 ("volatile object & cannot act as global item of a "
2333 & "function", Item, Item_Id);
2336 -- An effectively volatile object with external property
2337 -- Effective_Reads set to True must have mode Output or
2338 -- In_Out (SPARK RM 7.1.3(10)).
2340 elsif Effective_Reads_Enabled (Item_Id)
2341 and then Global_Mode = Name_Input
2344 ("volatile object & with property Effective_Reads must "
2345 & "have mode In_Out or Output", Item, Item_Id);
2350 -- When the item renames an entire object, replace the item
2351 -- with a reference to the object.
2353 if Entity (Item) /= Item_Id then
2354 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2358 -- Some form of illegal construct masquerading as a name
2359 -- (SPARK RM 6.1.4(4)).
2363 ("global item must denote object, state or current instance "
2364 & "of concurrent type", Item);
2368 -- Verify that an output does not appear as an input in an
2369 -- enclosing subprogram.
2371 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2372 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2375 -- The same entity might be referenced through various way.
2376 -- Check the entity of the item rather than the item itself
2377 -- (SPARK RM 6.1.4(10)).
2379 if Contains (Seen, Item_Id) then
2380 SPARK_Msg_N ("duplicate global item", Item);
2382 -- Add the entity of the current item to the list of processed
2386 Append_New_Elmt (Item_Id, Seen);
2388 if Ekind (Item_Id) = E_Abstract_State then
2389 Append_New_Elmt (Item_Id, States_Seen);
2391 -- The variable may eventually become a constituent of a single
2392 -- protected/task type. Record the reference now and verify its
2393 -- legality when analyzing the contract of the variable
2396 elsif Ekind (Item_Id) = E_Variable then
2397 Record_Possible_Part_Of_Reference
2402 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2403 and then Present (Encapsulating_State (Item_Id))
2405 Append_New_Elmt (Item_Id, Constits_Seen);
2408 end Analyze_Global_Item;
2410 --------------------------
2411 -- Check_Duplicate_Mode --
2412 --------------------------
2414 procedure Check_Duplicate_Mode
2416 Status : in out Boolean)
2420 SPARK_Msg_N ("duplicate global mode", Mode);
2424 end Check_Duplicate_Mode;
2426 -------------------------------------------------
2427 -- Check_Mode_Restriction_In_Enclosing_Context --
2428 -------------------------------------------------
2430 procedure Check_Mode_Restriction_In_Enclosing_Context
2432 Item_Id : Entity_Id)
2434 Context : Entity_Id;
2436 Inputs : Elist_Id := No_Elist;
2437 Outputs : Elist_Id := No_Elist;
2440 -- Traverse the scope stack looking for enclosing subprograms
2441 -- subject to pragma [Refined_]Global.
2443 Context := Scope (Subp_Id);
2444 while Present (Context) and then Context /= Standard_Standard loop
2445 if Is_Subprogram (Context)
2447 (Present (Get_Pragma (Context, Pragma_Global))
2449 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2451 Collect_Subprogram_Inputs_Outputs
2452 (Subp_Id => Context,
2453 Subp_Inputs => Inputs,
2454 Subp_Outputs => Outputs,
2455 Global_Seen => Dummy);
2457 -- The item is classified as In_Out or Output but appears as
2458 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2460 if Appears_In (Inputs, Item_Id)
2461 and then not Appears_In (Outputs, Item_Id)
2464 ("global item & cannot have mode In_Out or Output",
2468 (Fix_Msg (Subp_Id, "\item already appears as input of "
2469 & "subprogram &"), Item, Context);
2471 -- Stop the traversal once an error has been detected
2477 Context := Scope (Context);
2479 end Check_Mode_Restriction_In_Enclosing_Context;
2481 ----------------------------------------
2482 -- Check_Mode_Restriction_In_Function --
2483 ----------------------------------------
2485 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2487 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2489 ("global mode & is not applicable to functions", Mode);
2491 end Check_Mode_Restriction_In_Function;
2499 -- Start of processing for Analyze_Global_List
2502 if Nkind (List) = N_Null then
2503 Set_Analyzed (List);
2505 -- Single global item declaration
2507 elsif Nkind_In (List, N_Expanded_Name,
2509 N_Selected_Component)
2511 Analyze_Global_Item (List, Global_Mode);
2513 -- Simple global list or moded global list declaration
2515 elsif Nkind (List) = N_Aggregate then
2516 Set_Analyzed (List);
2518 -- The declaration of a simple global list appear as a collection
2521 if Present (Expressions (List)) then
2522 if Present (Component_Associations (List)) then
2524 ("cannot mix moded and non-moded global lists", List);
2527 Item := First (Expressions (List));
2528 while Present (Item) loop
2529 Analyze_Global_Item (Item, Global_Mode);
2533 -- The declaration of a moded global list appears as a collection
2534 -- of component associations where individual choices denote
2537 elsif Present (Component_Associations (List)) then
2538 if Present (Expressions (List)) then
2540 ("cannot mix moded and non-moded global lists", List);
2543 Assoc := First (Component_Associations (List));
2544 while Present (Assoc) loop
2545 Mode := First (Choices (Assoc));
2547 if Nkind (Mode) = N_Identifier then
2548 if Chars (Mode) = Name_In_Out then
2549 Check_Duplicate_Mode (Mode, In_Out_Seen);
2550 Check_Mode_Restriction_In_Function (Mode);
2552 elsif Chars (Mode) = Name_Input then
2553 Check_Duplicate_Mode (Mode, Input_Seen);
2555 elsif Chars (Mode) = Name_Output then
2556 Check_Duplicate_Mode (Mode, Output_Seen);
2557 Check_Mode_Restriction_In_Function (Mode);
2559 elsif Chars (Mode) = Name_Proof_In then
2560 Check_Duplicate_Mode (Mode, Proof_Seen);
2563 SPARK_Msg_N ("invalid mode selector", Mode);
2567 SPARK_Msg_N ("invalid mode selector", Mode);
2570 -- Items in a moded list appear as a collection of
2571 -- expressions. Reuse the existing machinery to analyze
2575 (List => Expression (Assoc),
2576 Global_Mode => Chars (Mode));
2584 raise Program_Error;
2587 -- Any other attempt to declare a global item is illegal. This is a
2588 -- syntax error, always report.
2591 Error_Msg_N ("malformed global list", List);
2593 end Analyze_Global_List;
2597 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2599 Restore_Scope : Boolean := False;
2601 -- Start of processing for Analyze_Global_In_Decl_Part
2604 -- Do not analyze the pragma multiple times
2606 if Is_Analyzed_Pragma (N) then
2610 -- There is nothing to be done for a null global list
2612 if Nkind (Items) = N_Null then
2613 Set_Analyzed (Items);
2615 -- Analyze the various forms of global lists and items. Note that some
2616 -- of these may be malformed in which case the analysis emits error
2620 -- When pragma [Refined_]Global appears on a single concurrent type,
2621 -- it is relocated to the anonymous object.
2623 if Is_Single_Concurrent_Object (Spec_Id) then
2626 -- Ensure that the formal parameters are visible when processing an
2627 -- item. This falls out of the general rule of aspects pertaining to
2628 -- subprogram declarations.
2630 elsif not In_Open_Scopes (Spec_Id) then
2631 Restore_Scope := True;
2632 Push_Scope (Spec_Id);
2634 if Ekind (Spec_Id) = E_Task_Type then
2635 if Has_Discriminants (Spec_Id) then
2636 Install_Discriminants (Spec_Id);
2639 elsif Is_Generic_Subprogram (Spec_Id) then
2640 Install_Generic_Formals (Spec_Id);
2643 Install_Formals (Spec_Id);
2647 Analyze_Global_List (Items);
2649 if Restore_Scope then
2654 -- Ensure that a state and a corresponding constituent do not appear
2655 -- together in pragma [Refined_]Global.
2657 Check_State_And_Constituent_Use
2658 (States => States_Seen,
2659 Constits => Constits_Seen,
2662 Set_Is_Analyzed_Pragma (N);
2663 end Analyze_Global_In_Decl_Part;
2665 --------------------------------------------
2666 -- Analyze_Initial_Condition_In_Decl_Part --
2667 --------------------------------------------
2669 -- WARNING: This routine manages Ghost regions. Return statements must be
2670 -- replaced by gotos which jump to the end of the routine and restore the
2673 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2674 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2675 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2676 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2678 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2679 -- Save the Ghost mode to restore on exit
2682 -- Do not analyze the pragma multiple times
2684 if Is_Analyzed_Pragma (N) then
2688 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2689 -- analysis of the pragma, the Ghost mode at point of declaration and
2690 -- point of analysis may not necessarily be the same. Use the mode in
2691 -- effect at the point of declaration.
2695 -- The expression is preanalyzed because it has not been moved to its
2696 -- final place yet. A direct analysis may generate side effects and this
2697 -- is not desired at this point.
2699 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2700 Set_Is_Analyzed_Pragma (N);
2702 Restore_Ghost_Mode (Saved_GM);
2703 end Analyze_Initial_Condition_In_Decl_Part;
2705 --------------------------------------
2706 -- Analyze_Initializes_In_Decl_Part --
2707 --------------------------------------
2709 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2710 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2711 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2713 Constits_Seen : Elist_Id := No_Elist;
2714 -- A list containing the entities of all constituents processed so far.
2715 -- It aids in detecting illegal usage of a state and a corresponding
2716 -- constituent in pragma Initializes.
2718 Items_Seen : Elist_Id := No_Elist;
2719 -- A list of all initialization items processed so far. This list is
2720 -- used to detect duplicate items.
2722 Non_Null_Seen : Boolean := False;
2723 Null_Seen : Boolean := False;
2724 -- Flags used to check the legality of a null initialization list
2726 States_And_Objs : Elist_Id := No_Elist;
2727 -- A list of all abstract states and objects declared in the visible
2728 -- declarations of the related package. This list is used to detect the
2729 -- legality of initialization items.
2731 States_Seen : Elist_Id := No_Elist;
2732 -- A list containing the entities of all states processed so far. It
2733 -- helps in detecting illegal usage of a state and a corresponding
2734 -- constituent in pragma Initializes.
2736 procedure Analyze_Initialization_Item (Item : Node_Id);
2737 -- Verify the legality of a single initialization item
2739 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2740 -- Verify the legality of a single initialization item followed by a
2741 -- list of input items.
2743 procedure Collect_States_And_Objects;
2744 -- Inspect the visible declarations of the related package and gather
2745 -- the entities of all abstract states and objects in States_And_Objs.
2747 ---------------------------------
2748 -- Analyze_Initialization_Item --
2749 ---------------------------------
2751 procedure Analyze_Initialization_Item (Item : Node_Id) is
2752 Item_Id : Entity_Id;
2755 -- Null initialization list
2757 if Nkind (Item) = N_Null then
2759 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2761 elsif Non_Null_Seen then
2763 ("cannot mix null and non-null initialization items", Item);
2768 -- Initialization item
2771 Non_Null_Seen := True;
2775 ("cannot mix null and non-null initialization items", Item);
2779 Resolve_State (Item);
2781 if Is_Entity_Name (Item) then
2782 Item_Id := Entity_Of (Item);
2784 if Ekind_In (Item_Id, E_Abstract_State,
2788 -- The state or variable must be declared in the visible
2789 -- declarations of the package (SPARK RM 7.1.5(7)).
2791 if not Contains (States_And_Objs, Item_Id) then
2792 Error_Msg_Name_1 := Chars (Pack_Id);
2794 ("initialization item & must appear in the visible "
2795 & "declarations of package %", Item, Item_Id);
2797 -- Detect a duplicate use of the same initialization item
2798 -- (SPARK RM 7.1.5(5)).
2800 elsif Contains (Items_Seen, Item_Id) then
2801 SPARK_Msg_N ("duplicate initialization item", Item);
2803 -- The item is legal, add it to the list of processed states
2807 Append_New_Elmt (Item_Id, Items_Seen);
2809 if Ekind (Item_Id) = E_Abstract_State then
2810 Append_New_Elmt (Item_Id, States_Seen);
2813 if Present (Encapsulating_State (Item_Id)) then
2814 Append_New_Elmt (Item_Id, Constits_Seen);
2818 -- The item references something that is not a state or object
2819 -- (SPARK RM 7.1.5(3)).
2823 ("initialization item must denote object or state", Item);
2826 -- Some form of illegal construct masquerading as a name
2827 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2831 ("initialization item must denote object or state", Item);
2834 end Analyze_Initialization_Item;
2836 ---------------------------------------------
2837 -- Analyze_Initialization_Item_With_Inputs --
2838 ---------------------------------------------
2840 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2841 Inputs_Seen : Elist_Id := No_Elist;
2842 -- A list of all inputs processed so far. This list is used to detect
2843 -- duplicate uses of an input.
2845 Non_Null_Seen : Boolean := False;
2846 Null_Seen : Boolean := False;
2847 -- Flags used to check the legality of an input list
2849 procedure Analyze_Input_Item (Input : Node_Id);
2850 -- Verify the legality of a single input item
2852 ------------------------
2853 -- Analyze_Input_Item --
2854 ------------------------
2856 procedure Analyze_Input_Item (Input : Node_Id) is
2857 Input_Id : Entity_Id;
2858 Input_OK : Boolean := True;
2863 if Nkind (Input) = N_Null then
2866 ("multiple null initializations not allowed", Item);
2868 elsif Non_Null_Seen then
2870 ("cannot mix null and non-null initialization item", Item);
2878 Non_Null_Seen := True;
2882 ("cannot mix null and non-null initialization item", Item);
2886 Resolve_State (Input);
2888 if Is_Entity_Name (Input) then
2889 Input_Id := Entity_Of (Input);
2891 if Ekind_In (Input_Id, E_Abstract_State,
2893 E_Generic_In_Out_Parameter,
2894 E_Generic_In_Parameter,
2900 -- The input cannot denote states or objects declared
2901 -- within the related package (SPARK RM 7.1.5(4)).
2903 if Within_Scope (Input_Id, Current_Scope) then
2905 -- Do not consider generic formal parameters or their
2906 -- respective mappings to generic formals. Even though
2907 -- the formals appear within the scope of the package,
2908 -- it is allowed for an initialization item to depend
2909 -- on an input item.
2911 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2912 E_Generic_In_Parameter)
2916 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2917 and then Present (Corresponding_Generic_Association
2918 (Declaration_Node (Input_Id)))
2924 Error_Msg_Name_1 := Chars (Pack_Id);
2926 ("input item & cannot denote a visible object or "
2927 & "state of package %", Input, Input_Id);
2931 -- Detect a duplicate use of the same input item
2932 -- (SPARK RM 7.1.5(5)).
2934 if Contains (Inputs_Seen, Input_Id) then
2936 SPARK_Msg_N ("duplicate input item", Input);
2939 -- Input is legal, add it to the list of processed inputs
2942 Append_New_Elmt (Input_Id, Inputs_Seen);
2944 if Ekind (Input_Id) = E_Abstract_State then
2945 Append_New_Elmt (Input_Id, States_Seen);
2948 if Ekind_In (Input_Id, E_Abstract_State,
2951 and then Present (Encapsulating_State (Input_Id))
2953 Append_New_Elmt (Input_Id, Constits_Seen);
2957 -- The input references something that is not a state or an
2958 -- object (SPARK RM 7.1.5(3)).
2962 ("input item must denote object or state", Input);
2965 -- Some form of illegal construct masquerading as a name
2966 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2970 ("input item must denote object or state", Input);
2973 end Analyze_Input_Item;
2977 Inputs : constant Node_Id := Expression (Item);
2981 Name_Seen : Boolean := False;
2982 -- A flag used to detect multiple item names
2984 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2987 -- Inspect the name of an item with inputs
2989 Elmt := First (Choices (Item));
2990 while Present (Elmt) loop
2992 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2995 Analyze_Initialization_Item (Elmt);
3001 -- Multiple input items appear as an aggregate
3003 if Nkind (Inputs) = N_Aggregate then
3004 if Present (Expressions (Inputs)) then
3005 Input := First (Expressions (Inputs));
3006 while Present (Input) loop
3007 Analyze_Input_Item (Input);
3012 if Present (Component_Associations (Inputs)) then
3014 ("inputs must appear in named association form", Inputs);
3017 -- Single input item
3020 Analyze_Input_Item (Inputs);
3022 end Analyze_Initialization_Item_With_Inputs;
3024 --------------------------------
3025 -- Collect_States_And_Objects --
3026 --------------------------------
3028 procedure Collect_States_And_Objects is
3029 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3033 -- Collect the abstract states defined in the package (if any)
3035 if Present (Abstract_States (Pack_Id)) then
3036 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3039 -- Collect all objects the appear in the visible declarations of the
3042 if Present (Visible_Declarations (Pack_Spec)) then
3043 Decl := First (Visible_Declarations (Pack_Spec));
3044 while Present (Decl) loop
3045 if Comes_From_Source (Decl)
3046 and then Nkind (Decl) = N_Object_Declaration
3048 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3054 end Collect_States_And_Objects;
3058 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3061 -- Start of processing for Analyze_Initializes_In_Decl_Part
3064 -- Do not analyze the pragma multiple times
3066 if Is_Analyzed_Pragma (N) then
3070 -- Nothing to do when the initialization list is empty
3072 if Nkind (Inits) = N_Null then
3076 -- Single and multiple initialization clauses appear as an aggregate. If
3077 -- this is not the case, then either the parser or the analysis of the
3078 -- pragma failed to produce an aggregate.
3080 pragma Assert (Nkind (Inits) = N_Aggregate);
3082 -- Initialize the various lists used during analysis
3084 Collect_States_And_Objects;
3086 if Present (Expressions (Inits)) then
3087 Init := First (Expressions (Inits));
3088 while Present (Init) loop
3089 Analyze_Initialization_Item (Init);
3094 if Present (Component_Associations (Inits)) then
3095 Init := First (Component_Associations (Inits));
3096 while Present (Init) loop
3097 Analyze_Initialization_Item_With_Inputs (Init);
3102 -- Ensure that a state and a corresponding constituent do not appear
3103 -- together in pragma Initializes.
3105 Check_State_And_Constituent_Use
3106 (States => States_Seen,
3107 Constits => Constits_Seen,
3110 Set_Is_Analyzed_Pragma (N);
3111 end Analyze_Initializes_In_Decl_Part;
3113 ---------------------
3114 -- Analyze_Part_Of --
3115 ---------------------
3117 procedure Analyze_Part_Of
3119 Item_Id : Entity_Id;
3121 Encap_Id : out Entity_Id;
3122 Legal : out Boolean)
3124 Encap_Typ : Entity_Id;
3125 Item_Decl : Node_Id;
3126 Pack_Id : Entity_Id;
3127 Placement : State_Space_Kind;
3128 Parent_Unit : Entity_Id;
3131 -- Assume that the indicator is illegal
3136 if Nkind_In (Encap, N_Expanded_Name,
3138 N_Selected_Component)
3141 Resolve_State (Encap);
3143 Encap_Id := Entity (Encap);
3145 -- The encapsulator is an abstract state
3147 if Ekind (Encap_Id) = E_Abstract_State then
3150 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3152 elsif Is_Single_Concurrent_Object (Encap_Id) then
3155 -- Otherwise the encapsulator is not a legal choice
3159 ("indicator Part_Of must denote abstract state, single "
3160 & "protected type or single task type", Encap);
3164 -- This is a syntax error, always report
3168 ("indicator Part_Of must denote abstract state, single protected "
3169 & "type or single task type", Encap);
3173 -- Catch a case where indicator Part_Of denotes the abstract view of a
3174 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3176 if From_Limited_With (Encap_Id)
3177 and then Present (Non_Limited_View (Encap_Id))
3178 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3180 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3181 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3185 -- The encapsulator is an abstract state
3187 if Ekind (Encap_Id) = E_Abstract_State then
3189 -- Determine where the object, package instantiation or state lives
3190 -- with respect to the enclosing packages or package bodies.
3192 Find_Placement_In_State_Space
3193 (Item_Id => Item_Id,
3194 Placement => Placement,
3195 Pack_Id => Pack_Id);
3197 -- The item appears in a non-package construct with a declarative
3198 -- part (subprogram, block, etc). As such, the item is not allowed
3199 -- to be a part of an encapsulating state because the item is not
3202 if Placement = Not_In_Package then
3204 ("indicator Part_Of cannot appear in this context "
3205 & "(SPARK RM 7.2.6(5))", Indic);
3206 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3208 ("\& is not part of the hidden state of package %",
3211 -- The item appears in the visible state space of some package. In
3212 -- general this scenario does not warrant Part_Of except when the
3213 -- package is a private child unit and the encapsulating state is
3214 -- declared in a parent unit or a public descendant of that parent
3217 elsif Placement = Visible_State_Space then
3218 if Is_Child_Unit (Pack_Id)
3219 and then Is_Private_Descendant (Pack_Id)
3221 -- A variable or state abstraction which is part of the visible
3222 -- state of a private child unit (or one of its public
3223 -- descendants) must have its Part_Of indicator specified. The
3224 -- Part_Of indicator must denote a state abstraction declared
3225 -- by either the parent unit of the private unit or by a public
3226 -- descendant of that parent unit.
3228 -- Find nearest private ancestor (which can be the current unit
3231 Parent_Unit := Pack_Id;
3232 while Present (Parent_Unit) loop
3235 (Parent (Unit_Declaration_Node (Parent_Unit)));
3236 Parent_Unit := Scope (Parent_Unit);
3239 Parent_Unit := Scope (Parent_Unit);
3241 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3243 ("indicator Part_Of must denote abstract state or public "
3244 & "descendant of & (SPARK RM 7.2.6(3))",
3245 Indic, Parent_Unit);
3247 elsif Scope (Encap_Id) = Parent_Unit
3249 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3250 and then not Is_Private_Descendant (Scope (Encap_Id)))
3256 ("indicator Part_Of must denote abstract state or public "
3257 & "descendant of & (SPARK RM 7.2.6(3))",
3258 Indic, Parent_Unit);
3261 -- Indicator Part_Of is not needed when the related package is not
3262 -- a private child unit or a public descendant thereof.
3266 ("indicator Part_Of cannot appear in this context "
3267 & "(SPARK RM 7.2.6(5))", Indic);
3268 Error_Msg_Name_1 := Chars (Pack_Id);
3270 ("\& is declared in the visible part of package %",
3274 -- When the item appears in the private state space of a package, the
3275 -- encapsulating state must be declared in the same package.
3277 elsif Placement = Private_State_Space then
3278 if Scope (Encap_Id) /= Pack_Id then
3280 ("indicator Part_Of must designate an abstract state of "
3281 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3282 Error_Msg_Name_1 := Chars (Pack_Id);
3284 ("\& is declared in the private part of package %",
3288 -- Items declared in the body state space of a package do not need
3289 -- Part_Of indicators as the refinement has already been seen.
3293 ("indicator Part_Of cannot appear in this context "
3294 & "(SPARK RM 7.2.6(5))", Indic);
3296 if Scope (Encap_Id) = Pack_Id then
3297 Error_Msg_Name_1 := Chars (Pack_Id);
3299 ("\& is declared in the body of package %", Indic, Item_Id);
3303 -- The encapsulator is a single concurrent type
3306 Encap_Typ := Etype (Encap_Id);
3308 -- Only abstract states and variables can act as constituents of an
3309 -- encapsulating single concurrent type.
3311 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3314 -- The constituent is a constant
3316 elsif Ekind (Item_Id) = E_Constant then
3317 Error_Msg_Name_1 := Chars (Encap_Id);
3319 (Fix_Msg (Encap_Typ, "constant & cannot act as constituent of "
3320 & "single protected type %"), Indic, Item_Id);
3322 -- The constituent is a package instantiation
3325 Error_Msg_Name_1 := Chars (Encap_Id);
3327 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3328 & "constituent of single protected type %"), Indic, Item_Id);
3331 -- When the item denotes an abstract state of a nested package, use
3332 -- the declaration of the package to detect proper placement.
3337 -- with Abstract_State => (State with Part_Of => T)
3339 if Ekind (Item_Id) = E_Abstract_State then
3340 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3342 Item_Decl := Declaration_Node (Item_Id);
3345 -- Both the item and its encapsulating single concurrent type must
3346 -- appear in the same declarative region (SPARK RM 9.3). Note that
3347 -- privacy is ignored.
3349 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3350 Error_Msg_Name_1 := Chars (Encap_Id);
3352 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3353 & "immediately within the same region as single protected "
3354 & "type %"), Indic, Item_Id);
3359 end Analyze_Part_Of;
3361 ----------------------------------
3362 -- Analyze_Part_Of_In_Decl_Part --
3363 ----------------------------------
3365 procedure Analyze_Part_Of_In_Decl_Part
3367 Freeze_Id : Entity_Id := Empty)
3369 Encap : constant Node_Id :=
3370 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3371 Errors : constant Nat := Serious_Errors_Detected;
3372 Var_Decl : constant Node_Id := Find_Related_Context (N);
3373 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3374 Constits : Elist_Id;
3375 Encap_Id : Entity_Id;
3379 -- Detect any discrepancies between the placement of the variable with
3380 -- respect to general state space and the encapsulating state or single
3387 Encap_Id => Encap_Id,
3390 -- The Part_Of indicator turns the variable into a constituent of the
3391 -- encapsulating state or single concurrent type.
3394 pragma Assert (Present (Encap_Id));
3395 Constits := Part_Of_Constituents (Encap_Id);
3397 if No (Constits) then
3398 Constits := New_Elmt_List;
3399 Set_Part_Of_Constituents (Encap_Id, Constits);
3402 Append_Elmt (Var_Id, Constits);
3403 Set_Encapsulating_State (Var_Id, Encap_Id);
3405 -- A Part_Of constituent partially refines an abstract state. This
3406 -- property does not apply to protected or task units.
3408 if Ekind (Encap_Id) = E_Abstract_State then
3409 Set_Has_Partial_Visible_Refinement (Encap_Id);
3413 -- Emit a clarification message when the encapsulator is undefined,
3414 -- possibly due to contract "freezing".
3416 if Errors /= Serious_Errors_Detected
3417 and then Present (Freeze_Id)
3418 and then Has_Undefined_Reference (Encap)
3420 Contract_Freeze_Error (Var_Id, Freeze_Id);
3422 end Analyze_Part_Of_In_Decl_Part;
3424 --------------------
3425 -- Analyze_Pragma --
3426 --------------------
3428 procedure Analyze_Pragma (N : Node_Id) is
3429 Loc : constant Source_Ptr := Sloc (N);
3431 Pname : Name_Id := Pragma_Name (N);
3432 -- Name of the source pragma, or name of the corresponding aspect for
3433 -- pragmas which originate in a source aspect. In the latter case, the
3434 -- name may be different from the pragma name.
3436 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3438 Pragma_Exit : exception;
3439 -- This exception is used to exit pragma processing completely. It
3440 -- is used when an error is detected, and no further processing is
3441 -- required. It is also used if an earlier error has left the tree in
3442 -- a state where the pragma should not be processed.
3445 -- Number of pragma argument associations
3451 -- First four pragma arguments (pragma argument association nodes, or
3452 -- Empty if the corresponding argument does not exist).
3454 type Name_List is array (Natural range <>) of Name_Id;
3455 type Args_List is array (Natural range <>) of Node_Id;
3456 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3458 -----------------------
3459 -- Local Subprograms --
3460 -----------------------
3462 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3463 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3464 -- get the given string argument, and place it in Name_Buffer, adding
3465 -- leading and trailing asterisks if they are not already present. The
3466 -- caller has already checked that Arg is a static string expression.
3468 procedure Ada_2005_Pragma;
3469 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3470 -- Ada 95 mode, these are implementation defined pragmas, so should be
3471 -- caught by the No_Implementation_Pragmas restriction.
3473 procedure Ada_2012_Pragma;
3474 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3475 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3476 -- should be caught by the No_Implementation_Pragmas restriction.
3478 procedure Analyze_Depends_Global
3479 (Spec_Id : out Entity_Id;
3480 Subp_Decl : out Node_Id;
3481 Legal : out Boolean);
3482 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3483 -- legality of the placement and related context of the pragma. Spec_Id
3484 -- is the entity of the related subprogram. Subp_Decl is the declaration
3485 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3487 procedure Analyze_If_Present (Id : Pragma_Id);
3488 -- Inspect the remainder of the list containing pragma N and look for
3489 -- a pragma that matches Id. If found, analyze the pragma.
3491 procedure Analyze_Pre_Post_Condition;
3492 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3494 procedure Analyze_Refined_Depends_Global_Post
3495 (Spec_Id : out Entity_Id;
3496 Body_Id : out Entity_Id;
3497 Legal : out Boolean);
3498 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3499 -- Refined_Global and Refined_Post. Verify the legality of the placement
3500 -- and related context of the pragma. Spec_Id is the entity of the
3501 -- related subprogram. Body_Id is the entity of the subprogram body.
3502 -- Flag Legal is set when the pragma is legal.
3504 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3505 -- Perform full analysis of pragma Unmodified and the write aspect of
3506 -- pragma Unused. Flag Is_Unused should be set when verifying the
3507 -- semantics of pragma Unused.
3509 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3510 -- Perform full analysis of pragma Unreferenced and the read aspect of
3511 -- pragma Unused. Flag Is_Unused should be set when verifying the
3512 -- semantics of pragma Unused.
3514 procedure Check_Ada_83_Warning;
3515 -- Issues a warning message for the current pragma if operating in Ada
3516 -- 83 mode (used for language pragmas that are not a standard part of
3517 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3520 procedure Check_Arg_Count (Required : Nat);
3521 -- Check argument count for pragma is equal to given parameter. If not,
3522 -- then issue an error message and raise Pragma_Exit.
3524 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3525 -- Arg which can either be a pragma argument association, in which case
3526 -- the check is applied to the expression of the association or an
3527 -- expression directly.
3529 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3530 -- Check that an argument has the right form for an EXTERNAL_NAME
3531 -- parameter of an extended import/export pragma. The rule is that the
3532 -- name must be an identifier or string literal (in Ada 83 mode) or a
3533 -- static string expression (in Ada 95 mode).
3535 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3536 -- Check the specified argument Arg to make sure that it is an
3537 -- identifier. If not give error and raise Pragma_Exit.
3539 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3540 -- Check the specified argument Arg to make sure that it is an integer
3541 -- literal. If not give error and raise Pragma_Exit.
3543 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3544 -- Check the specified argument Arg to make sure that it has the proper
3545 -- syntactic form for a local name and meets the semantic requirements
3546 -- for a local name. The local name is analyzed as part of the
3547 -- processing for this call. In addition, the local name is required
3548 -- to represent an entity at the library level.
3550 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3551 -- Check the specified argument Arg to make sure that it has the proper
3552 -- syntactic form for a local name and meets the semantic requirements
3553 -- for a local name. The local name is analyzed as part of the
3554 -- processing for this call.
3556 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3557 -- Check the specified argument Arg to make sure that it is a valid
3558 -- locking policy name. If not give error and raise Pragma_Exit.
3560 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3561 -- Check the specified argument Arg to make sure that it is a valid
3562 -- elaboration policy name. If not give error and raise Pragma_Exit.
3564 procedure Check_Arg_Is_One_Of
3567 procedure Check_Arg_Is_One_Of
3569 N1, N2, N3 : Name_Id);
3570 procedure Check_Arg_Is_One_Of
3572 N1, N2, N3, N4 : Name_Id);
3573 procedure Check_Arg_Is_One_Of
3575 N1, N2, N3, N4, N5 : Name_Id);
3576 -- Check the specified argument Arg to make sure that it is an
3577 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3578 -- present). If not then give error and raise Pragma_Exit.
3580 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3581 -- Check the specified argument Arg to make sure that it is a valid
3582 -- queuing policy name. If not give error and raise Pragma_Exit.
3584 procedure Check_Arg_Is_OK_Static_Expression
3586 Typ : Entity_Id := Empty);
3587 -- Check the specified argument Arg to make sure that it is a static
3588 -- expression of the given type (i.e. it will be analyzed and resolved
3589 -- using this type, which can be any valid argument to Resolve, e.g.
3590 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3591 -- Typ is left Empty, then any static expression is allowed. Includes
3592 -- checking that the argument does not raise Constraint_Error.
3594 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3595 -- Check the specified argument Arg to make sure that it is a valid task
3596 -- dispatching policy name. If not give error and raise Pragma_Exit.
3598 procedure Check_Arg_Order (Names : Name_List);
3599 -- Checks for an instance of two arguments with identifiers for the
3600 -- current pragma which are not in the sequence indicated by Names,
3601 -- and if so, generates a fatal message about bad order of arguments.
3603 procedure Check_At_Least_N_Arguments (N : Nat);
3604 -- Check there are at least N arguments present
3606 procedure Check_At_Most_N_Arguments (N : Nat);
3607 -- Check there are no more than N arguments present
3609 procedure Check_Component
3612 In_Variant_Part : Boolean := False);
3613 -- Examine an Unchecked_Union component for correct use of per-object
3614 -- constrained subtypes, and for restrictions on finalizable components.
3615 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3616 -- should be set when Comp comes from a record variant.
3618 procedure Check_Duplicate_Pragma (E : Entity_Id);
3619 -- Check if a rep item of the same name as the current pragma is already
3620 -- chained as a rep pragma to the given entity. If so give a message
3621 -- about the duplicate, and then raise Pragma_Exit so does not return.
3622 -- Note that if E is a type, then this routine avoids flagging a pragma
3623 -- which applies to a parent type from which E is derived.
3625 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3626 -- Nam is an N_String_Literal node containing the external name set by
3627 -- an Import or Export pragma (or extended Import or Export pragma).
3628 -- This procedure checks for possible duplications if this is the export
3629 -- case, and if found, issues an appropriate error message.
3631 procedure Check_Expr_Is_OK_Static_Expression
3633 Typ : Entity_Id := Empty);
3634 -- Check the specified expression Expr to make sure that it is a static
3635 -- expression of the given type (i.e. it will be analyzed and resolved
3636 -- using this type, which can be any valid argument to Resolve, e.g.
3637 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3638 -- Typ is left Empty, then any static expression is allowed. Includes
3639 -- checking that the expression does not raise Constraint_Error.
3641 procedure Check_First_Subtype (Arg : Node_Id);
3642 -- Checks that Arg, whose expression is an entity name, references a
3645 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3646 -- Checks that the given argument has an identifier, and if so, requires
3647 -- it to match the given identifier name. If there is no identifier, or
3648 -- a non-matching identifier, then an error message is given and
3649 -- Pragma_Exit is raised.
3651 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3652 -- Checks that the given argument has an identifier, and if so, requires
3653 -- it to match one of the given identifier names. If there is no
3654 -- identifier, or a non-matching identifier, then an error message is
3655 -- given and Pragma_Exit is raised.
3657 procedure Check_In_Main_Program;
3658 -- Common checks for pragmas that appear within a main program
3659 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3661 procedure Check_Interrupt_Or_Attach_Handler;
3662 -- Common processing for first argument of pragma Interrupt_Handler or
3663 -- pragma Attach_Handler.
3665 procedure Check_Loop_Pragma_Placement;
3666 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3667 -- appear immediately within a construct restricted to loops, and that
3668 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3670 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3671 -- Check that pragma appears in a declarative part, or in a package
3672 -- specification, i.e. that it does not occur in a statement sequence
3675 procedure Check_No_Identifier (Arg : Node_Id);
3676 -- Checks that the given argument does not have an identifier. If
3677 -- an identifier is present, then an error message is issued, and
3678 -- Pragma_Exit is raised.
3680 procedure Check_No_Identifiers;
3681 -- Checks that none of the arguments to the pragma has an identifier.
3682 -- If any argument has an identifier, then an error message is issued,
3683 -- and Pragma_Exit is raised.
3685 procedure Check_No_Link_Name;
3686 -- Checks that no link name is specified
3688 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3689 -- Checks if the given argument has an identifier, and if so, requires
3690 -- it to match the given identifier name. If there is a non-matching
3691 -- identifier, then an error message is given and Pragma_Exit is raised.
3693 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3694 -- Checks if the given argument has an identifier, and if so, requires
3695 -- it to match the given identifier name. If there is a non-matching
3696 -- identifier, then an error message is given and Pragma_Exit is raised.
3697 -- In this version of the procedure, the identifier name is given as
3698 -- a string with lower case letters.
3700 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3701 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3702 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3703 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3704 -- is an OK static boolean expression. Emit an error if this is not the
3707 procedure Check_Static_Constraint (Constr : Node_Id);
3708 -- Constr is a constraint from an N_Subtype_Indication node from a
3709 -- component constraint in an Unchecked_Union type. This routine checks
3710 -- that the constraint is static as required by the restrictions for
3713 procedure Check_Valid_Configuration_Pragma;
3714 -- Legality checks for placement of a configuration pragma
3716 procedure Check_Valid_Library_Unit_Pragma;
3717 -- Legality checks for library unit pragmas. A special case arises for
3718 -- pragmas in generic instances that come from copies of the original
3719 -- library unit pragmas in the generic templates. In the case of other
3720 -- than library level instantiations these can appear in contexts which
3721 -- would normally be invalid (they only apply to the original template
3722 -- and to library level instantiations), and they are simply ignored,
3723 -- which is implemented by rewriting them as null statements.
3725 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3726 -- Check an Unchecked_Union variant for lack of nested variants and
3727 -- presence of at least one component. UU_Typ is the related Unchecked_
3730 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3731 -- Subsidiary routine to the processing of pragmas Abstract_State,
3732 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3733 -- Refined_Global and Refined_State. Transform argument Arg into
3734 -- an aggregate if not one already. N_Null is never transformed.
3735 -- Arg may denote an aspect specification or a pragma argument
3738 procedure Error_Pragma (Msg : String);
3739 pragma No_Return (Error_Pragma);
3740 -- Outputs error message for current pragma. The message contains a %
3741 -- that will be replaced with the pragma name, and the flag is placed
3742 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3743 -- calls Fix_Error (see spec of that procedure for details).
3745 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3746 pragma No_Return (Error_Pragma_Arg);
3747 -- Outputs error message for current pragma. The message may contain
3748 -- a % that will be replaced with the pragma name. The parameter Arg
3749 -- may either be a pragma argument association, in which case the flag
3750 -- is placed on the expression of this association, or an expression,
3751 -- in which case the flag is placed directly on the expression. The
3752 -- message is placed using Error_Msg_N, so the message may also contain
3753 -- an & insertion character which will reference the given Arg value.
3754 -- After placing the message, Pragma_Exit is raised. Note: this routine
3755 -- calls Fix_Error (see spec of that procedure for details).
3757 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3758 pragma No_Return (Error_Pragma_Arg);
3759 -- Similar to above form of Error_Pragma_Arg except that two messages
3760 -- are provided, the second is a continuation comment starting with \.
3762 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3763 pragma No_Return (Error_Pragma_Arg_Ident);
3764 -- Outputs error message for current pragma. The message may contain a %
3765 -- that will be replaced with the pragma name. The parameter Arg must be
3766 -- a pragma argument association with a non-empty identifier (i.e. its
3767 -- Chars field must be set), and the error message is placed on the
3768 -- identifier. The message is placed using Error_Msg_N so the message
3769 -- may also contain an & insertion character which will reference
3770 -- the identifier. After placing the message, Pragma_Exit is raised.
3771 -- Note: this routine calls Fix_Error (see spec of that procedure for
3774 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3775 pragma No_Return (Error_Pragma_Ref);
3776 -- Outputs error message for current pragma. The message may contain
3777 -- a % that will be replaced with the pragma name. The parameter Ref
3778 -- must be an entity whose name can be referenced by & and sloc by #.
3779 -- After placing the message, Pragma_Exit is raised. Note: this routine
3780 -- calls Fix_Error (see spec of that procedure for details).
3782 function Find_Lib_Unit_Name return Entity_Id;
3783 -- Used for a library unit pragma to find the entity to which the
3784 -- library unit pragma applies, returns the entity found.
3786 procedure Find_Program_Unit_Name (Id : Node_Id);
3787 -- If the pragma is a compilation unit pragma, the id must denote the
3788 -- compilation unit in the same compilation, and the pragma must appear
3789 -- in the list of preceding or trailing pragmas. If it is a program
3790 -- unit pragma that is not a compilation unit pragma, then the
3791 -- identifier must be visible.
3793 function Find_Unique_Parameterless_Procedure
3795 Arg : Node_Id) return Entity_Id;
3796 -- Used for a procedure pragma to find the unique parameterless
3797 -- procedure identified by Name, returns it if it exists, otherwise
3798 -- errors out and uses Arg as the pragma argument for the message.
3800 function Fix_Error (Msg : String) return String;
3801 -- This is called prior to issuing an error message. Msg is the normal
3802 -- error message issued in the pragma case. This routine checks for the
3803 -- case of a pragma coming from an aspect in the source, and returns a
3804 -- message suitable for the aspect case as follows:
3806 -- Each substring "pragma" is replaced by "aspect"
3808 -- If "argument of" is at the start of the error message text, it is
3809 -- replaced by "entity for".
3811 -- If "argument" is at the start of the error message text, it is
3812 -- replaced by "entity".
3814 -- So for example, "argument of pragma X must be discrete type"
3815 -- returns "entity for aspect X must be a discrete type".
3817 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3818 -- be different from the pragma name). If the current pragma results
3819 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3820 -- original pragma name.
3822 procedure Gather_Associations
3824 Args : out Args_List);
3825 -- This procedure is used to gather the arguments for a pragma that
3826 -- permits arbitrary ordering of parameters using the normal rules
3827 -- for named and positional parameters. The Names argument is a list
3828 -- of Name_Id values that corresponds to the allowed pragma argument
3829 -- association identifiers in order. The result returned in Args is
3830 -- a list of corresponding expressions that are the pragma arguments.
3831 -- Note that this is a list of expressions, not of pragma argument
3832 -- associations (Gather_Associations has completely checked all the
3833 -- optional identifiers when it returns). An entry in Args is Empty
3834 -- on return if the corresponding argument is not present.
3836 procedure GNAT_Pragma;
3837 -- Called for all GNAT defined pragmas to check the relevant restriction
3838 -- (No_Implementation_Pragmas).
3840 function Is_Before_First_Decl
3841 (Pragma_Node : Node_Id;
3842 Decls : List_Id) return Boolean;
3843 -- Return True if Pragma_Node is before the first declarative item in
3844 -- Decls where Decls is the list of declarative items.
3846 function Is_Configuration_Pragma return Boolean;
3847 -- Determines if the placement of the current pragma is appropriate
3848 -- for a configuration pragma.
3850 function Is_In_Context_Clause return Boolean;
3851 -- Returns True if pragma appears within the context clause of a unit,
3852 -- and False for any other placement (does not generate any messages).
3854 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3855 -- Analyzes the argument, and determines if it is a static string
3856 -- expression, returns True if so, False if non-static or not String.
3857 -- A special case is that a string literal returns True in Ada 83 mode
3858 -- (which has no such thing as static string expressions). Note that
3859 -- the call analyzes its argument, so this cannot be used for the case
3860 -- where an identifier might not be declared.
3862 procedure Pragma_Misplaced;
3863 pragma No_Return (Pragma_Misplaced);
3864 -- Issue fatal error message for misplaced pragma
3866 procedure Process_Atomic_Independent_Shared_Volatile;
3867 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3868 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3869 -- and treated as being identical in effect to pragma Atomic.
3871 procedure Process_Compile_Time_Warning_Or_Error;
3872 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3874 procedure Process_Convention
3875 (C : out Convention_Id;
3876 Ent : out Entity_Id);
3877 -- Common processing for Convention, Interface, Import and Export.
3878 -- Checks first two arguments of pragma, and sets the appropriate
3879 -- convention value in the specified entity or entities. On return
3880 -- C is the convention, Ent is the referenced entity.
3882 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3883 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3884 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3886 procedure Process_Extended_Import_Export_Object_Pragma
3887 (Arg_Internal : Node_Id;
3888 Arg_External : Node_Id;
3889 Arg_Size : Node_Id);
3890 -- Common processing for the pragmas Import/Export_Object. The three
3891 -- arguments correspond to the three named parameters of the pragmas. An
3892 -- argument is empty if the corresponding parameter is not present in
3895 procedure Process_Extended_Import_Export_Internal_Arg
3896 (Arg_Internal : Node_Id := Empty);
3897 -- Common processing for all extended Import and Export pragmas. The
3898 -- argument is the pragma parameter for the Internal argument. If
3899 -- Arg_Internal is empty or inappropriate, an error message is posted.
3900 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3901 -- set to identify the referenced entity.
3903 procedure Process_Extended_Import_Export_Subprogram_Pragma
3904 (Arg_Internal : Node_Id;
3905 Arg_External : Node_Id;
3906 Arg_Parameter_Types : Node_Id;
3907 Arg_Result_Type : Node_Id := Empty;
3908 Arg_Mechanism : Node_Id;
3909 Arg_Result_Mechanism : Node_Id := Empty);
3910 -- Common processing for all extended Import and Export pragmas applying
3911 -- to subprograms. The caller omits any arguments that do not apply to
3912 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3913 -- only in the Import_Function and Export_Function cases). The argument
3914 -- names correspond to the allowed pragma association identifiers.
3916 procedure Process_Generic_List;
3917 -- Common processing for Share_Generic and Inline_Generic
3919 procedure Process_Import_Or_Interface;
3920 -- Common processing for Import or Interface
3922 procedure Process_Import_Predefined_Type;
3923 -- Processing for completing a type with pragma Import. This is used
3924 -- to declare types that match predefined C types, especially for cases
3925 -- without corresponding Ada predefined type.
3927 type Inline_Status is (Suppressed, Disabled, Enabled);
3928 -- Inline status of a subprogram, indicated as follows:
3929 -- Suppressed: inlining is suppressed for the subprogram
3930 -- Disabled: no inlining is requested for the subprogram
3931 -- Enabled: inlining is requested/required for the subprogram
3933 procedure Process_Inline (Status : Inline_Status);
3934 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3935 -- indicates the inline status specified by the pragma.
3937 procedure Process_Interface_Name
3938 (Subprogram_Def : Entity_Id;
3942 -- Given the last two arguments of pragma Import, pragma Export, or
3943 -- pragma Interface_Name, performs validity checks and sets the
3944 -- Interface_Name field of the given subprogram entity to the
3945 -- appropriate external or link name, depending on the arguments given.
3946 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3947 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3948 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3949 -- nor Link_Arg is present, the interface name is set to the default
3950 -- from the subprogram name. In addition, the pragma itself is passed
3951 -- to analyze any expressions in the case the pragma came from an aspect
3954 procedure Process_Interrupt_Or_Attach_Handler;
3955 -- Common processing for Interrupt and Attach_Handler pragmas
3957 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3958 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3959 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3960 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3961 -- is not set in the Restrictions case.
3963 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3964 -- Common processing for Suppress and Unsuppress. The boolean parameter
3965 -- Suppress_Case is True for the Suppress case, and False for the
3968 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3969 -- Subsidiary to the analysis of pragmas Independent[_Components].
3970 -- Record such a pragma N applied to entity E for future checks.
3972 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3973 -- This procedure sets the Is_Exported flag for the given entity,
3974 -- checking that the entity was not previously imported. Arg is
3975 -- the argument that specified the entity. A check is also made
3976 -- for exporting inappropriate entities.
3978 procedure Set_Extended_Import_Export_External_Name
3979 (Internal_Ent : Entity_Id;
3980 Arg_External : Node_Id);
3981 -- Common processing for all extended import export pragmas. The first
3982 -- argument, Internal_Ent, is the internal entity, which has already
3983 -- been checked for validity by the caller. Arg_External is from the
3984 -- Import or Export pragma, and may be null if no External parameter
3985 -- was present. If Arg_External is present and is a non-null string
3986 -- (a null string is treated as the default), then the Interface_Name
3987 -- field of Internal_Ent is set appropriately.
3989 procedure Set_Imported (E : Entity_Id);
3990 -- This procedure sets the Is_Imported flag for the given entity,
3991 -- checking that it is not previously exported or imported.
3993 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3994 -- Mech is a parameter passing mechanism (see Import_Function syntax
3995 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3996 -- has the right form, and if not issues an error message. If the
3997 -- argument has the right form then the Mechanism field of Ent is
3998 -- set appropriately.
4000 procedure Set_Rational_Profile;
4001 -- Activate the set of configuration pragmas and permissions that make
4002 -- up the Rational profile.
4004 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4005 -- Activate the set of configuration pragmas and restrictions that make
4006 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4007 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4008 -- which is used for error messages on any constructs violating the
4011 ----------------------------------
4012 -- Acquire_Warning_Match_String --
4013 ----------------------------------
4015 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4017 String_To_Name_Buffer
4018 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4020 -- Add asterisk at start if not already there
4022 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4023 Name_Buffer (2 .. Name_Len + 1) :=
4024 Name_Buffer (1 .. Name_Len);
4025 Name_Buffer (1) := '*';
4026 Name_Len := Name_Len + 1;
4029 -- Add asterisk at end if not already there
4031 if Name_Buffer (Name_Len) /= '*' then
4032 Name_Len := Name_Len + 1;
4033 Name_Buffer (Name_Len) := '*';
4035 end Acquire_Warning_Match_String;
4037 ---------------------
4038 -- Ada_2005_Pragma --
4039 ---------------------
4041 procedure Ada_2005_Pragma is
4043 if Ada_Version <= Ada_95 then
4044 Check_Restriction (No_Implementation_Pragmas, N);
4046 end Ada_2005_Pragma;
4048 ---------------------
4049 -- Ada_2012_Pragma --
4050 ---------------------
4052 procedure Ada_2012_Pragma is
4054 if Ada_Version <= Ada_2005 then
4055 Check_Restriction (No_Implementation_Pragmas, N);
4057 end Ada_2012_Pragma;
4059 ----------------------------
4060 -- Analyze_Depends_Global --
4061 ----------------------------
4063 procedure Analyze_Depends_Global
4064 (Spec_Id : out Entity_Id;
4065 Subp_Decl : out Node_Id;
4066 Legal : out Boolean)
4069 -- Assume that the pragma is illegal
4076 Check_Arg_Count (1);
4078 -- Ensure the proper placement of the pragma. Depends/Global must be
4079 -- associated with a subprogram declaration or a body that acts as a
4082 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4086 if Nkind (Subp_Decl) = N_Entry_Declaration then
4089 -- Generic subprogram
4091 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4094 -- Object declaration of a single concurrent type
4096 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4101 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4104 -- Subprogram body acts as spec
4106 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4107 and then No (Corresponding_Spec (Subp_Decl))
4111 -- Subprogram body stub acts as spec
4113 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4114 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4118 -- Subprogram declaration
4120 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4125 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4133 -- If we get here, then the pragma is legal
4136 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4138 -- When the related context is an entry, the entry must belong to a
4139 -- protected unit (SPARK RM 6.1.4(6)).
4141 if Is_Entry_Declaration (Spec_Id)
4142 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4147 -- When the related context is an anonymous object created for a
4148 -- simple concurrent type, the type must be a task
4149 -- (SPARK RM 6.1.4(6)).
4151 elsif Is_Single_Concurrent_Object (Spec_Id)
4152 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4158 -- A pragma that applies to a Ghost entity becomes Ghost for the
4159 -- purposes of legality checks and removal of ignored Ghost code.
4161 Mark_Ghost_Pragma (N, Spec_Id);
4162 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4163 end Analyze_Depends_Global;
4165 ------------------------
4166 -- Analyze_If_Present --
4167 ------------------------
4169 procedure Analyze_If_Present (Id : Pragma_Id) is
4173 pragma Assert (Is_List_Member (N));
4175 -- Inspect the declarations or statements following pragma N looking
4176 -- for another pragma whose Id matches the caller's request. If it is
4177 -- available, analyze it.
4180 while Present (Stmt) loop
4181 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4182 Analyze_Pragma (Stmt);
4185 -- The first source declaration or statement immediately following
4186 -- N ends the region where a pragma may appear.
4188 elsif Comes_From_Source (Stmt) then
4194 end Analyze_If_Present;
4196 --------------------------------
4197 -- Analyze_Pre_Post_Condition --
4198 --------------------------------
4200 procedure Analyze_Pre_Post_Condition is
4201 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4202 Subp_Decl : Node_Id;
4203 Subp_Id : Entity_Id;
4205 Duplicates_OK : Boolean := False;
4206 -- Flag set when a pre/postcondition allows multiple pragmas of the
4209 In_Body_OK : Boolean := False;
4210 -- Flag set when a pre/postcondition is allowed to appear on a body
4211 -- even though the subprogram may have a spec.
4213 Is_Pre_Post : Boolean := False;
4214 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4217 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4218 -- Implement rules in AI12-0131: an overriding operation can have
4219 -- a class-wide precondition only if one of its ancestors has an
4220 -- explicit class-wide precondition.
4222 -----------------------------
4223 -- Inherits_Class_Wide_Pre --
4224 -----------------------------
4226 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4227 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4230 Prev : Entity_Id := Overridden_Operation (E);
4233 -- Check ancestors on the overriding operation to examine the
4234 -- preconditions that may apply to them.
4236 while Present (Prev) loop
4237 Cont := Contract (Prev);
4238 if Present (Cont) then
4239 Prag := Pre_Post_Conditions (Cont);
4240 while Present (Prag) loop
4241 if Class_Present (Prag) then
4245 Prag := Next_Pragma (Prag);
4249 -- For a type derived from a generic formal type, the operation
4250 -- inheriting the condition is a renaming, not an overriding of
4251 -- the operation of the formal.
4253 if Is_Generic_Type (Find_Dispatching_Type (Prev)) then
4254 Prev := Alias (Prev);
4256 Prev := Overridden_Operation (Prev);
4260 -- If the controlling type of the subprogram has progenitors, an
4261 -- interface operation implemented by the current operation may
4262 -- have a class-wide precondition.
4264 if Has_Interfaces (Typ) then
4269 Prim_Elmt : Elmt_Id;
4270 Prim_List : Elist_Id;
4273 Collect_Interfaces (Typ, Ints);
4274 Elmt := First_Elmt (Ints);
4276 -- Iterate over the primitive operations of each interface
4278 while Present (Elmt) loop
4279 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4280 Prim_Elmt := First_Elmt (Prim_List);
4281 while Present (Prim_Elmt) loop
4282 Prim := Node (Prim_Elmt);
4283 if Chars (Prim) = Chars (E)
4284 and then Present (Contract (Prim))
4285 and then Class_Present
4286 (Pre_Post_Conditions (Contract (Prim)))
4291 Next_Elmt (Prim_Elmt);
4300 end Inherits_Class_Wide_Pre;
4302 -- Start of processing for Analyze_Pre_Post_Condition
4305 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4306 -- offer uniformity among the various kinds of pre/postconditions by
4307 -- rewriting the pragma identifier. This allows the retrieval of the
4308 -- original pragma name by routine Original_Aspect_Pragma_Name.
4310 if Comes_From_Source (N) then
4311 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4312 Is_Pre_Post := True;
4313 Set_Class_Present (N, Pname = Name_Pre_Class);
4314 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4316 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4317 Is_Pre_Post := True;
4318 Set_Class_Present (N, Pname = Name_Post_Class);
4319 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4323 -- Determine the semantics with respect to duplicates and placement
4324 -- in a body. Pragmas Precondition and Postcondition were introduced
4325 -- before aspects and are not subject to the same aspect-like rules.
4327 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4328 Duplicates_OK := True;
4334 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4335 -- argument without an identifier.
4338 Check_Arg_Count (1);
4339 Check_No_Identifiers;
4341 -- Pragmas Precondition and Postcondition have complex argument
4345 Check_At_Least_N_Arguments (1);
4346 Check_At_Most_N_Arguments (2);
4347 Check_Optional_Identifier (Arg1, Name_Check);
4349 if Present (Arg2) then
4350 Check_Optional_Identifier (Arg2, Name_Message);
4351 Preanalyze_Spec_Expression
4352 (Get_Pragma_Arg (Arg2), Standard_String);
4356 -- For a pragma PPC in the extended main source unit, record enabled
4358 -- ??? nothing checks that the pragma is in the main source unit
4360 if Is_Checked (N) and then not Split_PPC (N) then
4361 Set_SCO_Pragma_Enabled (Loc);
4364 -- Ensure the proper placement of the pragma
4367 Find_Related_Declaration_Or_Body
4368 (N, Do_Checks => not Duplicates_OK);
4370 -- When a pre/postcondition pragma applies to an abstract subprogram,
4371 -- its original form must be an aspect with 'Class.
4373 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4374 if not From_Aspect_Specification (N) then
4376 ("pragma % cannot be applied to abstract subprogram");
4378 elsif not Class_Present (N) then
4380 ("aspect % requires ''Class for abstract subprogram");
4383 -- Entry declaration
4385 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4388 -- Generic subprogram declaration
4390 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4395 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4396 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4400 -- Subprogram body stub
4402 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4403 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4407 -- Subprogram declaration
4409 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4411 -- AI05-0230: When a pre/postcondition pragma applies to a null
4412 -- procedure, its original form must be an aspect with 'Class.
4414 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4415 and then Null_Present (Specification (Subp_Decl))
4416 and then From_Aspect_Specification (N)
4417 and then not Class_Present (N)
4419 Error_Pragma ("aspect % requires ''Class for null procedure");
4422 -- Implement the legality checks mandated by AI12-0131:
4423 -- Pre'Class shall not be specified for an overriding primitive
4424 -- subprogram of a tagged type T unless the Pre'Class aspect is
4425 -- specified for the corresponding primitive subprogram of some
4429 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4432 if Class_Present (N)
4433 and then Pragma_Name (N) = Name_Precondition
4434 and then Present (Overridden_Operation (E))
4435 and then not Inherits_Class_Wide_Pre (E)
4438 ("illegal class-wide precondition on overriding operation",
4439 Corresponding_Aspect (N));
4443 -- Otherwise the placement is illegal
4450 Subp_Id := Defining_Entity (Subp_Decl);
4452 -- A pragma that applies to a Ghost entity becomes Ghost for the
4453 -- purposes of legality checks and removal of ignored Ghost code.
4455 Mark_Ghost_Pragma (N, Subp_Id);
4457 -- Chain the pragma on the contract for further processing by
4458 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4460 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4462 -- Fully analyze the pragma when it appears inside an entry or
4463 -- subprogram body because it cannot benefit from forward references.
4465 if Nkind_In (Subp_Decl, N_Entry_Body,
4467 N_Subprogram_Body_Stub)
4469 -- The legality checks of pragmas Precondition and Postcondition
4470 -- are affected by the SPARK mode in effect and the volatility of
4471 -- the context. Analyze all pragmas in a specific order.
4473 Analyze_If_Present (Pragma_SPARK_Mode);
4474 Analyze_If_Present (Pragma_Volatile_Function);
4475 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4477 end Analyze_Pre_Post_Condition;
4479 -----------------------------------------
4480 -- Analyze_Refined_Depends_Global_Post --
4481 -----------------------------------------
4483 procedure Analyze_Refined_Depends_Global_Post
4484 (Spec_Id : out Entity_Id;
4485 Body_Id : out Entity_Id;
4486 Legal : out Boolean)
4488 Body_Decl : Node_Id;
4489 Spec_Decl : Node_Id;
4492 -- Assume that the pragma is illegal
4499 Check_Arg_Count (1);
4500 Check_No_Identifiers;
4502 -- Verify the placement of the pragma and check for duplicates. The
4503 -- pragma must apply to a subprogram body [stub].
4505 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4509 if Nkind (Body_Decl) = N_Entry_Body then
4514 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4517 -- Subprogram body stub
4519 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4524 elsif Nkind (Body_Decl) = N_Task_Body then
4532 Body_Id := Defining_Entity (Body_Decl);
4533 Spec_Id := Unique_Defining_Entity (Body_Decl);
4535 -- The pragma must apply to the second declaration of a subprogram.
4536 -- In other words, the body [stub] cannot acts as a spec.
4538 if No (Spec_Id) then
4539 Error_Pragma ("pragma % cannot apply to a stand alone body");
4542 -- Catch the case where the subprogram body is a subunit and acts as
4543 -- the third declaration of the subprogram.
4545 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4546 Error_Pragma ("pragma % cannot apply to a subunit");
4550 -- A refined pragma can only apply to the body [stub] of a subprogram
4551 -- declared in the visible part of a package. Retrieve the context of
4552 -- the subprogram declaration.
4554 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4556 -- When dealing with protected entries or protected subprograms, use
4557 -- the enclosing protected type as the proper context.
4559 if Ekind_In (Spec_Id, E_Entry,
4563 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4565 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4568 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4570 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4571 & "subprogram declared in a package specification"));
4575 -- If we get here, then the pragma is legal
4579 -- A pragma that applies to a Ghost entity becomes Ghost for the
4580 -- purposes of legality checks and removal of ignored Ghost code.
4582 Mark_Ghost_Pragma (N, Spec_Id);
4584 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4585 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4587 end Analyze_Refined_Depends_Global_Post;
4589 ----------------------------------
4590 -- Analyze_Unmodified_Or_Unused --
4591 ----------------------------------
4593 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4598 Ghost_Error_Posted : Boolean := False;
4599 -- Flag set when an error concerning the illegal mix of Ghost and
4600 -- non-Ghost variables is emitted.
4602 Ghost_Id : Entity_Id := Empty;
4603 -- The entity of the first Ghost variable encountered while
4604 -- processing the arguments of the pragma.
4608 Check_At_Least_N_Arguments (1);
4610 -- Loop through arguments
4613 while Present (Arg) loop
4614 Check_No_Identifier (Arg);
4616 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4617 -- in fact generate reference, so that the entity will have a
4618 -- reference, which will inhibit any warnings about it not
4619 -- being referenced, and also properly show up in the ali file
4620 -- as a reference. But this reference is recorded before the
4621 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4622 -- generated for this reference.
4624 Check_Arg_Is_Local_Name (Arg);
4625 Arg_Expr := Get_Pragma_Arg (Arg);
4627 if Is_Entity_Name (Arg_Expr) then
4628 Arg_Id := Entity (Arg_Expr);
4630 -- Skip processing the argument if already flagged
4632 if Is_Assignable (Arg_Id)
4633 and then not Has_Pragma_Unmodified (Arg_Id)
4634 and then not Has_Pragma_Unused (Arg_Id)
4636 Set_Has_Pragma_Unmodified (Arg_Id);
4639 Set_Has_Pragma_Unused (Arg_Id);
4642 -- A pragma that applies to a Ghost entity becomes Ghost for
4643 -- the purposes of legality checks and removal of ignored
4646 Mark_Ghost_Pragma (N, Arg_Id);
4648 -- Capture the entity of the first Ghost variable being
4649 -- processed for error detection purposes.
4651 if Is_Ghost_Entity (Arg_Id) then
4652 if No (Ghost_Id) then
4656 -- Otherwise the variable is non-Ghost. It is illegal to mix
4657 -- references to Ghost and non-Ghost entities
4660 elsif Present (Ghost_Id)
4661 and then not Ghost_Error_Posted
4663 Ghost_Error_Posted := True;
4665 Error_Msg_Name_1 := Pname;
4667 ("pragma % cannot mention ghost and non-ghost "
4670 Error_Msg_Sloc := Sloc (Ghost_Id);
4671 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4673 Error_Msg_Sloc := Sloc (Arg_Id);
4674 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4677 -- Warn if already flagged as Unused or Unmodified
4679 elsif Has_Pragma_Unmodified (Arg_Id) then
4680 if Has_Pragma_Unused (Arg_Id) then
4682 ("??pragma Unused already given for &!", Arg_Expr,
4686 ("??pragma Unmodified already given for &!", Arg_Expr,
4690 -- Otherwise the pragma referenced an illegal entity
4694 ("pragma% can only be applied to a variable", Arg_Expr);
4700 end Analyze_Unmodified_Or_Unused;
4702 -----------------------------------
4703 -- Analyze_Unreference_Or_Unused --
4704 -----------------------------------
4706 procedure Analyze_Unreferenced_Or_Unused
4707 (Is_Unused : Boolean := False)
4714 Ghost_Error_Posted : Boolean := False;
4715 -- Flag set when an error concerning the illegal mix of Ghost and
4716 -- non-Ghost names is emitted.
4718 Ghost_Id : Entity_Id := Empty;
4719 -- The entity of the first Ghost name encountered while processing
4720 -- the arguments of the pragma.
4724 Check_At_Least_N_Arguments (1);
4726 -- Check case of appearing within context clause
4728 if not Is_Unused and then Is_In_Context_Clause then
4730 -- The arguments must all be units mentioned in a with clause in
4731 -- the same context clause. Note that Par.Prag already checked
4732 -- that the arguments are either identifiers or selected
4736 while Present (Arg) loop
4737 Citem := First (List_Containing (N));
4738 while Citem /= N loop
4739 Arg_Expr := Get_Pragma_Arg (Arg);
4741 if Nkind (Citem) = N_With_Clause
4742 and then Same_Name (Name (Citem), Arg_Expr)
4744 Set_Has_Pragma_Unreferenced
4747 (Library_Unit (Citem))));
4748 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4757 ("argument of pragma% is not withed unit", Arg);
4763 -- Case of not in list of context items
4767 while Present (Arg) loop
4768 Check_No_Identifier (Arg);
4770 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4771 -- in fact generate reference, so that the entity will have a
4772 -- reference, which will inhibit any warnings about it not
4773 -- being referenced, and also properly show up in the ali file
4774 -- as a reference. But this reference is recorded before the
4775 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4776 -- generated for this reference.
4778 Check_Arg_Is_Local_Name (Arg);
4779 Arg_Expr := Get_Pragma_Arg (Arg);
4781 if Is_Entity_Name (Arg_Expr) then
4782 Arg_Id := Entity (Arg_Expr);
4784 -- Warn if already flagged as Unused or Unreferenced and
4785 -- skip processing the argument.
4787 if Has_Pragma_Unreferenced (Arg_Id) then
4788 if Has_Pragma_Unused (Arg_Id) then
4790 ("??pragma Unused already given for &!", Arg_Expr,
4794 ("??pragma Unreferenced already given for &!",
4798 -- Apply Unreferenced to the entity
4801 -- If the entity is overloaded, the pragma applies to the
4802 -- most recent overloading, as documented. In this case,
4803 -- name resolution does not generate a reference, so it
4804 -- must be done here explicitly.
4806 if Is_Overloaded (Arg_Expr) then
4807 Generate_Reference (Arg_Id, N);
4810 Set_Has_Pragma_Unreferenced (Arg_Id);
4813 Set_Has_Pragma_Unused (Arg_Id);
4816 -- A pragma that applies to a Ghost entity becomes Ghost
4817 -- for the purposes of legality checks and removal of
4818 -- ignored Ghost code.
4820 Mark_Ghost_Pragma (N, Arg_Id);
4822 -- Capture the entity of the first Ghost name being
4823 -- processed for error detection purposes.
4825 if Is_Ghost_Entity (Arg_Id) then
4826 if No (Ghost_Id) then
4830 -- Otherwise the name is non-Ghost. It is illegal to mix
4831 -- references to Ghost and non-Ghost entities
4834 elsif Present (Ghost_Id)
4835 and then not Ghost_Error_Posted
4837 Ghost_Error_Posted := True;
4839 Error_Msg_Name_1 := Pname;
4841 ("pragma % cannot mention ghost and non-ghost "
4844 Error_Msg_Sloc := Sloc (Ghost_Id);
4846 ("\& # declared as ghost", N, Ghost_Id);
4848 Error_Msg_Sloc := Sloc (Arg_Id);
4850 ("\& # declared as non-ghost", N, Arg_Id);
4858 end Analyze_Unreferenced_Or_Unused;
4860 --------------------------
4861 -- Check_Ada_83_Warning --
4862 --------------------------
4864 procedure Check_Ada_83_Warning is
4866 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4867 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4869 end Check_Ada_83_Warning;
4871 ---------------------
4872 -- Check_Arg_Count --
4873 ---------------------
4875 procedure Check_Arg_Count (Required : Nat) is
4877 if Arg_Count /= Required then
4878 Error_Pragma ("wrong number of arguments for pragma%");
4880 end Check_Arg_Count;
4882 --------------------------------
4883 -- Check_Arg_Is_External_Name --
4884 --------------------------------
4886 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4887 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4890 if Nkind (Argx) = N_Identifier then
4894 Analyze_And_Resolve (Argx, Standard_String);
4896 if Is_OK_Static_Expression (Argx) then
4899 elsif Etype (Argx) = Any_Type then
4902 -- An interesting special case, if we have a string literal and
4903 -- we are in Ada 83 mode, then we allow it even though it will
4904 -- not be flagged as static. This allows expected Ada 83 mode
4905 -- use of external names which are string literals, even though
4906 -- technically these are not static in Ada 83.
4908 elsif Ada_Version = Ada_83
4909 and then Nkind (Argx) = N_String_Literal
4913 -- Static expression that raises Constraint_Error. This has
4914 -- already been flagged, so just exit from pragma processing.
4916 elsif Is_OK_Static_Expression (Argx) then
4919 -- Here we have a real error (non-static expression)
4922 Error_Msg_Name_1 := Pname;
4925 Msg : constant String :=
4926 "argument for pragma% must be a identifier or "
4927 & "static string expression!";
4929 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4934 end Check_Arg_Is_External_Name;
4936 -----------------------------
4937 -- Check_Arg_Is_Identifier --
4938 -----------------------------
4940 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4941 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4943 if Nkind (Argx) /= N_Identifier then
4945 ("argument for pragma% must be identifier", Argx);
4947 end Check_Arg_Is_Identifier;
4949 ----------------------------------
4950 -- Check_Arg_Is_Integer_Literal --
4951 ----------------------------------
4953 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4954 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4956 if Nkind (Argx) /= N_Integer_Literal then
4958 ("argument for pragma% must be integer literal", Argx);
4960 end Check_Arg_Is_Integer_Literal;
4962 -------------------------------------------
4963 -- Check_Arg_Is_Library_Level_Local_Name --
4964 -------------------------------------------
4968 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4969 -- | library_unit_NAME
4971 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4973 Check_Arg_Is_Local_Name (Arg);
4975 -- If it came from an aspect, we want to give the error just as if it
4976 -- came from source.
4978 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4979 and then (Comes_From_Source (N)
4980 or else Present (Corresponding_Aspect (Parent (Arg))))
4983 ("argument for pragma% must be library level entity", Arg);
4985 end Check_Arg_Is_Library_Level_Local_Name;
4987 -----------------------------
4988 -- Check_Arg_Is_Local_Name --
4989 -----------------------------
4993 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4994 -- | library_unit_NAME
4996 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4997 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5000 -- If this pragma came from an aspect specification, we don't want to
5001 -- check for this error, because that would cause spurious errors, in
5002 -- case a type is frozen in a scope more nested than the type. The
5003 -- aspect itself of course can't be anywhere but on the declaration
5006 if Nkind (Arg) = N_Pragma_Argument_Association then
5007 if From_Aspect_Specification (Parent (Arg)) then
5011 -- Arg is the Expression of an N_Pragma_Argument_Association
5014 if From_Aspect_Specification (Parent (Parent (Arg))) then
5021 if Nkind (Argx) not in N_Direct_Name
5022 and then (Nkind (Argx) /= N_Attribute_Reference
5023 or else Present (Expressions (Argx))
5024 or else Nkind (Prefix (Argx)) /= N_Identifier)
5025 and then (not Is_Entity_Name (Argx)
5026 or else not Is_Compilation_Unit (Entity (Argx)))
5028 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5031 -- No further check required if not an entity name
5033 if not Is_Entity_Name (Argx) then
5039 Ent : constant Entity_Id := Entity (Argx);
5040 Scop : constant Entity_Id := Scope (Ent);
5043 -- Case of a pragma applied to a compilation unit: pragma must
5044 -- occur immediately after the program unit in the compilation.
5046 if Is_Compilation_Unit (Ent) then
5048 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5051 -- Case of pragma placed immediately after spec
5053 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5056 -- Case of pragma placed immediately after body
5058 elsif Nkind (Decl) = N_Subprogram_Declaration
5059 and then Present (Corresponding_Body (Decl))
5063 (Parent (Unit_Declaration_Node
5064 (Corresponding_Body (Decl))));
5066 -- All other cases are illegal
5073 -- Special restricted placement rule from 10.2.1(11.8/2)
5075 elsif Is_Generic_Formal (Ent)
5076 and then Prag_Id = Pragma_Preelaborable_Initialization
5078 OK := List_Containing (N) =
5079 Generic_Formal_Declarations
5080 (Unit_Declaration_Node (Scop));
5082 -- If this is an aspect applied to a subprogram body, the
5083 -- pragma is inserted in its declarative part.
5085 elsif From_Aspect_Specification (N)
5086 and then Ent = Current_Scope
5088 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5092 -- If the aspect is a predicate (possibly others ???) and the
5093 -- context is a record type, this is a discriminant expression
5094 -- within a type declaration, that freezes the predicated
5097 elsif From_Aspect_Specification (N)
5098 and then Prag_Id = Pragma_Predicate
5099 and then Ekind (Current_Scope) = E_Record_Type
5100 and then Scop = Scope (Current_Scope)
5104 -- Default case, just check that the pragma occurs in the scope
5105 -- of the entity denoted by the name.
5108 OK := Current_Scope = Scop;
5113 ("pragma% argument must be in same declarative part", Arg);
5117 end Check_Arg_Is_Local_Name;
5119 ---------------------------------
5120 -- Check_Arg_Is_Locking_Policy --
5121 ---------------------------------
5123 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5124 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5127 Check_Arg_Is_Identifier (Argx);
5129 if not Is_Locking_Policy_Name (Chars (Argx)) then
5130 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5132 end Check_Arg_Is_Locking_Policy;
5134 -----------------------------------------------
5135 -- Check_Arg_Is_Partition_Elaboration_Policy --
5136 -----------------------------------------------
5138 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5139 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5142 Check_Arg_Is_Identifier (Argx);
5144 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5146 ("& is not a valid partition elaboration policy name", Argx);
5148 end Check_Arg_Is_Partition_Elaboration_Policy;
5150 -------------------------
5151 -- Check_Arg_Is_One_Of --
5152 -------------------------
5154 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5155 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5158 Check_Arg_Is_Identifier (Argx);
5160 if not Nam_In (Chars (Argx), N1, N2) then
5161 Error_Msg_Name_2 := N1;
5162 Error_Msg_Name_3 := N2;
5163 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5165 end Check_Arg_Is_One_Of;
5167 procedure Check_Arg_Is_One_Of
5169 N1, N2, N3 : Name_Id)
5171 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5174 Check_Arg_Is_Identifier (Argx);
5176 if not Nam_In (Chars (Argx), N1, N2, N3) then
5177 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5179 end Check_Arg_Is_One_Of;
5181 procedure Check_Arg_Is_One_Of
5183 N1, N2, N3, N4 : Name_Id)
5185 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5188 Check_Arg_Is_Identifier (Argx);
5190 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5191 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5193 end Check_Arg_Is_One_Of;
5195 procedure Check_Arg_Is_One_Of
5197 N1, N2, N3, N4, N5 : Name_Id)
5199 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5202 Check_Arg_Is_Identifier (Argx);
5204 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5205 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5207 end Check_Arg_Is_One_Of;
5209 ---------------------------------
5210 -- Check_Arg_Is_Queuing_Policy --
5211 ---------------------------------
5213 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5214 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5217 Check_Arg_Is_Identifier (Argx);
5219 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5220 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5222 end Check_Arg_Is_Queuing_Policy;
5224 ---------------------------------------
5225 -- Check_Arg_Is_OK_Static_Expression --
5226 ---------------------------------------
5228 procedure Check_Arg_Is_OK_Static_Expression
5230 Typ : Entity_Id := Empty)
5233 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5234 end Check_Arg_Is_OK_Static_Expression;
5236 ------------------------------------------
5237 -- Check_Arg_Is_Task_Dispatching_Policy --
5238 ------------------------------------------
5240 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5241 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5244 Check_Arg_Is_Identifier (Argx);
5246 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5248 ("& is not an allowed task dispatching policy name", Argx);
5250 end Check_Arg_Is_Task_Dispatching_Policy;
5252 ---------------------
5253 -- Check_Arg_Order --
5254 ---------------------
5256 procedure Check_Arg_Order (Names : Name_List) is
5259 Highest_So_Far : Natural := 0;
5260 -- Highest index in Names seen do far
5264 for J in 1 .. Arg_Count loop
5265 if Chars (Arg) /= No_Name then
5266 for K in Names'Range loop
5267 if Chars (Arg) = Names (K) then
5268 if K < Highest_So_Far then
5269 Error_Msg_Name_1 := Pname;
5271 ("parameters out of order for pragma%", Arg);
5272 Error_Msg_Name_1 := Names (K);
5273 Error_Msg_Name_2 := Names (Highest_So_Far);
5274 Error_Msg_N ("\% must appear before %", Arg);
5278 Highest_So_Far := K;
5286 end Check_Arg_Order;
5288 --------------------------------
5289 -- Check_At_Least_N_Arguments --
5290 --------------------------------
5292 procedure Check_At_Least_N_Arguments (N : Nat) is
5294 if Arg_Count < N then
5295 Error_Pragma ("too few arguments for pragma%");
5297 end Check_At_Least_N_Arguments;
5299 -------------------------------
5300 -- Check_At_Most_N_Arguments --
5301 -------------------------------
5303 procedure Check_At_Most_N_Arguments (N : Nat) is
5306 if Arg_Count > N then
5308 for J in 1 .. N loop
5310 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5313 end Check_At_Most_N_Arguments;
5315 ---------------------
5316 -- Check_Component --
5317 ---------------------
5319 procedure Check_Component
5322 In_Variant_Part : Boolean := False)
5324 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5325 Sindic : constant Node_Id :=
5326 Subtype_Indication (Component_Definition (Comp));
5327 Typ : constant Entity_Id := Etype (Comp_Id);
5330 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5331 -- object constraint, then the component type shall be an Unchecked_
5334 if Nkind (Sindic) = N_Subtype_Indication
5335 and then Has_Per_Object_Constraint (Comp_Id)
5336 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5339 ("component subtype subject to per-object constraint "
5340 & "must be an Unchecked_Union", Comp);
5342 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5343 -- the body of a generic unit, or within the body of any of its
5344 -- descendant library units, no part of the type of a component
5345 -- declared in a variant_part of the unchecked union type shall be of
5346 -- a formal private type or formal private extension declared within
5347 -- the formal part of the generic unit.
5349 elsif Ada_Version >= Ada_2012
5350 and then In_Generic_Body (UU_Typ)
5351 and then In_Variant_Part
5352 and then Is_Private_Type (Typ)
5353 and then Is_Generic_Type (Typ)
5356 ("component of unchecked union cannot be of generic type", Comp);
5358 elsif Needs_Finalization (Typ) then
5360 ("component of unchecked union cannot be controlled", Comp);
5362 elsif Has_Task (Typ) then
5364 ("component of unchecked union cannot have tasks", Comp);
5366 end Check_Component;
5368 ----------------------------
5369 -- Check_Duplicate_Pragma --
5370 ----------------------------
5372 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5373 Id : Entity_Id := E;
5377 -- Nothing to do if this pragma comes from an aspect specification,
5378 -- since we could not be duplicating a pragma, and we dealt with the
5379 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5381 if From_Aspect_Specification (N) then
5385 -- Otherwise current pragma may duplicate previous pragma or a
5386 -- previously given aspect specification or attribute definition
5387 -- clause for the same pragma.
5389 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5393 -- If the entity is a type, then we have to make sure that the
5394 -- ostensible duplicate is not for a parent type from which this
5398 if Nkind (P) = N_Pragma then
5400 Args : constant List_Id :=
5401 Pragma_Argument_Associations (P);
5404 and then Is_Entity_Name (Expression (First (Args)))
5405 and then Is_Type (Entity (Expression (First (Args))))
5406 and then Entity (Expression (First (Args))) /= E
5412 elsif Nkind (P) = N_Aspect_Specification
5413 and then Is_Type (Entity (P))
5414 and then Entity (P) /= E
5420 -- Here we have a definite duplicate
5422 Error_Msg_Name_1 := Pragma_Name (N);
5423 Error_Msg_Sloc := Sloc (P);
5425 -- For a single protected or a single task object, the error is
5426 -- issued on the original entity.
5428 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5429 Id := Defining_Identifier (Original_Node (Parent (Id)));
5432 if Nkind (P) = N_Aspect_Specification
5433 or else From_Aspect_Specification (P)
5435 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5437 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5442 end Check_Duplicate_Pragma;
5444 ----------------------------------
5445 -- Check_Duplicated_Export_Name --
5446 ----------------------------------
5448 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5449 String_Val : constant String_Id := Strval (Nam);
5452 -- We are only interested in the export case, and in the case of
5453 -- generics, it is the instance, not the template, that is the
5454 -- problem (the template will generate a warning in any case).
5456 if not Inside_A_Generic
5457 and then (Prag_Id = Pragma_Export
5459 Prag_Id = Pragma_Export_Procedure
5461 Prag_Id = Pragma_Export_Valued_Procedure
5463 Prag_Id = Pragma_Export_Function)
5465 for J in Externals.First .. Externals.Last loop
5466 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5467 Error_Msg_Sloc := Sloc (Externals.Table (J));
5468 Error_Msg_N ("external name duplicates name given#", Nam);
5473 Externals.Append (Nam);
5475 end Check_Duplicated_Export_Name;
5477 ----------------------------------------
5478 -- Check_Expr_Is_OK_Static_Expression --
5479 ----------------------------------------
5481 procedure Check_Expr_Is_OK_Static_Expression
5483 Typ : Entity_Id := Empty)
5486 if Present (Typ) then
5487 Analyze_And_Resolve (Expr, Typ);
5489 Analyze_And_Resolve (Expr);
5492 -- An expression cannot be considered static if its resolution failed
5493 -- or if it's erroneous. Stop the analysis of the related pragma.
5495 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5498 elsif Is_OK_Static_Expression (Expr) then
5501 -- An interesting special case, if we have a string literal and we
5502 -- are in Ada 83 mode, then we allow it even though it will not be
5503 -- flagged as static. This allows the use of Ada 95 pragmas like
5504 -- Import in Ada 83 mode. They will of course be flagged with
5505 -- warnings as usual, but will not cause errors.
5507 elsif Ada_Version = Ada_83
5508 and then Nkind (Expr) = N_String_Literal
5512 -- Finally, we have a real error
5515 Error_Msg_Name_1 := Pname;
5516 Flag_Non_Static_Expr
5517 (Fix_Error ("argument for pragma% must be a static expression!"),
5521 end Check_Expr_Is_OK_Static_Expression;
5523 -------------------------
5524 -- Check_First_Subtype --
5525 -------------------------
5527 procedure Check_First_Subtype (Arg : Node_Id) is
5528 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5529 Ent : constant Entity_Id := Entity (Argx);
5532 if Is_First_Subtype (Ent) then
5535 elsif Is_Type (Ent) then
5537 ("pragma% cannot apply to subtype", Argx);
5539 elsif Is_Object (Ent) then
5541 ("pragma% cannot apply to object, requires a type", Argx);
5545 ("pragma% cannot apply to&, requires a type", Argx);
5547 end Check_First_Subtype;
5549 ----------------------
5550 -- Check_Identifier --
5551 ----------------------
5553 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5556 and then Nkind (Arg) = N_Pragma_Argument_Association
5558 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5559 Error_Msg_Name_1 := Pname;
5560 Error_Msg_Name_2 := Id;
5561 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5565 end Check_Identifier;
5567 --------------------------------
5568 -- Check_Identifier_Is_One_Of --
5569 --------------------------------
5571 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5574 and then Nkind (Arg) = N_Pragma_Argument_Association
5576 if Chars (Arg) = No_Name then
5577 Error_Msg_Name_1 := Pname;
5578 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5581 elsif Chars (Arg) /= N1
5582 and then Chars (Arg) /= N2
5584 Error_Msg_Name_1 := Pname;
5585 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5589 end Check_Identifier_Is_One_Of;
5591 ---------------------------
5592 -- Check_In_Main_Program --
5593 ---------------------------
5595 procedure Check_In_Main_Program is
5596 P : constant Node_Id := Parent (N);
5599 -- Must be in subprogram body
5601 if Nkind (P) /= N_Subprogram_Body then
5602 Error_Pragma ("% pragma allowed only in subprogram");
5604 -- Otherwise warn if obviously not main program
5606 elsif Present (Parameter_Specifications (Specification (P)))
5607 or else not Is_Compilation_Unit (Defining_Entity (P))
5609 Error_Msg_Name_1 := Pname;
5611 ("??pragma% is only effective in main program", N);
5613 end Check_In_Main_Program;
5615 ---------------------------------------
5616 -- Check_Interrupt_Or_Attach_Handler --
5617 ---------------------------------------
5619 procedure Check_Interrupt_Or_Attach_Handler is
5620 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5621 Handler_Proc, Proc_Scope : Entity_Id;
5626 if Prag_Id = Pragma_Interrupt_Handler then
5627 Check_Restriction (No_Dynamic_Attachment, N);
5630 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5631 Proc_Scope := Scope (Handler_Proc);
5633 if Ekind (Proc_Scope) /= E_Protected_Type then
5635 ("argument of pragma% must be protected procedure", Arg1);
5638 -- For pragma case (as opposed to access case), check placement.
5639 -- We don't need to do that for aspects, because we have the
5640 -- check that they aspect applies an appropriate procedure.
5642 if not From_Aspect_Specification (N)
5643 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5645 Error_Pragma ("pragma% must be in protected definition");
5648 if not Is_Library_Level_Entity (Proc_Scope) then
5650 ("argument for pragma% must be library level entity", Arg1);
5653 -- AI05-0033: A pragma cannot appear within a generic body, because
5654 -- instance can be in a nested scope. The check that protected type
5655 -- is itself a library-level declaration is done elsewhere.
5657 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5658 -- handle code prior to AI-0033. Analysis tools typically are not
5659 -- interested in this pragma in any case, so no need to worry too
5660 -- much about its placement.
5662 if Inside_A_Generic then
5663 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5664 and then In_Package_Body (Scope (Current_Scope))
5665 and then not Relaxed_RM_Semantics
5667 Error_Pragma ("pragma% cannot be used inside a generic");
5670 end Check_Interrupt_Or_Attach_Handler;
5672 ---------------------------------
5673 -- Check_Loop_Pragma_Placement --
5674 ---------------------------------
5676 procedure Check_Loop_Pragma_Placement is
5677 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5678 -- Verify whether the current pragma is properly grouped with other
5679 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5680 -- related loop where the pragma appears.
5682 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5683 -- Determine whether an arbitrary statement Stmt denotes pragma
5684 -- Loop_Invariant or Loop_Variant.
5686 procedure Placement_Error (Constr : Node_Id);
5687 pragma No_Return (Placement_Error);
5688 -- Node Constr denotes the last loop restricted construct before we
5689 -- encountered an illegal relation between enclosing constructs. Emit
5690 -- an error depending on what Constr was.
5692 --------------------------------
5693 -- Check_Loop_Pragma_Grouping --
5694 --------------------------------
5696 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5697 Stop_Search : exception;
5698 -- This exception is used to terminate the recursive descent of
5699 -- routine Check_Grouping.
5701 procedure Check_Grouping (L : List_Id);
5702 -- Find the first group of pragmas in list L and if successful,
5703 -- ensure that the current pragma is part of that group. The
5704 -- routine raises Stop_Search once such a check is performed to
5705 -- halt the recursive descent.
5707 procedure Grouping_Error (Prag : Node_Id);
5708 pragma No_Return (Grouping_Error);
5709 -- Emit an error concerning the current pragma indicating that it
5710 -- should be placed after pragma Prag.
5712 --------------------
5713 -- Check_Grouping --
5714 --------------------
5716 procedure Check_Grouping (L : List_Id) is
5722 -- Inspect the list of declarations or statements looking for
5723 -- the first grouping of pragmas:
5726 -- pragma Loop_Invariant ...;
5727 -- pragma Loop_Variant ...;
5729 -- pragma Loop_Variant ...; -- current pragma
5731 -- If the current pragma is not in the grouping, then it must
5732 -- either appear in a different declarative or statement list
5733 -- or the construct at (1) is separating the pragma from the
5737 while Present (Stmt) loop
5739 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5740 -- inside a loop or a block housed inside a loop. Inspect
5741 -- the declarations and statements of the block as they may
5742 -- contain the first grouping.
5744 if Nkind (Stmt) = N_Block_Statement then
5745 HSS := Handled_Statement_Sequence (Stmt);
5747 Check_Grouping (Declarations (Stmt));
5749 if Present (HSS) then
5750 Check_Grouping (Statements (HSS));
5753 -- First pragma of the first topmost grouping has been found
5755 elsif Is_Loop_Pragma (Stmt) then
5757 -- The group and the current pragma are not in the same
5758 -- declarative or statement list.
5760 if List_Containing (Stmt) /= List_Containing (N) then
5761 Grouping_Error (Stmt);
5763 -- Try to reach the current pragma from the first pragma
5764 -- of the grouping while skipping other members:
5766 -- pragma Loop_Invariant ...; -- first pragma
5767 -- pragma Loop_Variant ...; -- member
5769 -- pragma Loop_Variant ...; -- current pragma
5772 while Present (Stmt) loop
5774 -- The current pragma is either the first pragma
5775 -- of the group or is a member of the group. Stop
5776 -- the search as the placement is legal.
5781 -- Skip group members, but keep track of the last
5782 -- pragma in the group.
5784 elsif Is_Loop_Pragma (Stmt) then
5787 -- Skip declarations and statements generated by
5788 -- the compiler during expansion.
5790 elsif not Comes_From_Source (Stmt) then
5793 -- A non-pragma is separating the group from the
5794 -- current pragma, the placement is illegal.
5797 Grouping_Error (Prag);
5803 -- If the traversal did not reach the current pragma,
5804 -- then the list must be malformed.
5806 raise Program_Error;
5814 --------------------
5815 -- Grouping_Error --
5816 --------------------
5818 procedure Grouping_Error (Prag : Node_Id) is
5820 Error_Msg_Sloc := Sloc (Prag);
5821 Error_Pragma ("pragma% must appear next to pragma#");
5824 -- Start of processing for Check_Loop_Pragma_Grouping
5827 -- Inspect the statements of the loop or nested blocks housed
5828 -- within to determine whether the current pragma is part of the
5829 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5831 Check_Grouping (Statements (Loop_Stmt));
5834 when Stop_Search => null;
5835 end Check_Loop_Pragma_Grouping;
5837 --------------------
5838 -- Is_Loop_Pragma --
5839 --------------------
5841 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5843 -- Inspect the original node as Loop_Invariant and Loop_Variant
5844 -- pragmas are rewritten to null when assertions are disabled.
5846 if Nkind (Original_Node (Stmt)) = N_Pragma then
5848 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
5849 Name_Loop_Invariant,
5856 ---------------------
5857 -- Placement_Error --
5858 ---------------------
5860 procedure Placement_Error (Constr : Node_Id) is
5861 LA : constant String := " with Loop_Entry";
5864 if Prag_Id = Pragma_Assert then
5865 Error_Msg_String (1 .. LA'Length) := LA;
5866 Error_Msg_Strlen := LA'Length;
5868 Error_Msg_Strlen := 0;
5871 if Nkind (Constr) = N_Pragma then
5873 ("pragma %~ must appear immediately within the statements "
5877 ("block containing pragma %~ must appear immediately within "
5878 & "the statements of a loop", Constr);
5880 end Placement_Error;
5882 -- Local declarations
5887 -- Start of processing for Check_Loop_Pragma_Placement
5890 -- Check that pragma appears immediately within a loop statement,
5891 -- ignoring intervening block statements.
5895 while Present (Stmt) loop
5897 -- The pragma or previous block must appear immediately within the
5898 -- current block's declarative or statement part.
5900 if Nkind (Stmt) = N_Block_Statement then
5901 if (No (Declarations (Stmt))
5902 or else List_Containing (Prev) /= Declarations (Stmt))
5904 List_Containing (Prev) /=
5905 Statements (Handled_Statement_Sequence (Stmt))
5907 Placement_Error (Prev);
5910 -- Keep inspecting the parents because we are now within a
5911 -- chain of nested blocks.
5915 Stmt := Parent (Stmt);
5918 -- The pragma or previous block must appear immediately within the
5919 -- statements of the loop.
5921 elsif Nkind (Stmt) = N_Loop_Statement then
5922 if List_Containing (Prev) /= Statements (Stmt) then
5923 Placement_Error (Prev);
5926 -- Stop the traversal because we reached the innermost loop
5927 -- regardless of whether we encountered an error or not.
5931 -- Ignore a handled statement sequence. Note that this node may
5932 -- be related to a subprogram body in which case we will emit an
5933 -- error on the next iteration of the search.
5935 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5936 Stmt := Parent (Stmt);
5938 -- Any other statement breaks the chain from the pragma to the
5942 Placement_Error (Prev);
5947 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5948 -- grouped together with other such pragmas.
5950 if Is_Loop_Pragma (N) then
5952 -- The previous check should have located the related loop
5954 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5955 Check_Loop_Pragma_Grouping (Stmt);
5957 end Check_Loop_Pragma_Placement;
5959 -------------------------------------------
5960 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5961 -------------------------------------------
5963 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5972 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5975 elsif Nkind_In (P, N_Package_Specification,
5980 -- Note: the following tests seem a little peculiar, because
5981 -- they test for bodies, but if we were in the statement part
5982 -- of the body, we would already have hit the handled statement
5983 -- sequence, so the only way we get here is by being in the
5984 -- declarative part of the body.
5986 elsif Nkind_In (P, N_Subprogram_Body,
5997 Error_Pragma ("pragma% is not in declarative part or package spec");
5998 end Check_Is_In_Decl_Part_Or_Package_Spec;
6000 -------------------------
6001 -- Check_No_Identifier --
6002 -------------------------
6004 procedure Check_No_Identifier (Arg : Node_Id) is
6006 if Nkind (Arg) = N_Pragma_Argument_Association
6007 and then Chars (Arg) /= No_Name
6009 Error_Pragma_Arg_Ident
6010 ("pragma% does not permit identifier& here", Arg);
6012 end Check_No_Identifier;
6014 --------------------------
6015 -- Check_No_Identifiers --
6016 --------------------------
6018 procedure Check_No_Identifiers is
6022 for J in 1 .. Arg_Count loop
6023 Check_No_Identifier (Arg_Node);
6026 end Check_No_Identifiers;
6028 ------------------------
6029 -- Check_No_Link_Name --
6030 ------------------------
6032 procedure Check_No_Link_Name is
6034 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6038 if Present (Arg4) then
6040 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6042 end Check_No_Link_Name;
6044 -------------------------------
6045 -- Check_Optional_Identifier --
6046 -------------------------------
6048 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6051 and then Nkind (Arg) = N_Pragma_Argument_Association
6052 and then Chars (Arg) /= No_Name
6054 if Chars (Arg) /= Id then
6055 Error_Msg_Name_1 := Pname;
6056 Error_Msg_Name_2 := Id;
6057 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6061 end Check_Optional_Identifier;
6063 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6065 Check_Optional_Identifier (Arg, Name_Find (Id));
6066 end Check_Optional_Identifier;
6068 -------------------------------------
6069 -- Check_Static_Boolean_Expression --
6070 -------------------------------------
6072 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6074 if Present (Expr) then
6075 Analyze_And_Resolve (Expr, Standard_Boolean);
6077 if not Is_OK_Static_Expression (Expr) then
6079 ("expression of pragma % must be static", Expr);
6082 end Check_Static_Boolean_Expression;
6084 -----------------------------
6085 -- Check_Static_Constraint --
6086 -----------------------------
6088 -- Note: for convenience in writing this procedure, in addition to
6089 -- the officially (i.e. by spec) allowed argument which is always a
6090 -- constraint, it also allows ranges and discriminant associations.
6091 -- Above is not clear ???
6093 procedure Check_Static_Constraint (Constr : Node_Id) is
6095 procedure Require_Static (E : Node_Id);
6096 -- Require given expression to be static expression
6098 --------------------
6099 -- Require_Static --
6100 --------------------
6102 procedure Require_Static (E : Node_Id) is
6104 if not Is_OK_Static_Expression (E) then
6105 Flag_Non_Static_Expr
6106 ("non-static constraint not allowed in Unchecked_Union!", E);
6111 -- Start of processing for Check_Static_Constraint
6114 case Nkind (Constr) is
6115 when N_Discriminant_Association =>
6116 Require_Static (Expression (Constr));
6119 Require_Static (Low_Bound (Constr));
6120 Require_Static (High_Bound (Constr));
6122 when N_Attribute_Reference =>
6123 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6124 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6126 when N_Range_Constraint =>
6127 Check_Static_Constraint (Range_Expression (Constr));
6129 when N_Index_Or_Discriminant_Constraint =>
6133 IDC := First (Constraints (Constr));
6134 while Present (IDC) loop
6135 Check_Static_Constraint (IDC);
6143 end Check_Static_Constraint;
6145 --------------------------------------
6146 -- Check_Valid_Configuration_Pragma --
6147 --------------------------------------
6149 -- A configuration pragma must appear in the context clause of a
6150 -- compilation unit, and only other pragmas may precede it. Note that
6151 -- the test also allows use in a configuration pragma file.
6153 procedure Check_Valid_Configuration_Pragma is
6155 if not Is_Configuration_Pragma then
6156 Error_Pragma ("incorrect placement for configuration pragma%");
6158 end Check_Valid_Configuration_Pragma;
6160 -------------------------------------
6161 -- Check_Valid_Library_Unit_Pragma --
6162 -------------------------------------
6164 procedure Check_Valid_Library_Unit_Pragma is
6166 Parent_Node : Node_Id;
6167 Unit_Name : Entity_Id;
6168 Unit_Kind : Node_Kind;
6169 Unit_Node : Node_Id;
6170 Sindex : Source_File_Index;
6173 if not Is_List_Member (N) then
6177 Plist := List_Containing (N);
6178 Parent_Node := Parent (Plist);
6180 if Parent_Node = Empty then
6183 -- Case of pragma appearing after a compilation unit. In this case
6184 -- it must have an argument with the corresponding name and must
6185 -- be part of the following pragmas of its parent.
6187 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6188 if Plist /= Pragmas_After (Parent_Node) then
6191 elsif Arg_Count = 0 then
6193 ("argument required if outside compilation unit");
6196 Check_No_Identifiers;
6197 Check_Arg_Count (1);
6198 Unit_Node := Unit (Parent (Parent_Node));
6199 Unit_Kind := Nkind (Unit_Node);
6201 Analyze (Get_Pragma_Arg (Arg1));
6203 if Unit_Kind = N_Generic_Subprogram_Declaration
6204 or else Unit_Kind = N_Subprogram_Declaration
6206 Unit_Name := Defining_Entity (Unit_Node);
6208 elsif Unit_Kind in N_Generic_Instantiation then
6209 Unit_Name := Defining_Entity (Unit_Node);
6212 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6215 if Chars (Unit_Name) /=
6216 Chars (Entity (Get_Pragma_Arg (Arg1)))
6219 ("pragma% argument is not current unit name", Arg1);
6222 if Ekind (Unit_Name) = E_Package
6223 and then Present (Renamed_Entity (Unit_Name))
6225 Error_Pragma ("pragma% not allowed for renamed package");
6229 -- Pragma appears other than after a compilation unit
6232 -- Here we check for the generic instantiation case and also
6233 -- for the case of processing a generic formal package. We
6234 -- detect these cases by noting that the Sloc on the node
6235 -- does not belong to the current compilation unit.
6237 Sindex := Source_Index (Current_Sem_Unit);
6239 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6240 Rewrite (N, Make_Null_Statement (Loc));
6243 -- If before first declaration, the pragma applies to the
6244 -- enclosing unit, and the name if present must be this name.
6246 elsif Is_Before_First_Decl (N, Plist) then
6247 Unit_Node := Unit_Declaration_Node (Current_Scope);
6248 Unit_Kind := Nkind (Unit_Node);
6250 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6253 elsif Unit_Kind = N_Subprogram_Body
6254 and then not Acts_As_Spec (Unit_Node)
6258 elsif Nkind (Parent_Node) = N_Package_Body then
6261 elsif Nkind (Parent_Node) = N_Package_Specification
6262 and then Plist = Private_Declarations (Parent_Node)
6266 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6267 or else Nkind (Parent_Node) =
6268 N_Generic_Subprogram_Declaration)
6269 and then Plist = Generic_Formal_Declarations (Parent_Node)
6273 elsif Arg_Count > 0 then
6274 Analyze (Get_Pragma_Arg (Arg1));
6276 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6278 ("name in pragma% must be enclosing unit", Arg1);
6281 -- It is legal to have no argument in this context
6287 -- Error if not before first declaration. This is because a
6288 -- library unit pragma argument must be the name of a library
6289 -- unit (RM 10.1.5(7)), but the only names permitted in this
6290 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6291 -- generic subprogram declarations or generic instantiations.
6295 ("pragma% misplaced, must be before first declaration");
6299 end Check_Valid_Library_Unit_Pragma;
6305 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6306 Clist : constant Node_Id := Component_List (Variant);
6310 Comp := First (Component_Items (Clist));
6311 while Present (Comp) loop
6312 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6317 ---------------------------
6318 -- Ensure_Aggregate_Form --
6319 ---------------------------
6321 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6322 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6323 Expr : constant Node_Id := Expression (Arg);
6324 Loc : constant Source_Ptr := Sloc (Expr);
6325 Comps : List_Id := No_List;
6326 Exprs : List_Id := No_List;
6327 Nam : Name_Id := No_Name;
6328 Nam_Loc : Source_Ptr;
6331 -- The pragma argument is in positional form:
6333 -- pragma Depends (Nam => ...)
6337 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6338 -- argument association.
6340 if Nkind (Arg) = N_Pragma_Argument_Association then
6342 Nam_Loc := Sloc (Arg);
6344 -- Remove the pragma argument name as this will be captured in the
6347 Set_Chars (Arg, No_Name);
6350 -- The argument is already in aggregate form, but the presence of a
6351 -- name causes this to be interpreted as named association which in
6352 -- turn must be converted into an aggregate.
6354 -- pragma Global (In_Out => (A, B, C))
6358 -- pragma Global ((In_Out => (A, B, C)))
6360 -- aggregate aggregate
6362 if Nkind (Expr) = N_Aggregate then
6363 if Nam = No_Name then
6367 -- Do not transform a null argument into an aggregate as N_Null has
6368 -- special meaning in formal verification pragmas.
6370 elsif Nkind (Expr) = N_Null then
6374 -- Everything comes from source if the original comes from source
6376 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6378 -- Positional argument is transformed into an aggregate with an
6379 -- Expressions list.
6381 if Nam = No_Name then
6382 Exprs := New_List (Relocate_Node (Expr));
6384 -- An associative argument is transformed into an aggregate with
6385 -- Component_Associations.
6389 Make_Component_Association (Loc,
6390 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6391 Expression => Relocate_Node (Expr)));
6394 Set_Expression (Arg,
6395 Make_Aggregate (Loc,
6396 Component_Associations => Comps,
6397 Expressions => Exprs));
6399 -- Restore Comes_From_Source default
6401 Set_Comes_From_Source_Default (CFSD);
6402 end Ensure_Aggregate_Form;
6408 procedure Error_Pragma (Msg : String) is
6410 Error_Msg_Name_1 := Pname;
6411 Error_Msg_N (Fix_Error (Msg), N);
6415 ----------------------
6416 -- Error_Pragma_Arg --
6417 ----------------------
6419 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6421 Error_Msg_Name_1 := Pname;
6422 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6424 end Error_Pragma_Arg;
6426 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6428 Error_Msg_Name_1 := Pname;
6429 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6430 Error_Pragma_Arg (Msg2, Arg);
6431 end Error_Pragma_Arg;
6433 ----------------------------
6434 -- Error_Pragma_Arg_Ident --
6435 ----------------------------
6437 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6439 Error_Msg_Name_1 := Pname;
6440 Error_Msg_N (Fix_Error (Msg), Arg);
6442 end Error_Pragma_Arg_Ident;
6444 ----------------------
6445 -- Error_Pragma_Ref --
6446 ----------------------
6448 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6450 Error_Msg_Name_1 := Pname;
6451 Error_Msg_Sloc := Sloc (Ref);
6452 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6454 end Error_Pragma_Ref;
6456 ------------------------
6457 -- Find_Lib_Unit_Name --
6458 ------------------------
6460 function Find_Lib_Unit_Name return Entity_Id is
6462 -- Return inner compilation unit entity, for case of nested
6463 -- categorization pragmas. This happens in generic unit.
6465 if Nkind (Parent (N)) = N_Package_Specification
6466 and then Defining_Entity (Parent (N)) /= Current_Scope
6468 return Defining_Entity (Parent (N));
6470 return Current_Scope;
6472 end Find_Lib_Unit_Name;
6474 ----------------------------
6475 -- Find_Program_Unit_Name --
6476 ----------------------------
6478 procedure Find_Program_Unit_Name (Id : Node_Id) is
6479 Unit_Name : Entity_Id;
6480 Unit_Kind : Node_Kind;
6481 P : constant Node_Id := Parent (N);
6484 if Nkind (P) = N_Compilation_Unit then
6485 Unit_Kind := Nkind (Unit (P));
6487 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6488 N_Package_Declaration)
6489 or else Unit_Kind in N_Generic_Declaration
6491 Unit_Name := Defining_Entity (Unit (P));
6493 if Chars (Id) = Chars (Unit_Name) then
6494 Set_Entity (Id, Unit_Name);
6495 Set_Etype (Id, Etype (Unit_Name));
6497 Set_Etype (Id, Any_Type);
6499 ("cannot find program unit referenced by pragma%");
6503 Set_Etype (Id, Any_Type);
6504 Error_Pragma ("pragma% inapplicable to this unit");
6510 end Find_Program_Unit_Name;
6512 -----------------------------------------
6513 -- Find_Unique_Parameterless_Procedure --
6514 -----------------------------------------
6516 function Find_Unique_Parameterless_Procedure
6518 Arg : Node_Id) return Entity_Id
6520 Proc : Entity_Id := Empty;
6523 -- The body of this procedure needs some comments ???
6525 if not Is_Entity_Name (Name) then
6527 ("argument of pragma% must be entity name", Arg);
6529 elsif not Is_Overloaded (Name) then
6530 Proc := Entity (Name);
6532 if Ekind (Proc) /= E_Procedure
6533 or else Present (First_Formal (Proc))
6536 ("argument of pragma% must be parameterless procedure", Arg);
6541 Found : Boolean := False;
6543 Index : Interp_Index;
6546 Get_First_Interp (Name, Index, It);
6547 while Present (It.Nam) loop
6550 if Ekind (Proc) = E_Procedure
6551 and then No (First_Formal (Proc))
6555 Set_Entity (Name, Proc);
6556 Set_Is_Overloaded (Name, False);
6559 ("ambiguous handler name for pragma% ", Arg);
6563 Get_Next_Interp (Index, It);
6568 ("argument of pragma% must be parameterless procedure",
6571 Proc := Entity (Name);
6577 end Find_Unique_Parameterless_Procedure;
6583 function Fix_Error (Msg : String) return String is
6584 Res : String (Msg'Range) := Msg;
6585 Res_Last : Natural := Msg'Last;
6589 -- If we have a rewriting of another pragma, go to that pragma
6591 if Is_Rewrite_Substitution (N)
6592 and then Nkind (Original_Node (N)) = N_Pragma
6594 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6597 -- Case where pragma comes from an aspect specification
6599 if From_Aspect_Specification (N) then
6601 -- Change appearence of "pragma" in message to "aspect"
6604 while J <= Res_Last - 5 loop
6605 if Res (J .. J + 5) = "pragma" then
6606 Res (J .. J + 5) := "aspect";
6614 -- Change "argument of" at start of message to "entity for"
6617 and then Res (Res'First .. Res'First + 10) = "argument of"
6619 Res (Res'First .. Res'First + 9) := "entity for";
6620 Res (Res'First + 10 .. Res_Last - 1) :=
6621 Res (Res'First + 11 .. Res_Last);
6622 Res_Last := Res_Last - 1;
6625 -- Change "argument" at start of message to "entity"
6628 and then Res (Res'First .. Res'First + 7) = "argument"
6630 Res (Res'First .. Res'First + 5) := "entity";
6631 Res (Res'First + 6 .. Res_Last - 2) :=
6632 Res (Res'First + 8 .. Res_Last);
6633 Res_Last := Res_Last - 2;
6636 -- Get name from corresponding aspect
6638 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6641 -- Return possibly modified message
6643 return Res (Res'First .. Res_Last);
6646 -------------------------
6647 -- Gather_Associations --
6648 -------------------------
6650 procedure Gather_Associations
6652 Args : out Args_List)
6657 -- Initialize all parameters to Empty
6659 for J in Args'Range loop
6663 -- That's all we have to do if there are no argument associations
6665 if No (Pragma_Argument_Associations (N)) then
6669 -- Otherwise first deal with any positional parameters present
6671 Arg := First (Pragma_Argument_Associations (N));
6672 for Index in Args'Range loop
6673 exit when No (Arg) or else Chars (Arg) /= No_Name;
6674 Args (Index) := Get_Pragma_Arg (Arg);
6678 -- Positional parameters all processed, if any left, then we
6679 -- have too many positional parameters.
6681 if Present (Arg) and then Chars (Arg) = No_Name then
6683 ("too many positional associations for pragma%", Arg);
6686 -- Process named parameters if any are present
6688 while Present (Arg) loop
6689 if Chars (Arg) = No_Name then
6691 ("positional association cannot follow named association",
6695 for Index in Names'Range loop
6696 if Names (Index) = Chars (Arg) then
6697 if Present (Args (Index)) then
6699 ("duplicate argument association for pragma%", Arg);
6701 Args (Index) := Get_Pragma_Arg (Arg);
6706 if Index = Names'Last then
6707 Error_Msg_Name_1 := Pname;
6708 Error_Msg_N ("pragma% does not allow & argument", Arg);
6710 -- Check for possible misspelling
6712 for Index1 in Names'Range loop
6713 if Is_Bad_Spelling_Of
6714 (Chars (Arg), Names (Index1))
6716 Error_Msg_Name_1 := Names (Index1);
6717 Error_Msg_N -- CODEFIX
6718 ("\possible misspelling of%", Arg);
6730 end Gather_Associations;
6736 procedure GNAT_Pragma is
6738 -- We need to check the No_Implementation_Pragmas restriction for
6739 -- the case of a pragma from source. Note that the case of aspects
6740 -- generating corresponding pragmas marks these pragmas as not being
6741 -- from source, so this test also catches that case.
6743 if Comes_From_Source (N) then
6744 Check_Restriction (No_Implementation_Pragmas, N);
6748 --------------------------
6749 -- Is_Before_First_Decl --
6750 --------------------------
6752 function Is_Before_First_Decl
6753 (Pragma_Node : Node_Id;
6754 Decls : List_Id) return Boolean
6756 Item : Node_Id := First (Decls);
6759 -- Only other pragmas can come before this pragma
6762 if No (Item) or else Nkind (Item) /= N_Pragma then
6765 elsif Item = Pragma_Node then
6771 end Is_Before_First_Decl;
6773 -----------------------------
6774 -- Is_Configuration_Pragma --
6775 -----------------------------
6777 -- A configuration pragma must appear in the context clause of a
6778 -- compilation unit, and only other pragmas may precede it. Note that
6779 -- the test below also permits use in a configuration pragma file.
6781 function Is_Configuration_Pragma return Boolean is
6782 Lis : constant List_Id := List_Containing (N);
6783 Par : constant Node_Id := Parent (N);
6787 -- If no parent, then we are in the configuration pragma file,
6788 -- so the placement is definitely appropriate.
6793 -- Otherwise we must be in the context clause of a compilation unit
6794 -- and the only thing allowed before us in the context list is more
6795 -- configuration pragmas.
6797 elsif Nkind (Par) = N_Compilation_Unit
6798 and then Context_Items (Par) = Lis
6805 elsif Nkind (Prg) /= N_Pragma then
6815 end Is_Configuration_Pragma;
6817 --------------------------
6818 -- Is_In_Context_Clause --
6819 --------------------------
6821 function Is_In_Context_Clause return Boolean is
6823 Parent_Node : Node_Id;
6826 if not Is_List_Member (N) then
6830 Plist := List_Containing (N);
6831 Parent_Node := Parent (Plist);
6833 if Parent_Node = Empty
6834 or else Nkind (Parent_Node) /= N_Compilation_Unit
6835 or else Context_Items (Parent_Node) /= Plist
6842 end Is_In_Context_Clause;
6844 ---------------------------------
6845 -- Is_Static_String_Expression --
6846 ---------------------------------
6848 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6849 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6850 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6853 Analyze_And_Resolve (Argx);
6855 -- Special case Ada 83, where the expression will never be static,
6856 -- but we will return true if we had a string literal to start with.
6858 if Ada_Version = Ada_83 then
6861 -- Normal case, true only if we end up with a string literal that
6862 -- is marked as being the result of evaluating a static expression.
6865 return Is_OK_Static_Expression (Argx)
6866 and then Nkind (Argx) = N_String_Literal;
6869 end Is_Static_String_Expression;
6871 ----------------------
6872 -- Pragma_Misplaced --
6873 ----------------------
6875 procedure Pragma_Misplaced is
6877 Error_Pragma ("incorrect placement of pragma%");
6878 end Pragma_Misplaced;
6880 ------------------------------------------------
6881 -- Process_Atomic_Independent_Shared_Volatile --
6882 ------------------------------------------------
6884 procedure Process_Atomic_Independent_Shared_Volatile is
6885 procedure Set_Atomic_VFA (E : Entity_Id);
6886 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6887 -- no explicit alignment was given, set alignment to unknown, since
6888 -- back end knows what the alignment requirements are for atomic and
6889 -- full access arrays. Note: this is necessary for derived types.
6891 --------------------
6892 -- Set_Atomic_VFA --
6893 --------------------
6895 procedure Set_Atomic_VFA (E : Entity_Id) is
6897 if Prag_Id = Pragma_Volatile_Full_Access then
6898 Set_Is_Volatile_Full_Access (E);
6903 if not Has_Alignment_Clause (E) then
6904 Set_Alignment (E, Uint_0);
6914 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6917 Check_Ada_83_Warning;
6918 Check_No_Identifiers;
6919 Check_Arg_Count (1);
6920 Check_Arg_Is_Local_Name (Arg1);
6921 E_Arg := Get_Pragma_Arg (Arg1);
6923 if Etype (E_Arg) = Any_Type then
6927 E := Entity (E_Arg);
6929 -- A pragma that applies to a Ghost entity becomes Ghost for the
6930 -- purposes of legality checks and removal of ignored Ghost code.
6932 Mark_Ghost_Pragma (N, E);
6934 -- Check duplicate before we chain ourselves
6936 Check_Duplicate_Pragma (E);
6938 -- Check Atomic and VFA used together
6940 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6941 or else (Is_Volatile_Full_Access (E)
6942 and then (Prag_Id = Pragma_Atomic
6944 Prag_Id = Pragma_Shared))
6947 ("cannot have Volatile_Full_Access and Atomic for same entity");
6950 -- Check for applying VFA to an entity which has aliased component
6952 if Prag_Id = Pragma_Volatile_Full_Access then
6955 Aliased_Comp : Boolean := False;
6956 -- Set True if aliased component present
6959 if Is_Array_Type (Etype (E)) then
6960 Aliased_Comp := Has_Aliased_Components (Etype (E));
6962 -- Record case, too bad Has_Aliased_Components is not also
6963 -- set for records, should it be ???
6965 elsif Is_Record_Type (Etype (E)) then
6966 Comp := First_Component_Or_Discriminant (Etype (E));
6967 while Present (Comp) loop
6968 if Is_Aliased (Comp)
6969 or else Is_Aliased (Etype (Comp))
6971 Aliased_Comp := True;
6975 Next_Component_Or_Discriminant (Comp);
6979 if Aliased_Comp then
6981 ("cannot apply Volatile_Full_Access (aliased component "
6987 -- Now check appropriateness of the entity
6989 Decl := Declaration_Node (E);
6992 if Rep_Item_Too_Early (E, N)
6994 Rep_Item_Too_Late (E, N)
6998 Check_First_Subtype (Arg1);
7001 -- Attribute belongs on the base type. If the view of the type is
7002 -- currently private, it also belongs on the underlying type.
7004 if Prag_Id = Pragma_Atomic
7006 Prag_Id = Pragma_Shared
7008 Prag_Id = Pragma_Volatile_Full_Access
7011 Set_Atomic_VFA (Base_Type (E));
7012 Set_Atomic_VFA (Underlying_Type (E));
7015 -- Atomic/Shared/Volatile_Full_Access imply Independent
7017 if Prag_Id /= Pragma_Volatile then
7018 Set_Is_Independent (E);
7019 Set_Is_Independent (Base_Type (E));
7020 Set_Is_Independent (Underlying_Type (E));
7022 if Prag_Id = Pragma_Independent then
7023 Record_Independence_Check (N, Base_Type (E));
7027 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7029 if Prag_Id /= Pragma_Independent then
7030 Set_Is_Volatile (E);
7031 Set_Is_Volatile (Base_Type (E));
7032 Set_Is_Volatile (Underlying_Type (E));
7034 Set_Treat_As_Volatile (E);
7035 Set_Treat_As_Volatile (Underlying_Type (E));
7038 elsif Nkind (Decl) = N_Object_Declaration
7039 or else (Nkind (Decl) = N_Component_Declaration
7040 and then Original_Record_Component (E) = E)
7042 if Rep_Item_Too_Late (E, N) then
7046 if Prag_Id = Pragma_Atomic
7048 Prag_Id = Pragma_Shared
7050 Prag_Id = Pragma_Volatile_Full_Access
7052 if Prag_Id = Pragma_Volatile_Full_Access then
7053 Set_Is_Volatile_Full_Access (E);
7058 -- If the object declaration has an explicit initialization, a
7059 -- temporary may have to be created to hold the expression, to
7060 -- ensure that access to the object remain atomic.
7062 if Nkind (Parent (E)) = N_Object_Declaration
7063 and then Present (Expression (Parent (E)))
7065 Set_Has_Delayed_Freeze (E);
7069 -- Atomic/Shared/Volatile_Full_Access imply Independent
7071 if Prag_Id /= Pragma_Volatile then
7072 Set_Is_Independent (E);
7074 if Prag_Id = Pragma_Independent then
7075 Record_Independence_Check (N, E);
7079 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7081 if Prag_Id /= Pragma_Independent then
7082 Set_Is_Volatile (E);
7083 Set_Treat_As_Volatile (E);
7087 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7090 -- The following check is only relevant when SPARK_Mode is on as
7091 -- this is not a standard Ada legality rule. Pragma Volatile can
7092 -- only apply to a full type declaration or an object declaration
7093 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7094 -- untagged derived types that are rewritten as subtypes of their
7095 -- respective root types.
7098 and then Prag_Id = Pragma_Volatile
7100 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
7101 N_Object_Declaration)
7104 ("argument of pragma % must denote a full type or object "
7105 & "declaration", Arg1);
7107 end Process_Atomic_Independent_Shared_Volatile;
7109 -------------------------------------------
7110 -- Process_Compile_Time_Warning_Or_Error --
7111 -------------------------------------------
7113 procedure Process_Compile_Time_Warning_Or_Error is
7114 Validation_Needed : Boolean := False;
7116 function Check_Node (N : Node_Id) return Traverse_Result;
7117 -- Tree visitor that checks if N is an attribute reference that can
7118 -- be statically computed by the back end. Validation_Needed is set
7119 -- to True if found.
7125 function Check_Node (N : Node_Id) return Traverse_Result is
7127 if Nkind (N) = N_Attribute_Reference
7128 and then Is_Entity_Name (Prefix (N))
7131 Attr_Id : constant Attribute_Id :=
7132 Get_Attribute_Id (Attribute_Name (N));
7134 if Attr_Id = Attribute_Alignment
7135 or else Attr_Id = Attribute_Size
7137 Validation_Needed := True;
7145 procedure Check_Expression is new Traverse_Proc (Check_Node);
7149 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7151 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7154 Check_Arg_Count (2);
7155 Check_No_Identifiers;
7156 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7157 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7159 if Compile_Time_Known_Value (Arg1x) then
7160 Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7162 -- Register the expression for its validation after the back end has
7163 -- been called if it has occurrences of attributes Size or Alignment
7164 -- (because they may be statically computed by the back end and hence
7165 -- the whole expression needs to be reevaluated).
7168 Check_Expression (Arg1x);
7170 if Validation_Needed then
7171 Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
7174 end Process_Compile_Time_Warning_Or_Error;
7176 ------------------------
7177 -- Process_Convention --
7178 ------------------------
7180 procedure Process_Convention
7181 (C : out Convention_Id;
7182 Ent : out Entity_Id)
7186 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7187 -- Called if we have more than one Export/Import/Convention pragma.
7188 -- This is generally illegal, but we have a special case of allowing
7189 -- Import and Interface to coexist if they specify the convention in
7190 -- a consistent manner. We are allowed to do this, since Interface is
7191 -- an implementation defined pragma, and we choose to do it since we
7192 -- know Rational allows this combination. S is the entity id of the
7193 -- subprogram in question. This procedure also sets the special flag
7194 -- Import_Interface_Present in both pragmas in the case where we do
7195 -- have matching Import and Interface pragmas.
7197 procedure Set_Convention_From_Pragma (E : Entity_Id);
7198 -- Set convention in entity E, and also flag that the entity has a
7199 -- convention pragma. If entity is for a private or incomplete type,
7200 -- also set convention and flag on underlying type. This procedure
7201 -- also deals with the special case of C_Pass_By_Copy convention,
7202 -- and error checks for inappropriate convention specification.
7204 -------------------------------
7205 -- Diagnose_Multiple_Pragmas --
7206 -------------------------------
7208 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7209 Pdec : constant Node_Id := Declaration_Node (S);
7213 function Same_Convention (Decl : Node_Id) return Boolean;
7214 -- Decl is a pragma node. This function returns True if this
7215 -- pragma has a first argument that is an identifier with a
7216 -- Chars field corresponding to the Convention_Id C.
7218 function Same_Name (Decl : Node_Id) return Boolean;
7219 -- Decl is a pragma node. This function returns True if this
7220 -- pragma has a second argument that is an identifier with a
7221 -- Chars field that matches the Chars of the current subprogram.
7223 ---------------------
7224 -- Same_Convention --
7225 ---------------------
7227 function Same_Convention (Decl : Node_Id) return Boolean is
7228 Arg1 : constant Node_Id :=
7229 First (Pragma_Argument_Associations (Decl));
7232 if Present (Arg1) then
7234 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7236 if Nkind (Arg) = N_Identifier
7237 and then Is_Convention_Name (Chars (Arg))
7238 and then Get_Convention_Id (Chars (Arg)) = C
7246 end Same_Convention;
7252 function Same_Name (Decl : Node_Id) return Boolean is
7253 Arg1 : constant Node_Id :=
7254 First (Pragma_Argument_Associations (Decl));
7262 Arg2 := Next (Arg1);
7269 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7271 if Nkind (Arg) = N_Identifier
7272 and then Chars (Arg) = Chars (S)
7281 -- Start of processing for Diagnose_Multiple_Pragmas
7286 -- Definitely give message if we have Convention/Export here
7288 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7291 -- If we have an Import or Export, scan back from pragma to
7292 -- find any previous pragma applying to the same procedure.
7293 -- The scan will be terminated by the start of the list, or
7294 -- hitting the subprogram declaration. This won't allow one
7295 -- pragma to appear in the public part and one in the private
7296 -- part, but that seems very unlikely in practice.
7300 while Present (Decl) and then Decl /= Pdec loop
7302 -- Look for pragma with same name as us
7304 if Nkind (Decl) = N_Pragma
7305 and then Same_Name (Decl)
7307 -- Give error if same as our pragma or Export/Convention
7309 if Nam_In (Pragma_Name_Unmapped (Decl),
7312 Pragma_Name_Unmapped (N))
7316 -- Case of Import/Interface or the other way round
7318 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7319 Name_Interface, Name_Import)
7321 -- Here we know that we have Import and Interface. It
7322 -- doesn't matter which way round they are. See if
7323 -- they specify the same convention. If so, all OK,
7324 -- and set special flags to stop other messages
7326 if Same_Convention (Decl) then
7327 Set_Import_Interface_Present (N);
7328 Set_Import_Interface_Present (Decl);
7331 -- If different conventions, special message
7334 Error_Msg_Sloc := Sloc (Decl);
7336 ("convention differs from that given#", Arg1);
7346 -- Give message if needed if we fall through those tests
7347 -- except on Relaxed_RM_Semantics where we let go: either this
7348 -- is a case accepted/ignored by other Ada compilers (e.g.
7349 -- a mix of Convention and Import), or another error will be
7350 -- generated later (e.g. using both Import and Export).
7352 if Err and not Relaxed_RM_Semantics then
7354 ("at most one Convention/Export/Import pragma is allowed",
7357 end Diagnose_Multiple_Pragmas;
7359 --------------------------------
7360 -- Set_Convention_From_Pragma --
7361 --------------------------------
7363 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7365 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7366 -- for an overridden dispatching operation. Technically this is
7367 -- an amendment and should only be done in Ada 2005 mode. However,
7368 -- this is clearly a mistake, since the problem that is addressed
7369 -- by this AI is that there is a clear gap in the RM.
7371 if Is_Dispatching_Operation (E)
7372 and then Present (Overridden_Operation (E))
7373 and then C /= Convention (Overridden_Operation (E))
7376 ("cannot change convention for overridden dispatching "
7377 & "operation", Arg1);
7380 -- Special checks for Convention_Stdcall
7382 if C = Convention_Stdcall then
7384 -- A dispatching call is not allowed. A dispatching subprogram
7385 -- cannot be used to interface to the Win32 API, so in fact
7386 -- this check does not impose any effective restriction.
7388 if Is_Dispatching_Operation (E) then
7389 Error_Msg_Sloc := Sloc (E);
7391 -- Note: make this unconditional so that if there is more
7392 -- than one call to which the pragma applies, we get a
7393 -- message for each call. Also don't use Error_Pragma,
7394 -- so that we get multiple messages.
7397 ("dispatching subprogram# cannot use Stdcall convention!",
7400 -- Several allowed cases
7402 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7406 or else Ekind (E) = E_Variable
7408 -- A component as well. The entity does not have its Ekind
7409 -- set until the enclosing record declaration is fully
7412 or else Nkind (Parent (E)) = N_Component_Declaration
7414 -- An access to subprogram is also allowed
7418 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7420 -- Allow internal call to set convention of subprogram type
7422 or else Ekind (E) = E_Subprogram_Type
7428 ("second argument of pragma% must be subprogram (type)",
7433 -- Set the convention
7435 Set_Convention (E, C);
7436 Set_Has_Convention_Pragma (E);
7438 -- For the case of a record base type, also set the convention of
7439 -- any anonymous access types declared in the record which do not
7440 -- currently have a specified convention.
7442 if Is_Record_Type (E) and then Is_Base_Type (E) then
7447 Comp := First_Component (E);
7448 while Present (Comp) loop
7449 if Present (Etype (Comp))
7450 and then Ekind_In (Etype (Comp),
7451 E_Anonymous_Access_Type,
7452 E_Anonymous_Access_Subprogram_Type)
7453 and then not Has_Convention_Pragma (Comp)
7455 Set_Convention (Comp, C);
7458 Next_Component (Comp);
7463 -- Deal with incomplete/private type case, where underlying type
7464 -- is available, so set convention of that underlying type.
7466 if Is_Incomplete_Or_Private_Type (E)
7467 and then Present (Underlying_Type (E))
7469 Set_Convention (Underlying_Type (E), C);
7470 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7473 -- A class-wide type should inherit the convention of the specific
7474 -- root type (although this isn't specified clearly by the RM).
7476 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7477 Set_Convention (Class_Wide_Type (E), C);
7480 -- If the entity is a record type, then check for special case of
7481 -- C_Pass_By_Copy, which is treated the same as C except that the
7482 -- special record flag is set. This convention is only permitted
7483 -- on record types (see AI95-00131).
7485 if Cname = Name_C_Pass_By_Copy then
7486 if Is_Record_Type (E) then
7487 Set_C_Pass_By_Copy (Base_Type (E));
7488 elsif Is_Incomplete_Or_Private_Type (E)
7489 and then Is_Record_Type (Underlying_Type (E))
7491 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7494 ("C_Pass_By_Copy convention allowed only for record type",
7499 -- If the entity is a derived boolean type, check for the special
7500 -- case of convention C, C++, or Fortran, where we consider any
7501 -- nonzero value to represent true.
7503 if Is_Discrete_Type (E)
7504 and then Root_Type (Etype (E)) = Standard_Boolean
7510 C = Convention_Fortran)
7512 Set_Nonzero_Is_True (Base_Type (E));
7514 end Set_Convention_From_Pragma;
7518 Comp_Unit : Unit_Number_Type;
7523 -- Start of processing for Process_Convention
7526 Check_At_Least_N_Arguments (2);
7527 Check_Optional_Identifier (Arg1, Name_Convention);
7528 Check_Arg_Is_Identifier (Arg1);
7529 Cname := Chars (Get_Pragma_Arg (Arg1));
7531 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7532 -- tested again below to set the critical flag).
7534 if Cname = Name_C_Pass_By_Copy then
7537 -- Otherwise we must have something in the standard convention list
7539 elsif Is_Convention_Name (Cname) then
7540 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7542 -- Otherwise warn on unrecognized convention
7545 if Warn_On_Export_Import then
7547 ("??unrecognized convention name, C assumed",
7548 Get_Pragma_Arg (Arg1));
7554 Check_Optional_Identifier (Arg2, Name_Entity);
7555 Check_Arg_Is_Local_Name (Arg2);
7557 Id := Get_Pragma_Arg (Arg2);
7560 if not Is_Entity_Name (Id) then
7561 Error_Pragma_Arg ("entity name required", Arg2);
7566 -- Set entity to return
7570 -- Ada_Pass_By_Copy special checking
7572 if C = Convention_Ada_Pass_By_Copy then
7573 if not Is_First_Subtype (E) then
7575 ("convention `Ada_Pass_By_Copy` only allowed for types",
7579 if Is_By_Reference_Type (E) then
7581 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7585 -- Ada_Pass_By_Reference special checking
7587 elsif C = Convention_Ada_Pass_By_Reference then
7588 if not Is_First_Subtype (E) then
7590 ("convention `Ada_Pass_By_Reference` only allowed for types",
7594 if Is_By_Copy_Type (E) then
7596 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7601 -- Go to renamed subprogram if present, since convention applies to
7602 -- the actual renamed entity, not to the renaming entity. If the
7603 -- subprogram is inherited, go to parent subprogram.
7605 if Is_Subprogram (E)
7606 and then Present (Alias (E))
7608 if Nkind (Parent (Declaration_Node (E))) =
7609 N_Subprogram_Renaming_Declaration
7611 if Scope (E) /= Scope (Alias (E)) then
7613 ("cannot apply pragma% to non-local entity&#", E);
7618 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7619 N_Private_Extension_Declaration)
7620 and then Scope (E) = Scope (Alias (E))
7624 -- Return the parent subprogram the entity was inherited from
7630 -- Check that we are not applying this to a specless body. Relax this
7631 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7633 if Is_Subprogram (E)
7634 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7635 and then not Relaxed_RM_Semantics
7638 ("pragma% requires separate spec and must come before body");
7641 -- Check that we are not applying this to a named constant
7643 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7644 Error_Msg_Name_1 := Pname;
7646 ("cannot apply pragma% to named constant!",
7647 Get_Pragma_Arg (Arg2));
7649 ("\supply appropriate type for&!", Arg2);
7652 if Ekind (E) = E_Enumeration_Literal then
7653 Error_Pragma ("enumeration literal not allowed for pragma%");
7656 -- Check for rep item appearing too early or too late
7658 if Etype (E) = Any_Type
7659 or else Rep_Item_Too_Early (E, N)
7663 elsif Present (Underlying_Type (E)) then
7664 E := Underlying_Type (E);
7667 if Rep_Item_Too_Late (E, N) then
7671 if Has_Convention_Pragma (E) then
7672 Diagnose_Multiple_Pragmas (E);
7674 elsif Convention (E) = Convention_Protected
7675 or else Ekind (Scope (E)) = E_Protected_Type
7678 ("a protected operation cannot be given a different convention",
7682 -- For Intrinsic, a subprogram is required
7684 if C = Convention_Intrinsic
7685 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7687 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7689 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7691 ("second argument of pragma% must be a subprogram", Arg2);
7695 -- Deal with non-subprogram cases
7697 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7698 Set_Convention_From_Pragma (E);
7702 -- The pragma must apply to a first subtype, but it can also
7703 -- apply to a generic type in a generic formal part, in which
7704 -- case it will also appear in the corresponding instance.
7706 if Is_Generic_Type (E) or else In_Instance then
7709 Check_First_Subtype (Arg2);
7712 Set_Convention_From_Pragma (Base_Type (E));
7714 -- For access subprograms, we must set the convention on the
7715 -- internally generated directly designated type as well.
7717 if Ekind (E) = E_Access_Subprogram_Type then
7718 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7722 -- For the subprogram case, set proper convention for all homonyms
7723 -- in same scope and the same declarative part, i.e. the same
7724 -- compilation unit.
7727 Comp_Unit := Get_Source_Unit (E);
7728 Set_Convention_From_Pragma (E);
7730 -- Treat a pragma Import as an implicit body, and pragma import
7731 -- as implicit reference (for navigation in GPS).
7733 if Prag_Id = Pragma_Import then
7734 Generate_Reference (E, Id, 'b');
7736 -- For exported entities we restrict the generation of references
7737 -- to entities exported to foreign languages since entities
7738 -- exported to Ada do not provide further information to GPS and
7739 -- add undesired references to the output of the gnatxref tool.
7741 elsif Prag_Id = Pragma_Export
7742 and then Convention (E) /= Convention_Ada
7744 Generate_Reference (E, Id, 'i');
7747 -- If the pragma comes from an aspect, it only applies to the
7748 -- given entity, not its homonyms.
7750 if From_Aspect_Specification (N) then
7754 -- Otherwise Loop through the homonyms of the pragma argument's
7755 -- entity, an apply convention to those in the current scope.
7761 exit when No (E1) or else Scope (E1) /= Current_Scope;
7763 -- Ignore entry for which convention is already set
7765 if Has_Convention_Pragma (E1) then
7769 if Is_Subprogram (E1)
7770 and then Nkind (Parent (Declaration_Node (E1))) =
7772 and then not Relaxed_RM_Semantics
7774 Set_Has_Completion (E); -- to prevent cascaded error
7776 ("pragma% requires separate spec and must come before "
7780 -- Do not set the pragma on inherited operations or on formal
7783 if Comes_From_Source (E1)
7784 and then Comp_Unit = Get_Source_Unit (E1)
7785 and then not Is_Formal_Subprogram (E1)
7786 and then Nkind (Original_Node (Parent (E1))) /=
7787 N_Full_Type_Declaration
7789 if Present (Alias (E1))
7790 and then Scope (E1) /= Scope (Alias (E1))
7793 ("cannot apply pragma% to non-local entity& declared#",
7797 Set_Convention_From_Pragma (E1);
7799 if Prag_Id = Pragma_Import then
7800 Generate_Reference (E1, Id, 'b');
7808 end Process_Convention;
7810 ----------------------------------------
7811 -- Process_Disable_Enable_Atomic_Sync --
7812 ----------------------------------------
7814 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7816 Check_No_Identifiers;
7817 Check_At_Most_N_Arguments (1);
7819 -- Modeled internally as
7820 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7825 Pragma_Argument_Associations => New_List (
7826 Make_Pragma_Argument_Association (Loc,
7828 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7830 if Present (Arg1) then
7831 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7835 end Process_Disable_Enable_Atomic_Sync;
7837 -------------------------------------------------
7838 -- Process_Extended_Import_Export_Internal_Arg --
7839 -------------------------------------------------
7841 procedure Process_Extended_Import_Export_Internal_Arg
7842 (Arg_Internal : Node_Id := Empty)
7845 if No (Arg_Internal) then
7846 Error_Pragma ("Internal parameter required for pragma%");
7849 if Nkind (Arg_Internal) = N_Identifier then
7852 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7853 and then (Prag_Id = Pragma_Import_Function
7855 Prag_Id = Pragma_Export_Function)
7861 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7864 Check_Arg_Is_Local_Name (Arg_Internal);
7865 end Process_Extended_Import_Export_Internal_Arg;
7867 --------------------------------------------------
7868 -- Process_Extended_Import_Export_Object_Pragma --
7869 --------------------------------------------------
7871 procedure Process_Extended_Import_Export_Object_Pragma
7872 (Arg_Internal : Node_Id;
7873 Arg_External : Node_Id;
7879 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7880 Def_Id := Entity (Arg_Internal);
7882 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7884 ("pragma% must designate an object", Arg_Internal);
7887 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7889 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7892 ("previous Common/Psect_Object applies, pragma % not permitted",
7896 if Rep_Item_Too_Late (Def_Id, N) then
7900 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7902 if Present (Arg_Size) then
7903 Check_Arg_Is_External_Name (Arg_Size);
7906 -- Export_Object case
7908 if Prag_Id = Pragma_Export_Object then
7909 if not Is_Library_Level_Entity (Def_Id) then
7911 ("argument for pragma% must be library level entity",
7915 if Ekind (Current_Scope) = E_Generic_Package then
7916 Error_Pragma ("pragma& cannot appear in a generic unit");
7919 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7921 ("exported object must have compile time known size",
7925 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7926 Error_Msg_N ("??duplicate Export_Object pragma", N);
7928 Set_Exported (Def_Id, Arg_Internal);
7931 -- Import_Object case
7934 if Is_Concurrent_Type (Etype (Def_Id)) then
7936 ("cannot use pragma% for task/protected object",
7940 if Ekind (Def_Id) = E_Constant then
7942 ("cannot import a constant", Arg_Internal);
7945 if Warn_On_Export_Import
7946 and then Has_Discriminants (Etype (Def_Id))
7949 ("imported value must be initialized??", Arg_Internal);
7952 if Warn_On_Export_Import
7953 and then Is_Access_Type (Etype (Def_Id))
7956 ("cannot import object of an access type??", Arg_Internal);
7959 if Warn_On_Export_Import
7960 and then Is_Imported (Def_Id)
7962 Error_Msg_N ("??duplicate Import_Object pragma", N);
7964 -- Check for explicit initialization present. Note that an
7965 -- initialization generated by the code generator, e.g. for an
7966 -- access type, does not count here.
7968 elsif Present (Expression (Parent (Def_Id)))
7971 (Original_Node (Expression (Parent (Def_Id))))
7973 Error_Msg_Sloc := Sloc (Def_Id);
7975 ("imported entities cannot be initialized (RM B.1(24))",
7976 "\no initialization allowed for & declared#", Arg1);
7978 Set_Imported (Def_Id);
7979 Note_Possible_Modification (Arg_Internal, Sure => False);
7982 end Process_Extended_Import_Export_Object_Pragma;
7984 ------------------------------------------------------
7985 -- Process_Extended_Import_Export_Subprogram_Pragma --
7986 ------------------------------------------------------
7988 procedure Process_Extended_Import_Export_Subprogram_Pragma
7989 (Arg_Internal : Node_Id;
7990 Arg_External : Node_Id;
7991 Arg_Parameter_Types : Node_Id;
7992 Arg_Result_Type : Node_Id := Empty;
7993 Arg_Mechanism : Node_Id;
7994 Arg_Result_Mechanism : Node_Id := Empty)
8000 Ambiguous : Boolean;
8003 function Same_Base_Type
8005 Formal : Entity_Id) return Boolean;
8006 -- Determines if Ptype references the type of Formal. Note that only
8007 -- the base types need to match according to the spec. Ptype here is
8008 -- the argument from the pragma, which is either a type name, or an
8009 -- access attribute.
8011 --------------------
8012 -- Same_Base_Type --
8013 --------------------
8015 function Same_Base_Type
8017 Formal : Entity_Id) return Boolean
8019 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8023 -- Case where pragma argument is typ'Access
8025 if Nkind (Ptype) = N_Attribute_Reference
8026 and then Attribute_Name (Ptype) = Name_Access
8028 Pref := Prefix (Ptype);
8031 if not Is_Entity_Name (Pref)
8032 or else Entity (Pref) = Any_Type
8037 -- We have a match if the corresponding argument is of an
8038 -- anonymous access type, and its designated type matches the
8039 -- type of the prefix of the access attribute
8041 return Ekind (Ftyp) = E_Anonymous_Access_Type
8042 and then Base_Type (Entity (Pref)) =
8043 Base_Type (Etype (Designated_Type (Ftyp)));
8045 -- Case where pragma argument is a type name
8050 if not Is_Entity_Name (Ptype)
8051 or else Entity (Ptype) = Any_Type
8056 -- We have a match if the corresponding argument is of the type
8057 -- given in the pragma (comparing base types)
8059 return Base_Type (Entity (Ptype)) = Ftyp;
8063 -- Start of processing for
8064 -- Process_Extended_Import_Export_Subprogram_Pragma
8067 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8071 -- Loop through homonyms (overloadings) of the entity
8073 Hom_Id := Entity (Arg_Internal);
8074 while Present (Hom_Id) loop
8075 Def_Id := Get_Base_Subprogram (Hom_Id);
8077 -- We need a subprogram in the current scope
8079 if not Is_Subprogram (Def_Id)
8080 or else Scope (Def_Id) /= Current_Scope
8087 -- Pragma cannot apply to subprogram body
8089 if Is_Subprogram (Def_Id)
8090 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8094 ("pragma% requires separate spec and must come before "
8098 -- Test result type if given, note that the result type
8099 -- parameter can only be present for the function cases.
8101 if Present (Arg_Result_Type)
8102 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8106 elsif Etype (Def_Id) /= Standard_Void_Type
8107 and then Nam_In (Pname, Name_Export_Procedure,
8108 Name_Import_Procedure)
8112 -- Test parameter types if given. Note that this parameter has
8113 -- not been analyzed (and must not be, since it is semantic
8114 -- nonsense), so we get it as the parser left it.
8116 elsif Present (Arg_Parameter_Types) then
8117 Check_Matching_Types : declare
8122 Formal := First_Formal (Def_Id);
8124 if Nkind (Arg_Parameter_Types) = N_Null then
8125 if Present (Formal) then
8129 -- A list of one type, e.g. (List) is parsed as a
8130 -- parenthesized expression.
8132 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8133 and then Paren_Count (Arg_Parameter_Types) = 1
8136 or else Present (Next_Formal (Formal))
8141 Same_Base_Type (Arg_Parameter_Types, Formal);
8144 -- A list of more than one type is parsed as a aggregate
8146 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8147 and then Paren_Count (Arg_Parameter_Types) = 0
8149 Ptype := First (Expressions (Arg_Parameter_Types));
8150 while Present (Ptype) or else Present (Formal) loop
8153 or else not Same_Base_Type (Ptype, Formal)
8158 Next_Formal (Formal);
8163 -- Anything else is of the wrong form
8167 ("wrong form for Parameter_Types parameter",
8168 Arg_Parameter_Types);
8170 end Check_Matching_Types;
8173 -- Match is now False if the entry we found did not match
8174 -- either a supplied Parameter_Types or Result_Types argument
8180 -- Ambiguous case, the flag Ambiguous shows if we already
8181 -- detected this and output the initial messages.
8184 if not Ambiguous then
8186 Error_Msg_Name_1 := Pname;
8188 ("pragma% does not uniquely identify subprogram!",
8190 Error_Msg_Sloc := Sloc (Ent);
8191 Error_Msg_N ("matching subprogram #!", N);
8195 Error_Msg_Sloc := Sloc (Def_Id);
8196 Error_Msg_N ("matching subprogram #!", N);
8201 Hom_Id := Homonym (Hom_Id);
8204 -- See if we found an entry
8207 if not Ambiguous then
8208 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8210 ("pragma% cannot be given for generic subprogram");
8213 ("pragma% does not identify local subprogram");
8220 -- Import pragmas must be for imported entities
8222 if Prag_Id = Pragma_Import_Function
8224 Prag_Id = Pragma_Import_Procedure
8226 Prag_Id = Pragma_Import_Valued_Procedure
8228 if not Is_Imported (Ent) then
8230 ("pragma Import or Interface must precede pragma%");
8233 -- Here we have the Export case which can set the entity as exported
8235 -- But does not do so if the specified external name is null, since
8236 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8237 -- compatible) to request no external name.
8239 elsif Nkind (Arg_External) = N_String_Literal
8240 and then String_Length (Strval (Arg_External)) = 0
8244 -- In all other cases, set entity as exported
8247 Set_Exported (Ent, Arg_Internal);
8250 -- Special processing for Valued_Procedure cases
8252 if Prag_Id = Pragma_Import_Valued_Procedure
8254 Prag_Id = Pragma_Export_Valued_Procedure
8256 Formal := First_Formal (Ent);
8259 Error_Pragma ("at least one parameter required for pragma%");
8261 elsif Ekind (Formal) /= E_Out_Parameter then
8262 Error_Pragma ("first parameter must have mode out for pragma%");
8265 Set_Is_Valued_Procedure (Ent);
8269 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8271 -- Process Result_Mechanism argument if present. We have already
8272 -- checked that this is only allowed for the function case.
8274 if Present (Arg_Result_Mechanism) then
8275 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8278 -- Process Mechanism parameter if present. Note that this parameter
8279 -- is not analyzed, and must not be analyzed since it is semantic
8280 -- nonsense, so we get it in exactly as the parser left it.
8282 if Present (Arg_Mechanism) then
8290 -- A single mechanism association without a formal parameter
8291 -- name is parsed as a parenthesized expression. All other
8292 -- cases are parsed as aggregates, so we rewrite the single
8293 -- parameter case as an aggregate for consistency.
8295 if Nkind (Arg_Mechanism) /= N_Aggregate
8296 and then Paren_Count (Arg_Mechanism) = 1
8298 Rewrite (Arg_Mechanism,
8299 Make_Aggregate (Sloc (Arg_Mechanism),
8300 Expressions => New_List (
8301 Relocate_Node (Arg_Mechanism))));
8304 -- Case of only mechanism name given, applies to all formals
8306 if Nkind (Arg_Mechanism) /= N_Aggregate then
8307 Formal := First_Formal (Ent);
8308 while Present (Formal) loop
8309 Set_Mechanism_Value (Formal, Arg_Mechanism);
8310 Next_Formal (Formal);
8313 -- Case of list of mechanism associations given
8316 if Null_Record_Present (Arg_Mechanism) then
8318 ("inappropriate form for Mechanism parameter",
8322 -- Deal with positional ones first
8324 Formal := First_Formal (Ent);
8326 if Present (Expressions (Arg_Mechanism)) then
8327 Mname := First (Expressions (Arg_Mechanism));
8328 while Present (Mname) loop
8331 ("too many mechanism associations", Mname);
8334 Set_Mechanism_Value (Formal, Mname);
8335 Next_Formal (Formal);
8340 -- Deal with named entries
8342 if Present (Component_Associations (Arg_Mechanism)) then
8343 Massoc := First (Component_Associations (Arg_Mechanism));
8344 while Present (Massoc) loop
8345 Choice := First (Choices (Massoc));
8347 if Nkind (Choice) /= N_Identifier
8348 or else Present (Next (Choice))
8351 ("incorrect form for mechanism association",
8355 Formal := First_Formal (Ent);
8359 ("parameter name & not present", Choice);
8362 if Chars (Choice) = Chars (Formal) then
8364 (Formal, Expression (Massoc));
8366 -- Set entity on identifier (needed by ASIS)
8368 Set_Entity (Choice, Formal);
8373 Next_Formal (Formal);
8382 end Process_Extended_Import_Export_Subprogram_Pragma;
8384 --------------------------
8385 -- Process_Generic_List --
8386 --------------------------
8388 procedure Process_Generic_List is
8393 Check_No_Identifiers;
8394 Check_At_Least_N_Arguments (1);
8396 -- Check all arguments are names of generic units or instances
8399 while Present (Arg) loop
8400 Exp := Get_Pragma_Arg (Arg);
8403 if not Is_Entity_Name (Exp)
8405 (not Is_Generic_Instance (Entity (Exp))
8407 not Is_Generic_Unit (Entity (Exp)))
8410 ("pragma% argument must be name of generic unit/instance",
8416 end Process_Generic_List;
8418 ------------------------------------
8419 -- Process_Import_Predefined_Type --
8420 ------------------------------------
8422 procedure Process_Import_Predefined_Type is
8423 Loc : constant Source_Ptr := Sloc (N);
8425 Ftyp : Node_Id := Empty;
8431 Nam := String_To_Name (Strval (Expression (Arg3)));
8433 Elmt := First_Elmt (Predefined_Float_Types);
8434 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8438 Ftyp := Node (Elmt);
8440 if Present (Ftyp) then
8442 -- Don't build a derived type declaration, because predefined C
8443 -- types have no declaration anywhere, so cannot really be named.
8444 -- Instead build a full type declaration, starting with an
8445 -- appropriate type definition is built
8447 if Is_Floating_Point_Type (Ftyp) then
8448 Def := Make_Floating_Point_Definition (Loc,
8449 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8450 Make_Real_Range_Specification (Loc,
8451 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8452 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8454 -- Should never have a predefined type we cannot handle
8457 raise Program_Error;
8460 -- Build and insert a Full_Type_Declaration, which will be
8461 -- analyzed as soon as this list entry has been analyzed.
8463 Decl := Make_Full_Type_Declaration (Loc,
8464 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8465 Type_Definition => Def);
8467 Insert_After (N, Decl);
8468 Mark_Rewrite_Insertion (Decl);
8471 Error_Pragma_Arg ("no matching type found for pragma%",
8474 end Process_Import_Predefined_Type;
8476 ---------------------------------
8477 -- Process_Import_Or_Interface --
8478 ---------------------------------
8480 procedure Process_Import_Or_Interface is
8486 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8487 -- pragma Import (Entity, "external name");
8489 if Relaxed_RM_Semantics
8490 and then Arg_Count = 2
8491 and then Prag_Id = Pragma_Import
8492 and then Nkind (Expression (Arg2)) = N_String_Literal
8495 Def_Id := Get_Pragma_Arg (Arg1);
8498 if not Is_Entity_Name (Def_Id) then
8499 Error_Pragma_Arg ("entity name required", Arg1);
8502 Def_Id := Entity (Def_Id);
8503 Kill_Size_Check_Code (Def_Id);
8504 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8507 Process_Convention (C, Def_Id);
8509 -- A pragma that applies to a Ghost entity becomes Ghost for the
8510 -- purposes of legality checks and removal of ignored Ghost code.
8512 Mark_Ghost_Pragma (N, Def_Id);
8513 Kill_Size_Check_Code (Def_Id);
8514 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8517 -- Various error checks
8519 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8521 -- We do not permit Import to apply to a renaming declaration
8523 if Present (Renamed_Object (Def_Id)) then
8525 ("pragma% not allowed for object renaming", Arg2);
8527 -- User initialization is not allowed for imported object, but
8528 -- the object declaration may contain a default initialization,
8529 -- that will be discarded. Note that an explicit initialization
8530 -- only counts if it comes from source, otherwise it is simply
8531 -- the code generator making an implicit initialization explicit.
8533 elsif Present (Expression (Parent (Def_Id)))
8534 and then Comes_From_Source
8535 (Original_Node (Expression (Parent (Def_Id))))
8537 -- Set imported flag to prevent cascaded errors
8539 Set_Is_Imported (Def_Id);
8541 Error_Msg_Sloc := Sloc (Def_Id);
8543 ("no initialization allowed for declaration of& #",
8544 "\imported entities cannot be initialized (RM B.1(24))",
8548 -- If the pragma comes from an aspect specification the
8549 -- Is_Imported flag has already been set.
8551 if not From_Aspect_Specification (N) then
8552 Set_Imported (Def_Id);
8555 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8557 -- Note that we do not set Is_Public here. That's because we
8558 -- only want to set it if there is no address clause, and we
8559 -- don't know that yet, so we delay that processing till
8562 -- pragma Import completes deferred constants
8564 if Ekind (Def_Id) = E_Constant then
8565 Set_Has_Completion (Def_Id);
8568 -- It is not possible to import a constant of an unconstrained
8569 -- array type (e.g. string) because there is no simple way to
8570 -- write a meaningful subtype for it.
8572 if Is_Array_Type (Etype (Def_Id))
8573 and then not Is_Constrained (Etype (Def_Id))
8576 ("imported constant& must have a constrained subtype",
8581 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8583 -- If the name is overloaded, pragma applies to all of the denoted
8584 -- entities in the same declarative part, unless the pragma comes
8585 -- from an aspect specification or was generated by the compiler
8586 -- (such as for pragma Provide_Shift_Operators).
8589 while Present (Hom_Id) loop
8591 Def_Id := Get_Base_Subprogram (Hom_Id);
8593 -- Ignore inherited subprograms because the pragma will apply
8594 -- to the parent operation, which is the one called.
8596 if Is_Overloadable (Def_Id)
8597 and then Present (Alias (Def_Id))
8601 -- If it is not a subprogram, it must be in an outer scope and
8602 -- pragma does not apply.
8604 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8607 -- The pragma does not apply to primitives of interfaces
8609 elsif Is_Dispatching_Operation (Def_Id)
8610 and then Present (Find_Dispatching_Type (Def_Id))
8611 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8615 -- Verify that the homonym is in the same declarative part (not
8616 -- just the same scope). If the pragma comes from an aspect
8617 -- specification we know that it is part of the declaration.
8619 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8620 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8621 and then not From_Aspect_Specification (N)
8626 -- If the pragma comes from an aspect specification the
8627 -- Is_Imported flag has already been set.
8629 if not From_Aspect_Specification (N) then
8630 Set_Imported (Def_Id);
8633 -- Reject an Import applied to an abstract subprogram
8635 if Is_Subprogram (Def_Id)
8636 and then Is_Abstract_Subprogram (Def_Id)
8638 Error_Msg_Sloc := Sloc (Def_Id);
8640 ("cannot import abstract subprogram& declared#",
8644 -- Special processing for Convention_Intrinsic
8646 if C = Convention_Intrinsic then
8648 -- Link_Name argument not allowed for intrinsic
8652 Set_Is_Intrinsic_Subprogram (Def_Id);
8654 -- If no external name is present, then check that this
8655 -- is a valid intrinsic subprogram. If an external name
8656 -- is present, then this is handled by the back end.
8659 Check_Intrinsic_Subprogram
8660 (Def_Id, Get_Pragma_Arg (Arg2));
8664 -- Verify that the subprogram does not have a completion
8665 -- through a renaming declaration. For other completions the
8666 -- pragma appears as a too late representation.
8669 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8673 and then Nkind (Decl) = N_Subprogram_Declaration
8674 and then Present (Corresponding_Body (Decl))
8675 and then Nkind (Unit_Declaration_Node
8676 (Corresponding_Body (Decl))) =
8677 N_Subprogram_Renaming_Declaration
8679 Error_Msg_Sloc := Sloc (Def_Id);
8681 ("cannot import&, renaming already provided for "
8682 & "declaration #", N, Def_Id);
8686 -- If the pragma comes from an aspect specification, there
8687 -- must be an Import aspect specified as well. In the rare
8688 -- case where Import is set to False, the suprogram needs to
8689 -- have a local completion.
8692 Imp_Aspect : constant Node_Id :=
8693 Find_Aspect (Def_Id, Aspect_Import);
8697 if Present (Imp_Aspect)
8698 and then Present (Expression (Imp_Aspect))
8700 Expr := Expression (Imp_Aspect);
8701 Analyze_And_Resolve (Expr, Standard_Boolean);
8703 if Is_Entity_Name (Expr)
8704 and then Entity (Expr) = Standard_True
8706 Set_Has_Completion (Def_Id);
8709 -- If there is no expression, the default is True, as for
8710 -- all boolean aspects. Same for the older pragma.
8713 Set_Has_Completion (Def_Id);
8717 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
8720 if Is_Compilation_Unit (Hom_Id) then
8722 -- Its possible homonyms are not affected by the pragma.
8723 -- Such homonyms might be present in the context of other
8724 -- units being compiled.
8728 elsif From_Aspect_Specification (N) then
8731 -- If the pragma was created by the compiler, then we don't
8732 -- want it to apply to other homonyms. This kind of case can
8733 -- occur when using pragma Provide_Shift_Operators, which
8734 -- generates implicit shift and rotate operators with Import
8735 -- pragmas that might apply to earlier explicit or implicit
8736 -- declarations marked with Import (for example, coming from
8737 -- an earlier pragma Provide_Shift_Operators for another type),
8738 -- and we don't generally want other homonyms being treated
8739 -- as imported or the pragma flagged as an illegal duplicate.
8741 elsif not Comes_From_Source (N) then
8745 Hom_Id := Homonym (Hom_Id);
8749 -- Import a CPP class
8751 elsif C = Convention_CPP
8752 and then (Is_Record_Type (Def_Id)
8753 or else Ekind (Def_Id) = E_Incomplete_Type)
8755 if Ekind (Def_Id) = E_Incomplete_Type then
8756 if Present (Full_View (Def_Id)) then
8757 Def_Id := Full_View (Def_Id);
8761 ("cannot import 'C'P'P type before full declaration seen",
8762 Get_Pragma_Arg (Arg2));
8764 -- Although we have reported the error we decorate it as
8765 -- CPP_Class to avoid reporting spurious errors
8767 Set_Is_CPP_Class (Def_Id);
8772 -- Types treated as CPP classes must be declared limited (note:
8773 -- this used to be a warning but there is no real benefit to it
8774 -- since we did effectively intend to treat the type as limited
8777 if not Is_Limited_Type (Def_Id) then
8779 ("imported 'C'P'P type must be limited",
8780 Get_Pragma_Arg (Arg2));
8783 if Etype (Def_Id) /= Def_Id
8784 and then not Is_CPP_Class (Root_Type (Def_Id))
8786 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8789 Set_Is_CPP_Class (Def_Id);
8791 -- Imported CPP types must not have discriminants (because C++
8792 -- classes do not have discriminants).
8794 if Has_Discriminants (Def_Id) then
8796 ("imported 'C'P'P type cannot have discriminants",
8797 First (Discriminant_Specifications
8798 (Declaration_Node (Def_Id))));
8801 -- Check that components of imported CPP types do not have default
8802 -- expressions. For private types this check is performed when the
8803 -- full view is analyzed (see Process_Full_View).
8805 if not Is_Private_Type (Def_Id) then
8806 Check_CPP_Type_Has_No_Defaults (Def_Id);
8809 -- Import a CPP exception
8811 elsif C = Convention_CPP
8812 and then Ekind (Def_Id) = E_Exception
8816 ("'External_'Name arguments is required for 'Cpp exception",
8819 -- As only a string is allowed, Check_Arg_Is_External_Name
8822 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8825 if Present (Arg4) then
8827 ("Link_Name argument not allowed for imported Cpp exception",
8831 -- Do not call Set_Interface_Name as the name of the exception
8832 -- shouldn't be modified (and in particular it shouldn't be
8833 -- the External_Name). For exceptions, the External_Name is the
8834 -- name of the RTTI structure.
8836 -- ??? Emit an error if pragma Import/Export_Exception is present
8838 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8840 Check_Arg_Count (3);
8841 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8843 Process_Import_Predefined_Type;
8847 ("second argument of pragma% must be object, subprogram "
8848 & "or incomplete type",
8852 -- If this pragma applies to a compilation unit, then the unit, which
8853 -- is a subprogram, does not require (or allow) a body. We also do
8854 -- not need to elaborate imported procedures.
8856 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8858 Cunit : constant Node_Id := Parent (Parent (N));
8860 Set_Body_Required (Cunit, False);
8863 end Process_Import_Or_Interface;
8865 --------------------
8866 -- Process_Inline --
8867 --------------------
8869 procedure Process_Inline (Status : Inline_Status) is
8876 Ghost_Error_Posted : Boolean := False;
8877 -- Flag set when an error concerning the illegal mix of Ghost and
8878 -- non-Ghost subprograms is emitted.
8880 Ghost_Id : Entity_Id := Empty;
8881 -- The entity of the first Ghost subprogram encountered while
8882 -- processing the arguments of the pragma.
8884 procedure Make_Inline (Subp : Entity_Id);
8885 -- Subp is the defining unit name of the subprogram declaration. If
8886 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8887 -- the corresponding body, if there is one present.
8889 procedure Set_Inline_Flags (Subp : Entity_Id);
8890 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8891 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8893 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8894 -- Returns True if it can be determined at this stage that inlining
8895 -- is not possible, for example if the body is available and contains
8896 -- exception handlers, we prevent inlining, since otherwise we can
8897 -- get undefined symbols at link time. This function also emits a
8898 -- warning if the pragma appears too late.
8900 -- ??? is business with link symbols still valid, or does it relate
8901 -- to front end ZCX which is being phased out ???
8903 ---------------------------
8904 -- Inlining_Not_Possible --
8905 ---------------------------
8907 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8908 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8912 if Nkind (Decl) = N_Subprogram_Body then
8913 Stats := Handled_Statement_Sequence (Decl);
8914 return Present (Exception_Handlers (Stats))
8915 or else Present (At_End_Proc (Stats));
8917 elsif Nkind (Decl) = N_Subprogram_Declaration
8918 and then Present (Corresponding_Body (Decl))
8920 if Analyzed (Corresponding_Body (Decl)) then
8921 Error_Msg_N ("pragma appears too late, ignored??", N);
8924 -- If the subprogram is a renaming as body, the body is just a
8925 -- call to the renamed subprogram, and inlining is trivially
8929 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8930 N_Subprogram_Renaming_Declaration
8936 Handled_Statement_Sequence
8937 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8940 Present (Exception_Handlers (Stats))
8941 or else Present (At_End_Proc (Stats));
8945 -- If body is not available, assume the best, the check is
8946 -- performed again when compiling enclosing package bodies.
8950 end Inlining_Not_Possible;
8956 procedure Make_Inline (Subp : Entity_Id) is
8957 Kind : constant Entity_Kind := Ekind (Subp);
8958 Inner_Subp : Entity_Id := Subp;
8961 -- Ignore if bad type, avoid cascaded error
8963 if Etype (Subp) = Any_Type then
8967 -- If inlining is not possible, for now do not treat as an error
8969 elsif Status /= Suppressed
8970 and then Front_End_Inlining
8971 and then Inlining_Not_Possible (Subp)
8976 -- Here we have a candidate for inlining, but we must exclude
8977 -- derived operations. Otherwise we would end up trying to inline
8978 -- a phantom declaration, and the result would be to drag in a
8979 -- body which has no direct inlining associated with it. That
8980 -- would not only be inefficient but would also result in the
8981 -- backend doing cross-unit inlining in cases where it was
8982 -- definitely inappropriate to do so.
8984 -- However, a simple Comes_From_Source test is insufficient, since
8985 -- we do want to allow inlining of generic instances which also do
8986 -- not come from source. We also need to recognize specs generated
8987 -- by the front-end for bodies that carry the pragma. Finally,
8988 -- predefined operators do not come from source but are not
8989 -- inlineable either.
8991 elsif Is_Generic_Instance (Subp)
8992 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8996 elsif not Comes_From_Source (Subp)
8997 and then Scope (Subp) /= Standard_Standard
9003 -- The referenced entity must either be the enclosing entity, or
9004 -- an entity declared within the current open scope.
9006 if Present (Scope (Subp))
9007 and then Scope (Subp) /= Current_Scope
9008 and then Subp /= Current_Scope
9011 ("argument of% must be entity in current scope", Assoc);
9015 -- Processing for procedure, operator or function. If subprogram
9016 -- is aliased (as for an instance) indicate that the renamed
9017 -- entity (if declared in the same unit) is inlined.
9018 -- If this is the anonymous subprogram created for a subprogram
9019 -- instance, the inlining applies to it directly. Otherwise we
9020 -- retrieve it as the alias of the visible subprogram instance.
9022 if Is_Subprogram (Subp) then
9023 if Is_Wrapper_Package (Scope (Subp)) then
9026 Inner_Subp := Ultimate_Alias (Inner_Subp);
9029 if In_Same_Source_Unit (Subp, Inner_Subp) then
9030 Set_Inline_Flags (Inner_Subp);
9032 Decl := Parent (Parent (Inner_Subp));
9034 if Nkind (Decl) = N_Subprogram_Declaration
9035 and then Present (Corresponding_Body (Decl))
9037 Set_Inline_Flags (Corresponding_Body (Decl));
9039 elsif Is_Generic_Instance (Subp)
9040 and then Comes_From_Source (Subp)
9042 -- Indicate that the body needs to be created for
9043 -- inlining subsequent calls. The instantiation node
9044 -- follows the declaration of the wrapper package
9045 -- created for it. The subprogram that requires the
9046 -- body is the anonymous one in the wrapper package.
9048 if Scope (Subp) /= Standard_Standard
9050 Need_Subprogram_Instance_Body
9051 (Next (Unit_Declaration_Node
9052 (Scope (Alias (Subp)))), Subp)
9057 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9058 -- appear in a formal part to apply to a formal subprogram.
9059 -- Do not apply check within an instance or a formal package
9060 -- the test will have been applied to the original generic.
9062 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9063 and then List_Containing (Decl) = List_Containing (N)
9064 and then not In_Instance
9067 ("Inline cannot apply to a formal subprogram", N);
9069 -- If Subp is a renaming, it is the renamed entity that
9070 -- will appear in any call, and be inlined. However, for
9071 -- ASIS uses it is convenient to indicate that the renaming
9072 -- itself is an inlined subprogram, so that some gnatcheck
9073 -- rules can be applied in the absence of expansion.
9075 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9076 Set_Inline_Flags (Subp);
9082 -- For a generic subprogram set flag as well, for use at the point
9083 -- of instantiation, to determine whether the body should be
9086 elsif Is_Generic_Subprogram (Subp) then
9087 Set_Inline_Flags (Subp);
9090 -- Literals are by definition inlined
9092 elsif Kind = E_Enumeration_Literal then
9095 -- Anything else is an error
9099 ("expect subprogram name for pragma%", Assoc);
9103 ----------------------
9104 -- Set_Inline_Flags --
9105 ----------------------
9107 procedure Set_Inline_Flags (Subp : Entity_Id) is
9109 -- First set the Has_Pragma_XXX flags and issue the appropriate
9110 -- errors and warnings for suspicious combinations.
9112 if Prag_Id = Pragma_No_Inline then
9113 if Has_Pragma_Inline_Always (Subp) then
9115 ("Inline_Always and No_Inline are mutually exclusive", N);
9116 elsif Has_Pragma_Inline (Subp) then
9118 ("Inline and No_Inline both specified for& ??",
9119 N, Entity (Subp_Id));
9122 Set_Has_Pragma_No_Inline (Subp);
9124 if Prag_Id = Pragma_Inline_Always then
9125 if Has_Pragma_No_Inline (Subp) then
9127 ("Inline_Always and No_Inline are mutually exclusive",
9131 Set_Has_Pragma_Inline_Always (Subp);
9133 if Has_Pragma_No_Inline (Subp) then
9135 ("Inline and No_Inline both specified for& ??",
9136 N, Entity (Subp_Id));
9140 Set_Has_Pragma_Inline (Subp);
9143 -- Then adjust the Is_Inlined flag. It can never be set if the
9144 -- subprogram is subject to pragma No_Inline.
9148 Set_Is_Inlined (Subp, False);
9154 if not Has_Pragma_No_Inline (Subp) then
9155 Set_Is_Inlined (Subp, True);
9159 -- A pragma that applies to a Ghost entity becomes Ghost for the
9160 -- purposes of legality checks and removal of ignored Ghost code.
9162 Mark_Ghost_Pragma (N, Subp);
9164 -- Capture the entity of the first Ghost subprogram being
9165 -- processed for error detection purposes.
9167 if Is_Ghost_Entity (Subp) then
9168 if No (Ghost_Id) then
9172 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9173 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9175 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9176 Ghost_Error_Posted := True;
9178 Error_Msg_Name_1 := Pname;
9180 ("pragma % cannot mention ghost and non-ghost subprograms",
9183 Error_Msg_Sloc := Sloc (Ghost_Id);
9184 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9186 Error_Msg_Sloc := Sloc (Subp);
9187 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9189 end Set_Inline_Flags;
9191 -- Start of processing for Process_Inline
9194 Check_No_Identifiers;
9195 Check_At_Least_N_Arguments (1);
9197 if Status = Enabled then
9198 Inline_Processing_Required := True;
9202 while Present (Assoc) loop
9203 Subp_Id := Get_Pragma_Arg (Assoc);
9207 if Is_Entity_Name (Subp_Id) then
9208 Subp := Entity (Subp_Id);
9210 if Subp = Any_Id then
9212 -- If previous error, avoid cascaded errors
9214 Check_Error_Detected;
9220 -- For the pragma case, climb homonym chain. This is
9221 -- what implements allowing the pragma in the renaming
9222 -- case, with the result applying to the ancestors, and
9223 -- also allows Inline to apply to all previous homonyms.
9225 if not From_Aspect_Specification (N) then
9226 while Present (Homonym (Subp))
9227 and then Scope (Homonym (Subp)) = Current_Scope
9229 Make_Inline (Homonym (Subp));
9230 Subp := Homonym (Subp);
9237 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9243 -- If the context is a package declaration, the pragma indicates
9244 -- that inlining will require the presence of the corresponding
9245 -- body. (this may be further refined).
9248 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9249 N_Package_Declaration
9251 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9255 ----------------------------
9256 -- Process_Interface_Name --
9257 ----------------------------
9259 procedure Process_Interface_Name
9260 (Subprogram_Def : Entity_Id;
9267 String_Val : String_Id;
9269 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9270 -- SN is a string literal node for an interface name. This routine
9271 -- performs some minimal checks that the name is reasonable. In
9272 -- particular that no spaces or other obviously incorrect characters
9273 -- appear. This is only a warning, since any characters are allowed.
9275 ----------------------------------
9276 -- Check_Form_Of_Interface_Name --
9277 ----------------------------------
9279 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9280 S : constant String_Id := Strval (Expr_Value_S (SN));
9281 SL : constant Nat := String_Length (S);
9286 Error_Msg_N ("interface name cannot be null string", SN);
9289 for J in 1 .. SL loop
9290 C := Get_String_Char (S, J);
9292 -- Look for dubious character and issue unconditional warning.
9293 -- Definitely dubious if not in character range.
9295 if not In_Character_Range (C)
9297 -- Commas, spaces and (back)slashes are dubious
9299 or else Get_Character (C) = ','
9300 or else Get_Character (C) = '\'
9301 or else Get_Character (C) = ' '
9302 or else Get_Character (C) = '/'
9305 ("??interface name contains illegal character",
9306 Sloc (SN) + Source_Ptr (J));
9309 end Check_Form_Of_Interface_Name;
9311 -- Start of processing for Process_Interface_Name
9314 -- If we are looking at a pragma that comes from an aspect then it
9315 -- needs to have its corresponding aspect argument expressions
9316 -- analyzed in addition to the generated pragma so that aspects
9317 -- within generic units get properly resolved.
9319 if Present (Prag) and then From_Aspect_Specification (Prag) then
9321 Asp : constant Node_Id := Corresponding_Aspect (Prag);
9329 -- Obtain all interfacing aspects used to construct the pragma
9331 Get_Interfacing_Aspects
9332 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
9334 -- Analyze the expression of aspect External_Name
9336 if Present (EN) then
9337 Analyze (Expression (EN));
9340 -- Analyze the expressio of aspect Link_Name
9342 if Present (LN) then
9343 Analyze (Expression (LN));
9348 if No (Link_Arg) then
9349 if No (Ext_Arg) then
9352 elsif Chars (Ext_Arg) = Name_Link_Name then
9354 Link_Nam := Expression (Ext_Arg);
9357 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9358 Ext_Nam := Expression (Ext_Arg);
9363 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9364 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9365 Ext_Nam := Expression (Ext_Arg);
9366 Link_Nam := Expression (Link_Arg);
9369 -- Check expressions for external name and link name are static
9371 if Present (Ext_Nam) then
9372 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9373 Check_Form_Of_Interface_Name (Ext_Nam);
9375 -- Verify that external name is not the name of a local entity,
9376 -- which would hide the imported one and could lead to run-time
9377 -- surprises. The problem can only arise for entities declared in
9378 -- a package body (otherwise the external name is fully qualified
9379 -- and will not conflict).
9387 if Prag_Id = Pragma_Import then
9388 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
9389 E := Entity_Id (Get_Name_Table_Int (Nam));
9391 if Nam /= Chars (Subprogram_Def)
9392 and then Present (E)
9393 and then not Is_Overloadable (E)
9394 and then Is_Immediately_Visible (E)
9395 and then not Is_Imported (E)
9396 and then Ekind (Scope (E)) = E_Package
9399 while Present (Par) loop
9400 if Nkind (Par) = N_Package_Body then
9401 Error_Msg_Sloc := Sloc (E);
9403 ("imported entity is hidden by & declared#",
9408 Par := Parent (Par);
9415 if Present (Link_Nam) then
9416 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9417 Check_Form_Of_Interface_Name (Link_Nam);
9420 -- If there is no link name, just set the external name
9422 if No (Link_Nam) then
9423 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9425 -- For the Link_Name case, the given literal is preceded by an
9426 -- asterisk, which indicates to GCC that the given name should be
9427 -- taken literally, and in particular that no prepending of
9428 -- underlines should occur, even in systems where this is the
9433 Store_String_Char (Get_Char_Code ('*'));
9434 String_Val := Strval (Expr_Value_S (Link_Nam));
9435 Store_String_Chars (String_Val);
9437 Make_String_Literal (Sloc (Link_Nam),
9438 Strval => End_String);
9441 -- Set the interface name. If the entity is a generic instance, use
9442 -- its alias, which is the callable entity.
9444 if Is_Generic_Instance (Subprogram_Def) then
9445 Set_Encoded_Interface_Name
9446 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9448 Set_Encoded_Interface_Name
9449 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9452 Check_Duplicated_Export_Name (Link_Nam);
9453 end Process_Interface_Name;
9455 -----------------------------------------
9456 -- Process_Interrupt_Or_Attach_Handler --
9457 -----------------------------------------
9459 procedure Process_Interrupt_Or_Attach_Handler is
9460 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9461 Prot_Typ : constant Entity_Id := Scope (Handler);
9464 -- A pragma that applies to a Ghost entity becomes Ghost for the
9465 -- purposes of legality checks and removal of ignored Ghost code.
9467 Mark_Ghost_Pragma (N, Handler);
9468 Set_Is_Interrupt_Handler (Handler);
9470 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9472 Record_Rep_Item (Prot_Typ, N);
9474 -- Chain the pragma on the contract for completeness
9476 Add_Contract_Item (N, Handler);
9477 end Process_Interrupt_Or_Attach_Handler;
9479 --------------------------------------------------
9480 -- Process_Restrictions_Or_Restriction_Warnings --
9481 --------------------------------------------------
9483 -- Note: some of the simple identifier cases were handled in par-prag,
9484 -- but it is harmless (and more straightforward) to simply handle all
9485 -- cases here, even if it means we repeat a bit of work in some cases.
9487 procedure Process_Restrictions_Or_Restriction_Warnings
9491 R_Id : Restriction_Id;
9497 -- Ignore all Restrictions pragmas in CodePeer mode
9499 if CodePeer_Mode then
9503 Check_Ada_83_Warning;
9504 Check_At_Least_N_Arguments (1);
9505 Check_Valid_Configuration_Pragma;
9508 while Present (Arg) loop
9510 Expr := Get_Pragma_Arg (Arg);
9512 -- Case of no restriction identifier present
9514 if Id = No_Name then
9515 if Nkind (Expr) /= N_Identifier then
9517 ("invalid form for restriction", Arg);
9522 (Process_Restriction_Synonyms (Expr));
9524 if R_Id not in All_Boolean_Restrictions then
9525 Error_Msg_Name_1 := Pname;
9527 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9529 -- Check for possible misspelling
9531 for J in Restriction_Id loop
9533 Rnm : constant String := Restriction_Id'Image (J);
9536 Name_Buffer (1 .. Rnm'Length) := Rnm;
9537 Name_Len := Rnm'Length;
9538 Set_Casing (All_Lower_Case);
9540 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9543 (Source_Index (Current_Sem_Unit)));
9544 Error_Msg_String (1 .. Rnm'Length) :=
9545 Name_Buffer (1 .. Name_Len);
9546 Error_Msg_Strlen := Rnm'Length;
9547 Error_Msg_N -- CODEFIX
9548 ("\possible misspelling of ""~""",
9549 Get_Pragma_Arg (Arg));
9558 if Implementation_Restriction (R_Id) then
9559 Check_Restriction (No_Implementation_Restrictions, Arg);
9562 -- Special processing for No_Elaboration_Code restriction
9564 if R_Id = No_Elaboration_Code then
9566 -- Restriction is only recognized within a configuration
9567 -- pragma file, or within a unit of the main extended
9568 -- program. Note: the test for Main_Unit is needed to
9569 -- properly include the case of configuration pragma files.
9571 if not (Current_Sem_Unit = Main_Unit
9572 or else In_Extended_Main_Source_Unit (N))
9576 -- Don't allow in a subunit unless already specified in
9579 elsif Nkind (Parent (N)) = N_Compilation_Unit
9580 and then Nkind (Unit (Parent (N))) = N_Subunit
9581 and then not Restriction_Active (No_Elaboration_Code)
9584 ("invalid specification of ""No_Elaboration_Code""",
9587 ("\restriction cannot be specified in a subunit", N);
9589 ("\unless also specified in body or spec", N);
9592 -- If we accept a No_Elaboration_Code restriction, then it
9593 -- needs to be added to the configuration restriction set so
9594 -- that we get proper application to other units in the main
9595 -- extended source as required.
9598 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9602 -- If this is a warning, then set the warning unless we already
9603 -- have a real restriction active (we never want a warning to
9604 -- override a real restriction).
9607 if not Restriction_Active (R_Id) then
9608 Set_Restriction (R_Id, N);
9609 Restriction_Warnings (R_Id) := True;
9612 -- If real restriction case, then set it and make sure that the
9613 -- restriction warning flag is off, since a real restriction
9614 -- always overrides a warning.
9617 Set_Restriction (R_Id, N);
9618 Restriction_Warnings (R_Id) := False;
9621 -- Check for obsolescent restrictions in Ada 2005 mode
9624 and then Ada_Version >= Ada_2005
9625 and then (R_Id = No_Asynchronous_Control
9627 R_Id = No_Unchecked_Deallocation
9629 R_Id = No_Unchecked_Conversion)
9631 Check_Restriction (No_Obsolescent_Features, N);
9634 -- A very special case that must be processed here: pragma
9635 -- Restrictions (No_Exceptions) turns off all run-time
9636 -- checking. This is a bit dubious in terms of the formal
9637 -- language definition, but it is what is intended by RM
9638 -- H.4(12). Restriction_Warnings never affects generated code
9639 -- so this is done only in the real restriction case.
9641 -- Atomic_Synchronization is not a real check, so it is not
9642 -- affected by this processing).
9644 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9645 -- run-time checks in CodePeer and GNATprove modes: we want to
9646 -- generate checks for analysis purposes, as set respectively
9647 -- by -gnatC and -gnatd.F
9650 and then not (CodePeer_Mode or GNATprove_Mode)
9651 and then R_Id = No_Exceptions
9653 for J in Scope_Suppress.Suppress'Range loop
9654 if J /= Atomic_Synchronization then
9655 Scope_Suppress.Suppress (J) := True;
9660 -- Case of No_Dependence => unit-name. Note that the parser
9661 -- already made the necessary entry in the No_Dependence table.
9663 elsif Id = Name_No_Dependence then
9664 if not OK_No_Dependence_Unit_Name (Expr) then
9668 -- Case of No_Specification_Of_Aspect => aspect-identifier
9670 elsif Id = Name_No_Specification_Of_Aspect then
9675 if Nkind (Expr) /= N_Identifier then
9678 A_Id := Get_Aspect_Id (Chars (Expr));
9681 if A_Id = No_Aspect then
9682 Error_Pragma_Arg ("invalid restriction name", Arg);
9684 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9688 -- Case of No_Use_Of_Attribute => attribute-identifier
9690 elsif Id = Name_No_Use_Of_Attribute then
9691 if Nkind (Expr) /= N_Identifier
9692 or else not Is_Attribute_Name (Chars (Expr))
9694 Error_Msg_N ("unknown attribute name??", Expr);
9697 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9700 -- Case of No_Use_Of_Entity => fully-qualified-name
9702 elsif Id = Name_No_Use_Of_Entity then
9704 -- Restriction is only recognized within a configuration
9705 -- pragma file, or within a unit of the main extended
9706 -- program. Note: the test for Main_Unit is needed to
9707 -- properly include the case of configuration pragma files.
9709 if Current_Sem_Unit = Main_Unit
9710 or else In_Extended_Main_Source_Unit (N)
9712 if not OK_No_Dependence_Unit_Name (Expr) then
9713 Error_Msg_N ("wrong form for entity name", Expr);
9715 Set_Restriction_No_Use_Of_Entity
9716 (Expr, Warn, No_Profile);
9720 -- Case of No_Use_Of_Pragma => pragma-identifier
9722 elsif Id = Name_No_Use_Of_Pragma then
9723 if Nkind (Expr) /= N_Identifier
9724 or else not Is_Pragma_Name (Chars (Expr))
9726 Error_Msg_N ("unknown pragma name??", Expr);
9728 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9731 -- All other cases of restriction identifier present
9734 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9735 Analyze_And_Resolve (Expr, Any_Integer);
9737 if R_Id not in All_Parameter_Restrictions then
9739 ("invalid restriction parameter identifier", Arg);
9741 elsif not Is_OK_Static_Expression (Expr) then
9742 Flag_Non_Static_Expr
9743 ("value must be static expression!", Expr);
9746 elsif not Is_Integer_Type (Etype (Expr))
9747 or else Expr_Value (Expr) < 0
9750 ("value must be non-negative integer", Arg);
9753 -- Restriction pragma is active
9755 Val := Expr_Value (Expr);
9757 if not UI_Is_In_Int_Range (Val) then
9759 ("pragma ignored, value too large??", Arg);
9762 -- Warning case. If the real restriction is active, then we
9763 -- ignore the request, since warning never overrides a real
9764 -- restriction. Otherwise we set the proper warning. Note that
9765 -- this circuit sets the warning again if it is already set,
9766 -- which is what we want, since the constant may have changed.
9769 if not Restriction_Active (R_Id) then
9771 (R_Id, N, Integer (UI_To_Int (Val)));
9772 Restriction_Warnings (R_Id) := True;
9775 -- Real restriction case, set restriction and make sure warning
9776 -- flag is off since real restriction always overrides warning.
9779 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9780 Restriction_Warnings (R_Id) := False;
9786 end Process_Restrictions_Or_Restriction_Warnings;
9788 ---------------------------------
9789 -- Process_Suppress_Unsuppress --
9790 ---------------------------------
9792 -- Note: this procedure makes entries in the check suppress data
9793 -- structures managed by Sem. See spec of package Sem for full
9794 -- details on how we handle recording of check suppression.
9796 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9801 In_Package_Spec : constant Boolean :=
9802 Is_Package_Or_Generic_Package (Current_Scope)
9803 and then not In_Package_Body (Current_Scope);
9805 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9806 -- Used to suppress a single check on the given entity
9808 --------------------------------
9809 -- Suppress_Unsuppress_Echeck --
9810 --------------------------------
9812 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9814 -- Check for error of trying to set atomic synchronization for
9815 -- a non-atomic variable.
9817 if C = Atomic_Synchronization
9818 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9821 ("pragma & requires atomic type or variable",
9822 Pragma_Identifier (Original_Node (N)));
9825 Set_Checks_May_Be_Suppressed (E);
9827 if In_Package_Spec then
9828 Push_Global_Suppress_Stack_Entry
9831 Suppress => Suppress_Case);
9833 Push_Local_Suppress_Stack_Entry
9836 Suppress => Suppress_Case);
9839 -- If this is a first subtype, and the base type is distinct,
9840 -- then also set the suppress flags on the base type.
9842 if Is_First_Subtype (E) and then Etype (E) /= E then
9843 Suppress_Unsuppress_Echeck (Etype (E), C);
9845 end Suppress_Unsuppress_Echeck;
9847 -- Start of processing for Process_Suppress_Unsuppress
9850 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9851 -- on user code: we want to generate checks for analysis purposes, as
9852 -- set respectively by -gnatC and -gnatd.F
9854 if Comes_From_Source (N)
9855 and then (CodePeer_Mode or GNATprove_Mode)
9860 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9861 -- declarative part or a package spec (RM 11.5(5)).
9863 if not Is_Configuration_Pragma then
9864 Check_Is_In_Decl_Part_Or_Package_Spec;
9867 Check_At_Least_N_Arguments (1);
9868 Check_At_Most_N_Arguments (2);
9869 Check_No_Identifier (Arg1);
9870 Check_Arg_Is_Identifier (Arg1);
9872 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9874 if C = No_Check_Id then
9876 ("argument of pragma% is not valid check name", Arg1);
9879 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9881 if C = Elaboration_Check and then SPARK_Mode = On then
9883 ("Suppress of Elaboration_Check ignored in SPARK??",
9884 "\elaboration checking rules are statically enforced "
9885 & "(SPARK RM 7.7)", Arg1);
9888 -- One-argument case
9890 if Arg_Count = 1 then
9892 -- Make an entry in the local scope suppress table. This is the
9893 -- table that directly shows the current value of the scope
9894 -- suppress check for any check id value.
9896 if C = All_Checks then
9898 -- For All_Checks, we set all specific predefined checks with
9899 -- the exception of Elaboration_Check, which is handled
9900 -- specially because of not wanting All_Checks to have the
9901 -- effect of deactivating static elaboration order processing.
9902 -- Atomic_Synchronization is also not affected, since this is
9903 -- not a real check.
9905 for J in Scope_Suppress.Suppress'Range loop
9906 if J /= Elaboration_Check
9908 J /= Atomic_Synchronization
9910 Scope_Suppress.Suppress (J) := Suppress_Case;
9914 -- If not All_Checks, and predefined check, then set appropriate
9915 -- scope entry. Note that we will set Elaboration_Check if this
9916 -- is explicitly specified. Atomic_Synchronization is allowed
9917 -- only if internally generated and entity is atomic.
9919 elsif C in Predefined_Check_Id
9920 and then (not Comes_From_Source (N)
9921 or else C /= Atomic_Synchronization)
9923 Scope_Suppress.Suppress (C) := Suppress_Case;
9926 -- Also make an entry in the Local_Entity_Suppress table
9928 Push_Local_Suppress_Stack_Entry
9931 Suppress => Suppress_Case);
9933 -- Case of two arguments present, where the check is suppressed for
9934 -- a specified entity (given as the second argument of the pragma)
9937 -- This is obsolescent in Ada 2005 mode
9939 if Ada_Version >= Ada_2005 then
9940 Check_Restriction (No_Obsolescent_Features, Arg2);
9943 Check_Optional_Identifier (Arg2, Name_On);
9944 E_Id := Get_Pragma_Arg (Arg2);
9947 if not Is_Entity_Name (E_Id) then
9949 ("second argument of pragma% must be entity name", Arg2);
9958 -- A pragma that applies to a Ghost entity becomes Ghost for the
9959 -- purposes of legality checks and removal of ignored Ghost code.
9961 Mark_Ghost_Pragma (N, E);
9963 -- Enforce RM 11.5(7) which requires that for a pragma that
9964 -- appears within a package spec, the named entity must be
9965 -- within the package spec. We allow the package name itself
9966 -- to be mentioned since that makes sense, although it is not
9967 -- strictly allowed by 11.5(7).
9970 and then E /= Current_Scope
9971 and then Scope (E) /= Current_Scope
9974 ("entity in pragma% is not in package spec (RM 11.5(7))",
9978 -- Loop through homonyms. As noted below, in the case of a package
9979 -- spec, only homonyms within the package spec are considered.
9982 Suppress_Unsuppress_Echeck (E, C);
9984 if Is_Generic_Instance (E)
9985 and then Is_Subprogram (E)
9986 and then Present (Alias (E))
9988 Suppress_Unsuppress_Echeck (Alias (E), C);
9991 -- Move to next homonym if not aspect spec case
9993 exit when From_Aspect_Specification (N);
9997 -- If we are within a package specification, the pragma only
9998 -- applies to homonyms in the same scope.
10000 exit when In_Package_Spec
10001 and then Scope (E) /= Current_Scope;
10004 end Process_Suppress_Unsuppress;
10006 -------------------------------
10007 -- Record_Independence_Check --
10008 -------------------------------
10010 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10012 -- For GCC back ends the validation is done a priori
10014 if not AAMP_On_Target then
10018 Independence_Checks.Append ((N, E));
10019 end Record_Independence_Check;
10025 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10027 if Is_Imported (E) then
10029 ("cannot export entity& that was previously imported", Arg);
10031 elsif Present (Address_Clause (E))
10032 and then not Relaxed_RM_Semantics
10035 ("cannot export entity& that has an address clause", Arg);
10038 Set_Is_Exported (E);
10040 -- Generate a reference for entity explicitly, because the
10041 -- identifier may be overloaded and name resolution will not
10044 Generate_Reference (E, Arg);
10046 -- Deal with exporting non-library level entity
10048 if not Is_Library_Level_Entity (E) then
10050 -- Not allowed at all for subprograms
10052 if Is_Subprogram (E) then
10053 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10055 -- Otherwise set public and statically allocated
10059 Set_Is_Statically_Allocated (E);
10061 -- Warn if the corresponding W flag is set
10063 if Warn_On_Export_Import
10065 -- Only do this for something that was in the source. Not
10066 -- clear if this can be False now (there used for sure to be
10067 -- cases on some systems where it was False), but anyway the
10068 -- test is harmless if not needed, so it is retained.
10070 and then Comes_From_Source (Arg)
10073 ("?x?& has been made static as a result of Export",
10076 ("\?x?this usage is non-standard and non-portable",
10082 if Warn_On_Export_Import and then Is_Type (E) then
10083 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10086 if Warn_On_Export_Import and Inside_A_Generic then
10088 ("all instances of& will have the same external name?x?",
10093 ----------------------------------------------
10094 -- Set_Extended_Import_Export_External_Name --
10095 ----------------------------------------------
10097 procedure Set_Extended_Import_Export_External_Name
10098 (Internal_Ent : Entity_Id;
10099 Arg_External : Node_Id)
10101 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10102 New_Name : Node_Id;
10105 if No (Arg_External) then
10109 Check_Arg_Is_External_Name (Arg_External);
10111 if Nkind (Arg_External) = N_String_Literal then
10112 if String_Length (Strval (Arg_External)) = 0 then
10115 New_Name := Adjust_External_Name_Case (Arg_External);
10118 elsif Nkind (Arg_External) = N_Identifier then
10119 New_Name := Get_Default_External_Name (Arg_External);
10121 -- Check_Arg_Is_External_Name should let through only identifiers and
10122 -- string literals or static string expressions (which are folded to
10123 -- string literals).
10126 raise Program_Error;
10129 -- If we already have an external name set (by a prior normal Import
10130 -- or Export pragma), then the external names must match
10132 if Present (Interface_Name (Internal_Ent)) then
10134 -- Ignore mismatching names in CodePeer mode, to support some
10135 -- old compilers which would export the same procedure under
10136 -- different names, e.g:
10138 -- pragma Export_Procedure (P, "a");
10139 -- pragma Export_Procedure (P, "b");
10141 if CodePeer_Mode then
10145 Check_Matching_Internal_Names : declare
10146 S1 : constant String_Id := Strval (Old_Name);
10147 S2 : constant String_Id := Strval (New_Name);
10149 procedure Mismatch;
10150 pragma No_Return (Mismatch);
10151 -- Called if names do not match
10157 procedure Mismatch is
10159 Error_Msg_Sloc := Sloc (Old_Name);
10161 ("external name does not match that given #",
10165 -- Start of processing for Check_Matching_Internal_Names
10168 if String_Length (S1) /= String_Length (S2) then
10172 for J in 1 .. String_Length (S1) loop
10173 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10178 end Check_Matching_Internal_Names;
10180 -- Otherwise set the given name
10183 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10184 Check_Duplicated_Export_Name (New_Name);
10186 end Set_Extended_Import_Export_External_Name;
10192 procedure Set_Imported (E : Entity_Id) is
10194 -- Error message if already imported or exported
10196 if Is_Exported (E) or else Is_Imported (E) then
10198 -- Error if being set Exported twice
10200 if Is_Exported (E) then
10201 Error_Msg_NE ("entity& was previously exported", N, E);
10203 -- Ignore error in CodePeer mode where we treat all imported
10204 -- subprograms as unknown.
10206 elsif CodePeer_Mode then
10209 -- OK if Import/Interface case
10211 elsif Import_Interface_Present (N) then
10214 -- Error if being set Imported twice
10217 Error_Msg_NE ("entity& was previously imported", N, E);
10220 Error_Msg_Name_1 := Pname;
10222 ("\(pragma% applies to all previous entities)", N);
10224 Error_Msg_Sloc := Sloc (E);
10225 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10227 -- Here if not previously imported or exported, OK to import
10230 Set_Is_Imported (E);
10232 -- For subprogram, set Import_Pragma field
10234 if Is_Subprogram (E) then
10235 Set_Import_Pragma (E, N);
10238 -- If the entity is an object that is not at the library level,
10239 -- then it is statically allocated. We do not worry about objects
10240 -- with address clauses in this context since they are not really
10241 -- imported in the linker sense.
10244 and then not Is_Library_Level_Entity (E)
10245 and then No (Address_Clause (E))
10247 Set_Is_Statically_Allocated (E);
10254 -------------------------
10255 -- Set_Mechanism_Value --
10256 -------------------------
10258 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10259 -- analyzed, since it is semantic nonsense), so we get it in the exact
10260 -- form created by the parser.
10262 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10263 procedure Bad_Mechanism;
10264 pragma No_Return (Bad_Mechanism);
10265 -- Signal bad mechanism name
10267 -------------------------
10268 -- Bad_Mechanism_Value --
10269 -------------------------
10271 procedure Bad_Mechanism is
10273 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10276 -- Start of processing for Set_Mechanism_Value
10279 if Mechanism (Ent) /= Default_Mechanism then
10281 ("mechanism for & has already been set", Mech_Name, Ent);
10284 -- MECHANISM_NAME ::= value | reference
10286 if Nkind (Mech_Name) = N_Identifier then
10287 if Chars (Mech_Name) = Name_Value then
10288 Set_Mechanism (Ent, By_Copy);
10291 elsif Chars (Mech_Name) = Name_Reference then
10292 Set_Mechanism (Ent, By_Reference);
10295 elsif Chars (Mech_Name) = Name_Copy then
10297 ("bad mechanism name, Value assumed", Mech_Name);
10306 end Set_Mechanism_Value;
10308 --------------------------
10309 -- Set_Rational_Profile --
10310 --------------------------
10312 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10313 -- extension to the semantics of renaming declarations.
10315 procedure Set_Rational_Profile is
10317 Implicit_Packing := True;
10318 Overriding_Renamings := True;
10319 Use_VADS_Size := True;
10320 end Set_Rational_Profile;
10322 ---------------------------
10323 -- Set_Ravenscar_Profile --
10324 ---------------------------
10326 -- The tasks to be done here are
10328 -- Set required policies
10330 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10331 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10332 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10333 -- (For GNAT_Ravenscar_EDF profile)
10334 -- pragma Locking_Policy (Ceiling_Locking)
10336 -- Set Detect_Blocking mode
10338 -- Set required restrictions (see System.Rident for detailed list)
10340 -- Set the No_Dependence rules
10341 -- No_Dependence => Ada.Asynchronous_Task_Control
10342 -- No_Dependence => Ada.Calendar
10343 -- No_Dependence => Ada.Execution_Time.Group_Budget
10344 -- No_Dependence => Ada.Execution_Time.Timers
10345 -- No_Dependence => Ada.Task_Attributes
10346 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10348 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10349 procedure Set_Error_Msg_To_Profile_Name;
10350 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10353 -----------------------------------
10354 -- Set_Error_Msg_To_Profile_Name --
10355 -----------------------------------
10357 procedure Set_Error_Msg_To_Profile_Name is
10358 Prof_Nam : constant Node_Id :=
10360 (First (Pragma_Argument_Associations (N)));
10363 Get_Name_String (Chars (Prof_Nam));
10364 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10365 Error_Msg_Strlen := Name_Len;
10366 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10367 end Set_Error_Msg_To_Profile_Name;
10376 Profile_Dispatching_Policy : Character;
10378 -- Start of processing for Set_Ravenscar_Profile
10381 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10383 if Profile = GNAT_Ravenscar_EDF then
10384 Profile_Dispatching_Policy := 'E';
10386 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10389 Profile_Dispatching_Policy := 'F';
10392 if Task_Dispatching_Policy /= ' '
10393 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
10395 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10396 Set_Error_Msg_To_Profile_Name;
10397 Error_Pragma ("Profile (~) incompatible with policy#");
10399 -- Set the FIFO_Within_Priorities policy, but always preserve
10400 -- System_Location since we like the error message with the run time
10404 Task_Dispatching_Policy := Profile_Dispatching_Policy;
10406 if Task_Dispatching_Policy_Sloc /= System_Location then
10407 Task_Dispatching_Policy_Sloc := Loc;
10411 -- pragma Locking_Policy (Ceiling_Locking)
10413 if Locking_Policy /= ' '
10414 and then Locking_Policy /= 'C'
10416 Error_Msg_Sloc := Locking_Policy_Sloc;
10417 Set_Error_Msg_To_Profile_Name;
10418 Error_Pragma ("Profile (~) incompatible with policy#");
10420 -- Set the Ceiling_Locking policy, but preserve System_Location since
10421 -- we like the error message with the run time name.
10424 Locking_Policy := 'C';
10426 if Locking_Policy_Sloc /= System_Location then
10427 Locking_Policy_Sloc := Loc;
10431 -- pragma Detect_Blocking
10433 Detect_Blocking := True;
10435 -- Set the corresponding restrictions
10437 Set_Profile_Restrictions
10438 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10440 -- Set the No_Dependence restrictions
10442 -- The following No_Dependence restrictions:
10443 -- No_Dependence => Ada.Asynchronous_Task_Control
10444 -- No_Dependence => Ada.Calendar
10445 -- No_Dependence => Ada.Task_Attributes
10446 -- are already set by previous call to Set_Profile_Restrictions.
10448 -- Set the following restrictions which were added to Ada 2005:
10449 -- No_Dependence => Ada.Execution_Time.Group_Budget
10450 -- No_Dependence => Ada.Execution_Time.Timers
10452 if Ada_Version >= Ada_2005 then
10453 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
10454 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
10457 Make_Selected_Component
10460 Selector_Name => Sel_Id);
10462 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
10465 Make_Selected_Component
10468 Selector_Name => Sel_Id);
10470 Set_Restriction_No_Dependence
10472 Warn => Treat_Restrictions_As_Warnings,
10473 Profile => Ravenscar);
10475 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
10478 Make_Selected_Component
10481 Selector_Name => Sel_Id);
10483 Set_Restriction_No_Dependence
10485 Warn => Treat_Restrictions_As_Warnings,
10486 Profile => Ravenscar);
10489 -- Set the following restriction which was added to Ada 2012 (see
10491 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10493 if Ada_Version >= Ada_2012 then
10494 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
10495 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
10498 Make_Selected_Component
10501 Selector_Name => Sel_Id);
10503 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
10506 Make_Selected_Component
10509 Selector_Name => Sel_Id);
10511 Set_Restriction_No_Dependence
10513 Warn => Treat_Restrictions_As_Warnings,
10514 Profile => Ravenscar);
10516 end Set_Ravenscar_Profile;
10518 -- Start of processing for Analyze_Pragma
10521 -- The following code is a defense against recursion. Not clear that
10522 -- this can happen legitimately, but perhaps some error situations can
10523 -- cause it, and we did see this recursion during testing.
10525 if Analyzed (N) then
10531 Check_Restriction_No_Use_Of_Pragma (N);
10533 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10534 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10536 if Should_Ignore_Pragma_Sem (N)
10537 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
10538 and then Ignore_Rep_Clauses)
10543 -- Deal with unrecognized pragma
10545 if not Is_Pragma_Name (Pname) then
10546 if Warn_On_Unrecognized_Pragma then
10547 Error_Msg_Name_1 := Pname;
10548 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10550 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10551 if Is_Bad_Spelling_Of (Pname, PN) then
10552 Error_Msg_Name_1 := PN;
10553 Error_Msg_N -- CODEFIX
10554 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10563 -- Here to start processing for recognized pragma
10565 Pname := Original_Aspect_Pragma_Name (N);
10567 -- Capture setting of Opt.Uneval_Old
10569 case Opt.Uneval_Old is
10571 Set_Uneval_Old_Accept (N);
10577 Set_Uneval_Old_Warn (N);
10580 raise Program_Error;
10583 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10584 -- is already set, indicating that we have already checked the policy
10585 -- at the right point. This happens for example in the case of a pragma
10586 -- that is derived from an Aspect.
10588 if Is_Ignored (N) or else Is_Checked (N) then
10591 -- For a pragma that is a rewriting of another pragma, copy the
10592 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10594 elsif Is_Rewrite_Substitution (N)
10595 and then Nkind (Original_Node (N)) = N_Pragma
10596 and then Original_Node (N) /= N
10598 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10599 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10601 -- Otherwise query the applicable policy at this point
10604 Check_Applicable_Policy (N);
10606 -- If pragma is disabled, rewrite as NULL and skip analysis
10608 if Is_Disabled (N) then
10609 Rewrite (N, Make_Null_Statement (Loc));
10615 -- Preset arguments
10623 if Present (Pragma_Argument_Associations (N)) then
10624 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10625 Arg1 := First (Pragma_Argument_Associations (N));
10627 if Present (Arg1) then
10628 Arg2 := Next (Arg1);
10630 if Present (Arg2) then
10631 Arg3 := Next (Arg2);
10633 if Present (Arg3) then
10634 Arg4 := Next (Arg3);
10640 -- An enumeration type defines the pragmas that are supported by the
10641 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10642 -- into the corresponding enumeration value for the following case.
10650 -- pragma Abort_Defer;
10652 when Pragma_Abort_Defer =>
10654 Check_Arg_Count (0);
10656 -- The only required semantic processing is to check the
10657 -- placement. This pragma must appear at the start of the
10658 -- statement sequence of a handled sequence of statements.
10660 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10661 or else N /= First (Statements (Parent (N)))
10666 --------------------
10667 -- Abstract_State --
10668 --------------------
10670 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10672 -- ABSTRACT_STATE_LIST ::=
10674 -- | STATE_NAME_WITH_OPTIONS
10675 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10677 -- STATE_NAME_WITH_OPTIONS ::=
10679 -- | (STATE_NAME with OPTION_LIST)
10681 -- OPTION_LIST ::= OPTION {, OPTION}
10685 -- | NAME_VALUE_OPTION
10687 -- SIMPLE_OPTION ::= Ghost | Synchronous
10689 -- NAME_VALUE_OPTION ::=
10690 -- Part_Of => ABSTRACT_STATE
10691 -- | External [=> EXTERNAL_PROPERTY_LIST]
10693 -- EXTERNAL_PROPERTY_LIST ::=
10694 -- EXTERNAL_PROPERTY
10695 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10697 -- EXTERNAL_PROPERTY ::=
10698 -- Async_Readers [=> boolean_EXPRESSION]
10699 -- | Async_Writers [=> boolean_EXPRESSION]
10700 -- | Effective_Reads [=> boolean_EXPRESSION]
10701 -- | Effective_Writes [=> boolean_EXPRESSION]
10702 -- others => boolean_EXPRESSION
10704 -- STATE_NAME ::= defining_identifier
10706 -- ABSTRACT_STATE ::= name
10708 -- Characteristics:
10710 -- * Analysis - The annotation is fully analyzed immediately upon
10711 -- elaboration as it cannot forward reference entities.
10713 -- * Expansion - None.
10715 -- * Template - The annotation utilizes the generic template of the
10716 -- related package declaration.
10718 -- * Globals - The annotation cannot reference global entities.
10720 -- * Instance - The annotation is instantiated automatically when
10721 -- the related generic package is instantiated.
10723 when Pragma_Abstract_State => Abstract_State : declare
10724 Missing_Parentheses : Boolean := False;
10725 -- Flag set when a state declaration with options is not properly
10728 -- Flags used to verify the consistency of states
10730 Non_Null_Seen : Boolean := False;
10731 Null_Seen : Boolean := False;
10733 procedure Analyze_Abstract_State
10735 Pack_Id : Entity_Id);
10736 -- Verify the legality of a single state declaration. Create and
10737 -- decorate a state abstraction entity and introduce it into the
10738 -- visibility chain. Pack_Id denotes the entity or the related
10739 -- package where pragma Abstract_State appears.
10741 procedure Malformed_State_Error (State : Node_Id);
10742 -- Emit an error concerning the illegal declaration of abstract
10743 -- state State. This routine diagnoses syntax errors that lead to
10744 -- a different parse tree. The error is issued regardless of the
10745 -- SPARK mode in effect.
10747 ----------------------------
10748 -- Analyze_Abstract_State --
10749 ----------------------------
10751 procedure Analyze_Abstract_State
10753 Pack_Id : Entity_Id)
10755 -- Flags used to verify the consistency of options
10757 AR_Seen : Boolean := False;
10758 AW_Seen : Boolean := False;
10759 ER_Seen : Boolean := False;
10760 EW_Seen : Boolean := False;
10761 External_Seen : Boolean := False;
10762 Ghost_Seen : Boolean := False;
10763 Others_Seen : Boolean := False;
10764 Part_Of_Seen : Boolean := False;
10765 Synchronous_Seen : Boolean := False;
10767 -- Flags used to store the static value of all external states'
10770 AR_Val : Boolean := False;
10771 AW_Val : Boolean := False;
10772 ER_Val : Boolean := False;
10773 EW_Val : Boolean := False;
10775 State_Id : Entity_Id := Empty;
10776 -- The entity to be generated for the current state declaration
10778 procedure Analyze_External_Option (Opt : Node_Id);
10779 -- Verify the legality of option External
10781 procedure Analyze_External_Property
10783 Expr : Node_Id := Empty);
10784 -- Verify the legailty of a single external property. Prop
10785 -- denotes the external property. Expr is the expression used
10786 -- to set the property.
10788 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10789 -- Verify the legality of option Part_Of
10791 procedure Check_Duplicate_Option
10793 Status : in out Boolean);
10794 -- Flag Status denotes whether a particular option has been
10795 -- seen while processing a state. This routine verifies that
10796 -- Opt is not a duplicate option and sets the flag Status
10797 -- (SPARK RM 7.1.4(1)).
10799 procedure Check_Duplicate_Property
10801 Status : in out Boolean);
10802 -- Flag Status denotes whether a particular property has been
10803 -- seen while processing option External. This routine verifies
10804 -- that Prop is not a duplicate property and sets flag Status.
10805 -- Opt is not a duplicate property and sets the flag Status.
10806 -- (SPARK RM 7.1.4(2))
10808 procedure Check_Ghost_Synchronous;
10809 -- Ensure that the abstract state is not subject to both Ghost
10810 -- and Synchronous simple options. Emit an error if this is the
10813 procedure Create_Abstract_State
10817 Is_Null : Boolean);
10818 -- Generate an abstract state entity with name Nam and enter it
10819 -- into visibility. Decl is the "declaration" of the state as
10820 -- it appears in pragma Abstract_State. Loc is the location of
10821 -- the related state "declaration". Flag Is_Null should be set
10822 -- when the associated Abstract_State pragma defines a null
10825 -----------------------------
10826 -- Analyze_External_Option --
10827 -----------------------------
10829 procedure Analyze_External_Option (Opt : Node_Id) is
10830 Errors : constant Nat := Serious_Errors_Detected;
10832 Props : Node_Id := Empty;
10835 if Nkind (Opt) = N_Component_Association then
10836 Props := Expression (Opt);
10839 -- External state with properties
10841 if Present (Props) then
10843 -- Multiple properties appear as an aggregate
10845 if Nkind (Props) = N_Aggregate then
10847 -- Simple property form
10849 Prop := First (Expressions (Props));
10850 while Present (Prop) loop
10851 Analyze_External_Property (Prop);
10855 -- Property with expression form
10857 Prop := First (Component_Associations (Props));
10858 while Present (Prop) loop
10859 Analyze_External_Property
10860 (Prop => First (Choices (Prop)),
10861 Expr => Expression (Prop));
10869 Analyze_External_Property (Props);
10872 -- An external state defined without any properties defaults
10873 -- all properties to True.
10882 -- Once all external properties have been processed, verify
10883 -- their mutual interaction. Do not perform the check when
10884 -- at least one of the properties is illegal as this will
10885 -- produce a bogus error.
10887 if Errors = Serious_Errors_Detected then
10888 Check_External_Properties
10889 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10891 end Analyze_External_Option;
10893 -------------------------------
10894 -- Analyze_External_Property --
10895 -------------------------------
10897 procedure Analyze_External_Property
10899 Expr : Node_Id := Empty)
10901 Expr_Val : Boolean;
10904 -- Check the placement of "others" (if available)
10906 if Nkind (Prop) = N_Others_Choice then
10907 if Others_Seen then
10909 ("only one others choice allowed in option External",
10912 Others_Seen := True;
10915 elsif Others_Seen then
10917 ("others must be the last property in option External",
10920 -- The only remaining legal options are the four predefined
10921 -- external properties.
10923 elsif Nkind (Prop) = N_Identifier
10924 and then Nam_In (Chars (Prop), Name_Async_Readers,
10925 Name_Async_Writers,
10926 Name_Effective_Reads,
10927 Name_Effective_Writes)
10931 -- Otherwise the construct is not a valid property
10934 SPARK_Msg_N ("invalid external state property", Prop);
10938 -- Ensure that the expression of the external state property
10939 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10941 if Present (Expr) then
10942 Analyze_And_Resolve (Expr, Standard_Boolean);
10944 if Is_OK_Static_Expression (Expr) then
10945 Expr_Val := Is_True (Expr_Value (Expr));
10948 ("expression of external state property must be "
10952 -- The lack of expression defaults the property to True
10958 -- Named properties
10960 if Nkind (Prop) = N_Identifier then
10961 if Chars (Prop) = Name_Async_Readers then
10962 Check_Duplicate_Property (Prop, AR_Seen);
10963 AR_Val := Expr_Val;
10965 elsif Chars (Prop) = Name_Async_Writers then
10966 Check_Duplicate_Property (Prop, AW_Seen);
10967 AW_Val := Expr_Val;
10969 elsif Chars (Prop) = Name_Effective_Reads then
10970 Check_Duplicate_Property (Prop, ER_Seen);
10971 ER_Val := Expr_Val;
10974 Check_Duplicate_Property (Prop, EW_Seen);
10975 EW_Val := Expr_Val;
10978 -- The handling of property "others" must take into account
10979 -- all other named properties that have been encountered so
10980 -- far. Only those that have not been seen are affected by
10984 if not AR_Seen then
10985 AR_Val := Expr_Val;
10988 if not AW_Seen then
10989 AW_Val := Expr_Val;
10992 if not ER_Seen then
10993 ER_Val := Expr_Val;
10996 if not EW_Seen then
10997 EW_Val := Expr_Val;
11000 end Analyze_External_Property;
11002 ----------------------------
11003 -- Analyze_Part_Of_Option --
11004 ----------------------------
11006 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11007 Encap : constant Node_Id := Expression (Opt);
11008 Constits : Elist_Id;
11009 Encap_Id : Entity_Id;
11013 Check_Duplicate_Option (Opt, Part_Of_Seen);
11016 (Indic => First (Choices (Opt)),
11017 Item_Id => State_Id,
11019 Encap_Id => Encap_Id,
11022 -- The Part_Of indicator transforms the abstract state into
11023 -- a constituent of the encapsulating state or single
11024 -- concurrent type.
11027 pragma Assert (Present (Encap_Id));
11028 Constits := Part_Of_Constituents (Encap_Id);
11030 if No (Constits) then
11031 Constits := New_Elmt_List;
11032 Set_Part_Of_Constituents (Encap_Id, Constits);
11035 Append_Elmt (State_Id, Constits);
11036 Set_Encapsulating_State (State_Id, Encap_Id);
11038 end Analyze_Part_Of_Option;
11040 ----------------------------
11041 -- Check_Duplicate_Option --
11042 ----------------------------
11044 procedure Check_Duplicate_Option
11046 Status : in out Boolean)
11050 SPARK_Msg_N ("duplicate state option", Opt);
11054 end Check_Duplicate_Option;
11056 ------------------------------
11057 -- Check_Duplicate_Property --
11058 ------------------------------
11060 procedure Check_Duplicate_Property
11062 Status : in out Boolean)
11066 SPARK_Msg_N ("duplicate external property", Prop);
11070 end Check_Duplicate_Property;
11072 -----------------------------
11073 -- Check_Ghost_Synchronous --
11074 -----------------------------
11076 procedure Check_Ghost_Synchronous is
11078 -- A synchronized abstract state cannot be Ghost and vice
11079 -- versa (SPARK RM 6.9(19)).
11081 if Ghost_Seen and Synchronous_Seen then
11082 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11084 end Check_Ghost_Synchronous;
11086 ---------------------------
11087 -- Create_Abstract_State --
11088 ---------------------------
11090 procedure Create_Abstract_State
11097 -- The abstract state may be semi-declared when the related
11098 -- package was withed through a limited with clause. In that
11099 -- case reuse the entity to fully declare the state.
11101 if Present (Decl) and then Present (Entity (Decl)) then
11102 State_Id := Entity (Decl);
11104 -- Otherwise the elaboration of pragma Abstract_State
11105 -- declares the state.
11108 State_Id := Make_Defining_Identifier (Loc, Nam);
11110 if Present (Decl) then
11111 Set_Entity (Decl, State_Id);
11115 -- Null states never come from source
11117 Set_Comes_From_Source (State_Id, not Is_Null);
11118 Set_Parent (State_Id, State);
11119 Set_Ekind (State_Id, E_Abstract_State);
11120 Set_Etype (State_Id, Standard_Void_Type);
11121 Set_Encapsulating_State (State_Id, Empty);
11123 -- An abstract state declared within a Ghost region becomes
11124 -- Ghost (SPARK RM 6.9(2)).
11126 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11127 Set_Is_Ghost_Entity (State_Id);
11130 -- Establish a link between the state declaration and the
11131 -- abstract state entity. Note that a null state remains as
11132 -- N_Null and does not carry any linkages.
11134 if not Is_Null then
11135 if Present (Decl) then
11136 Set_Entity (Decl, State_Id);
11137 Set_Etype (Decl, Standard_Void_Type);
11140 -- Every non-null state must be defined, nameable and
11143 Push_Scope (Pack_Id);
11144 Generate_Definition (State_Id);
11145 Enter_Name (State_Id);
11148 end Create_Abstract_State;
11155 -- Start of processing for Analyze_Abstract_State
11158 -- A package with a null abstract state is not allowed to
11159 -- declare additional states.
11163 ("package & has null abstract state", State, Pack_Id);
11165 -- Null states appear as internally generated entities
11167 elsif Nkind (State) = N_Null then
11168 Create_Abstract_State
11169 (Nam => New_Internal_Name ('S'),
11171 Loc => Sloc (State),
11175 -- Catch a case where a null state appears in a list of
11176 -- non-null states.
11178 if Non_Null_Seen then
11180 ("package & has non-null abstract state",
11184 -- Simple state declaration
11186 elsif Nkind (State) = N_Identifier then
11187 Create_Abstract_State
11188 (Nam => Chars (State),
11190 Loc => Sloc (State),
11192 Non_Null_Seen := True;
11194 -- State declaration with various options. This construct
11195 -- appears as an extension aggregate in the tree.
11197 elsif Nkind (State) = N_Extension_Aggregate then
11198 if Nkind (Ancestor_Part (State)) = N_Identifier then
11199 Create_Abstract_State
11200 (Nam => Chars (Ancestor_Part (State)),
11201 Decl => Ancestor_Part (State),
11202 Loc => Sloc (Ancestor_Part (State)),
11204 Non_Null_Seen := True;
11207 ("state name must be an identifier",
11208 Ancestor_Part (State));
11211 -- Options External, Ghost and Synchronous appear as
11214 Opt := First (Expressions (State));
11215 while Present (Opt) loop
11216 if Nkind (Opt) = N_Identifier then
11220 if Chars (Opt) = Name_External then
11221 Check_Duplicate_Option (Opt, External_Seen);
11222 Analyze_External_Option (Opt);
11226 elsif Chars (Opt) = Name_Ghost then
11227 Check_Duplicate_Option (Opt, Ghost_Seen);
11228 Check_Ghost_Synchronous;
11230 if Present (State_Id) then
11231 Set_Is_Ghost_Entity (State_Id);
11236 elsif Chars (Opt) = Name_Synchronous then
11237 Check_Duplicate_Option (Opt, Synchronous_Seen);
11238 Check_Ghost_Synchronous;
11240 -- Option Part_Of without an encapsulating state is
11241 -- illegal (SPARK RM 7.1.4(9)).
11243 elsif Chars (Opt) = Name_Part_Of then
11245 ("indicator Part_Of must denote abstract state, "
11246 & "single protected type or single task type",
11249 -- Do not emit an error message when a previous state
11250 -- declaration with options was not parenthesized as
11251 -- the option is actually another state declaration.
11253 -- with Abstract_State
11254 -- (State_1 with ..., -- missing parentheses
11255 -- (State_2 with ...),
11256 -- State_3) -- ok state declaration
11258 elsif Missing_Parentheses then
11261 -- Otherwise the option is not allowed. Note that it
11262 -- is not possible to distinguish between an option
11263 -- and a state declaration when a previous state with
11264 -- options not properly parentheses.
11266 -- with Abstract_State
11267 -- (State_1 with ..., -- missing parentheses
11268 -- State_2); -- could be an option
11272 ("simple option not allowed in state declaration",
11276 -- Catch a case where missing parentheses around a state
11277 -- declaration with options cause a subsequent state
11278 -- declaration with options to be treated as an option.
11280 -- with Abstract_State
11281 -- (State_1 with ..., -- missing parentheses
11282 -- (State_2 with ...))
11284 elsif Nkind (Opt) = N_Extension_Aggregate then
11285 Missing_Parentheses := True;
11287 ("state declaration must be parenthesized",
11288 Ancestor_Part (State));
11290 -- Otherwise the option is malformed
11293 SPARK_Msg_N ("malformed option", Opt);
11299 -- Options External and Part_Of appear as component
11302 Opt := First (Component_Associations (State));
11303 while Present (Opt) loop
11304 Opt_Nam := First (Choices (Opt));
11306 if Nkind (Opt_Nam) = N_Identifier then
11307 if Chars (Opt_Nam) = Name_External then
11308 Analyze_External_Option (Opt);
11310 elsif Chars (Opt_Nam) = Name_Part_Of then
11311 Analyze_Part_Of_Option (Opt);
11314 SPARK_Msg_N ("invalid state option", Opt);
11317 SPARK_Msg_N ("invalid state option", Opt);
11323 -- Any other attempt to declare a state is illegal
11326 Malformed_State_Error (State);
11330 -- Guard against a junk state. In such cases no entity is
11331 -- generated and the subsequent checks cannot be applied.
11333 if Present (State_Id) then
11335 -- Verify whether the state does not introduce an illegal
11336 -- hidden state within a package subject to a null abstract
11339 Check_No_Hidden_State (State_Id);
11341 -- Check whether the lack of option Part_Of agrees with the
11342 -- placement of the abstract state with respect to the state
11345 if not Part_Of_Seen then
11346 Check_Missing_Part_Of (State_Id);
11349 -- Associate the state with its related package
11351 if No (Abstract_States (Pack_Id)) then
11352 Set_Abstract_States (Pack_Id, New_Elmt_List);
11355 Append_Elmt (State_Id, Abstract_States (Pack_Id));
11357 end Analyze_Abstract_State;
11359 ---------------------------
11360 -- Malformed_State_Error --
11361 ---------------------------
11363 procedure Malformed_State_Error (State : Node_Id) is
11365 Error_Msg_N ("malformed abstract state declaration", State);
11367 -- An abstract state with a simple option is being declared
11368 -- with "=>" rather than the legal "with". The state appears
11369 -- as a component association.
11371 if Nkind (State) = N_Component_Association then
11372 Error_Msg_N ("\use WITH to specify simple option", State);
11374 end Malformed_State_Error;
11378 Pack_Decl : Node_Id;
11379 Pack_Id : Entity_Id;
11383 -- Start of processing for Abstract_State
11387 Check_No_Identifiers;
11388 Check_Arg_Count (1);
11390 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11392 -- Ensure the proper placement of the pragma. Abstract states must
11393 -- be associated with a package declaration.
11395 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11396 N_Package_Declaration)
11400 -- Otherwise the pragma is associated with an illegal construct
11407 Pack_Id := Defining_Entity (Pack_Decl);
11409 -- A pragma that applies to a Ghost entity becomes Ghost for the
11410 -- purposes of legality checks and removal of ignored Ghost code.
11412 Mark_Ghost_Pragma (N, Pack_Id);
11413 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11415 -- Chain the pragma on the contract for completeness
11417 Add_Contract_Item (N, Pack_Id);
11419 -- The legality checks of pragmas Abstract_State, Initializes, and
11420 -- Initial_Condition are affected by the SPARK mode in effect. In
11421 -- addition, these three pragmas are subject to an inherent order:
11423 -- 1) Abstract_State
11425 -- 3) Initial_Condition
11427 -- Analyze all these pragmas in the order outlined above
11429 Analyze_If_Present (Pragma_SPARK_Mode);
11430 States := Expression (Get_Argument (N, Pack_Id));
11432 -- Multiple non-null abstract states appear as an aggregate
11434 if Nkind (States) = N_Aggregate then
11435 State := First (Expressions (States));
11436 while Present (State) loop
11437 Analyze_Abstract_State (State, Pack_Id);
11441 -- An abstract state with a simple option is being illegaly
11442 -- declared with "=>" rather than "with". In this case the
11443 -- state declaration appears as a component association.
11445 if Present (Component_Associations (States)) then
11446 State := First (Component_Associations (States));
11447 while Present (State) loop
11448 Malformed_State_Error (State);
11453 -- Various forms of a single abstract state. Note that these may
11454 -- include malformed state declarations.
11457 Analyze_Abstract_State (States, Pack_Id);
11460 Analyze_If_Present (Pragma_Initializes);
11461 Analyze_If_Present (Pragma_Initial_Condition);
11462 end Abstract_State;
11470 -- Note: this pragma also has some specific processing in Par.Prag
11471 -- because we want to set the Ada version mode during parsing.
11473 when Pragma_Ada_83 =>
11475 Check_Arg_Count (0);
11477 -- We really should check unconditionally for proper configuration
11478 -- pragma placement, since we really don't want mixed Ada modes
11479 -- within a single unit, and the GNAT reference manual has always
11480 -- said this was a configuration pragma, but we did not check and
11481 -- are hesitant to add the check now.
11483 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11484 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11485 -- or Ada 2012 mode.
11487 if Ada_Version >= Ada_2005 then
11488 Check_Valid_Configuration_Pragma;
11491 -- Now set Ada 83 mode
11493 if Latest_Ada_Only then
11494 Error_Pragma ("??pragma% ignored");
11496 Ada_Version := Ada_83;
11497 Ada_Version_Explicit := Ada_83;
11498 Ada_Version_Pragma := N;
11507 -- Note: this pragma also has some specific processing in Par.Prag
11508 -- because we want to set the Ada 83 version mode during parsing.
11510 when Pragma_Ada_95 =>
11512 Check_Arg_Count (0);
11514 -- We really should check unconditionally for proper configuration
11515 -- pragma placement, since we really don't want mixed Ada modes
11516 -- within a single unit, and the GNAT reference manual has always
11517 -- said this was a configuration pragma, but we did not check and
11518 -- are hesitant to add the check now.
11520 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11521 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11523 if Ada_Version >= Ada_2005 then
11524 Check_Valid_Configuration_Pragma;
11527 -- Now set Ada 95 mode
11529 if Latest_Ada_Only then
11530 Error_Pragma ("??pragma% ignored");
11532 Ada_Version := Ada_95;
11533 Ada_Version_Explicit := Ada_95;
11534 Ada_Version_Pragma := N;
11537 ---------------------
11538 -- Ada_05/Ada_2005 --
11539 ---------------------
11542 -- pragma Ada_05 (LOCAL_NAME);
11544 -- pragma Ada_2005;
11545 -- pragma Ada_2005 (LOCAL_NAME):
11547 -- Note: these pragmas also have some specific processing in Par.Prag
11548 -- because we want to set the Ada 2005 version mode during parsing.
11550 -- The one argument form is used for managing the transition from
11551 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11552 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11553 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11554 -- mode, a preference rule is established which does not choose
11555 -- such an entity unless it is unambiguously specified. This avoids
11556 -- extra subprograms marked this way from generating ambiguities in
11557 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11558 -- intended for exclusive use in the GNAT run-time library.
11569 if Arg_Count = 1 then
11570 Check_Arg_Is_Local_Name (Arg1);
11571 E_Id := Get_Pragma_Arg (Arg1);
11573 if Etype (E_Id) = Any_Type then
11577 Set_Is_Ada_2005_Only (Entity (E_Id));
11578 Record_Rep_Item (Entity (E_Id), N);
11581 Check_Arg_Count (0);
11583 -- For Ada_2005 we unconditionally enforce the documented
11584 -- configuration pragma placement, since we do not want to
11585 -- tolerate mixed modes in a unit involving Ada 2005. That
11586 -- would cause real difficulties for those cases where there
11587 -- are incompatibilities between Ada 95 and Ada 2005.
11589 Check_Valid_Configuration_Pragma;
11591 -- Now set appropriate Ada mode
11593 if Latest_Ada_Only then
11594 Error_Pragma ("??pragma% ignored");
11596 Ada_Version := Ada_2005;
11597 Ada_Version_Explicit := Ada_2005;
11598 Ada_Version_Pragma := N;
11603 ---------------------
11604 -- Ada_12/Ada_2012 --
11605 ---------------------
11608 -- pragma Ada_12 (LOCAL_NAME);
11610 -- pragma Ada_2012;
11611 -- pragma Ada_2012 (LOCAL_NAME):
11613 -- Note: these pragmas also have some specific processing in Par.Prag
11614 -- because we want to set the Ada 2012 version mode during parsing.
11616 -- The one argument form is used for managing the transition from Ada
11617 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11618 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11619 -- mode will generate a warning. In addition, in any pre-Ada_2012
11620 -- mode, a preference rule is established which does not choose
11621 -- such an entity unless it is unambiguously specified. This avoids
11622 -- extra subprograms marked this way from generating ambiguities in
11623 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11624 -- intended for exclusive use in the GNAT run-time library.
11635 if Arg_Count = 1 then
11636 Check_Arg_Is_Local_Name (Arg1);
11637 E_Id := Get_Pragma_Arg (Arg1);
11639 if Etype (E_Id) = Any_Type then
11643 Set_Is_Ada_2012_Only (Entity (E_Id));
11644 Record_Rep_Item (Entity (E_Id), N);
11647 Check_Arg_Count (0);
11649 -- For Ada_2012 we unconditionally enforce the documented
11650 -- configuration pragma placement, since we do not want to
11651 -- tolerate mixed modes in a unit involving Ada 2012. That
11652 -- would cause real difficulties for those cases where there
11653 -- are incompatibilities between Ada 95 and Ada 2012. We could
11654 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11656 Check_Valid_Configuration_Pragma;
11658 -- Now set appropriate Ada mode
11660 Ada_Version := Ada_2012;
11661 Ada_Version_Explicit := Ada_2012;
11662 Ada_Version_Pragma := N;
11666 ----------------------
11667 -- All_Calls_Remote --
11668 ----------------------
11670 -- pragma All_Calls_Remote [(library_package_NAME)];
11672 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11673 Lib_Entity : Entity_Id;
11676 Check_Ada_83_Warning;
11677 Check_Valid_Library_Unit_Pragma;
11679 if Nkind (N) = N_Null_Statement then
11683 Lib_Entity := Find_Lib_Unit_Name;
11685 -- A pragma that applies to a Ghost entity becomes Ghost for the
11686 -- purposes of legality checks and removal of ignored Ghost code.
11688 Mark_Ghost_Pragma (N, Lib_Entity);
11690 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11692 if Present (Lib_Entity) and then not Debug_Flag_U then
11693 if not Is_Remote_Call_Interface (Lib_Entity) then
11694 Error_Pragma ("pragma% only apply to rci unit");
11696 -- Set flag for entity of the library unit
11699 Set_Has_All_Calls_Remote (Lib_Entity);
11702 end All_Calls_Remote;
11704 ---------------------------
11705 -- Allow_Integer_Address --
11706 ---------------------------
11708 -- pragma Allow_Integer_Address;
11710 when Pragma_Allow_Integer_Address =>
11712 Check_Valid_Configuration_Pragma;
11713 Check_Arg_Count (0);
11715 -- If Address is a private type, then set the flag to allow
11716 -- integer address values. If Address is not private, then this
11717 -- pragma has no purpose, so it is simply ignored. Not clear if
11718 -- there are any such targets now.
11720 if Opt.Address_Is_Private then
11721 Opt.Allow_Integer_Address := True;
11729 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11730 -- ARG ::= NAME | EXPRESSION
11732 -- The first two arguments are by convention intended to refer to an
11733 -- external tool and a tool-specific function. These arguments are
11736 when Pragma_Annotate => Annotate : declare
11743 Check_At_Least_N_Arguments (1);
11745 Nam_Arg := Last (Pragma_Argument_Associations (N));
11747 -- Determine whether the last argument is "Entity => local_NAME"
11748 -- and if it is, perform the required semantic checks. Remove the
11749 -- argument from further processing.
11751 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11752 and then Chars (Nam_Arg) = Name_Entity
11754 Check_Arg_Is_Local_Name (Nam_Arg);
11755 Arg_Count := Arg_Count - 1;
11757 -- A pragma that applies to a Ghost entity becomes Ghost for
11758 -- the purposes of legality checks and removal of ignored Ghost
11761 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11762 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11764 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11767 -- Not allowed in compiler units (bootstrap issues)
11769 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11772 -- Continue the processing with last argument removed for now
11774 Check_Arg_Is_Identifier (Arg1);
11775 Check_No_Identifiers;
11778 -- The second parameter is optional, it is never analyzed
11783 -- Otherwise there is a second parameter
11786 -- The second parameter must be an identifier
11788 Check_Arg_Is_Identifier (Arg2);
11790 -- Process the remaining parameters (if any)
11792 Arg := Next (Arg2);
11793 while Present (Arg) loop
11794 Expr := Get_Pragma_Arg (Arg);
11797 if Is_Entity_Name (Expr) then
11800 -- For string literals, we assume Standard_String as the
11801 -- type, unless the string contains wide or wide_wide
11804 elsif Nkind (Expr) = N_String_Literal then
11805 if Has_Wide_Wide_Character (Expr) then
11806 Resolve (Expr, Standard_Wide_Wide_String);
11807 elsif Has_Wide_Character (Expr) then
11808 Resolve (Expr, Standard_Wide_String);
11810 Resolve (Expr, Standard_String);
11813 elsif Is_Overloaded (Expr) then
11814 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11825 -------------------------------------------------
11826 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11827 -------------------------------------------------
11830 -- ( [Check => ] Boolean_EXPRESSION
11831 -- [, [Message =>] Static_String_EXPRESSION]);
11833 -- pragma Assert_And_Cut
11834 -- ( [Check => ] Boolean_EXPRESSION
11835 -- [, [Message =>] Static_String_EXPRESSION]);
11838 -- ( [Check => ] Boolean_EXPRESSION
11839 -- [, [Message =>] Static_String_EXPRESSION]);
11841 -- pragma Loop_Invariant
11842 -- ( [Check => ] Boolean_EXPRESSION
11843 -- [, [Message =>] Static_String_EXPRESSION]);
11846 | Pragma_Assert_And_Cut
11848 | Pragma_Loop_Invariant
11851 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11852 -- Determine whether expression Expr contains a Loop_Entry
11853 -- attribute reference.
11855 -------------------------
11856 -- Contains_Loop_Entry --
11857 -------------------------
11859 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11860 Has_Loop_Entry : Boolean := False;
11862 function Process (N : Node_Id) return Traverse_Result;
11863 -- Process function for traversal to look for Loop_Entry
11869 function Process (N : Node_Id) return Traverse_Result is
11871 if Nkind (N) = N_Attribute_Reference
11872 and then Attribute_Name (N) = Name_Loop_Entry
11874 Has_Loop_Entry := True;
11881 procedure Traverse is new Traverse_Proc (Process);
11883 -- Start of processing for Contains_Loop_Entry
11887 return Has_Loop_Entry;
11888 end Contains_Loop_Entry;
11893 New_Args : List_Id;
11895 -- Start of processing for Assert
11898 -- Assert is an Ada 2005 RM-defined pragma
11900 if Prag_Id = Pragma_Assert then
11903 -- The remaining ones are GNAT pragmas
11909 Check_At_Least_N_Arguments (1);
11910 Check_At_Most_N_Arguments (2);
11911 Check_Arg_Order ((Name_Check, Name_Message));
11912 Check_Optional_Identifier (Arg1, Name_Check);
11913 Expr := Get_Pragma_Arg (Arg1);
11915 -- Special processing for Loop_Invariant, Loop_Variant or for
11916 -- other cases where a Loop_Entry attribute is present. If the
11917 -- assertion pragma contains attribute Loop_Entry, ensure that
11918 -- the related pragma is within a loop.
11920 if Prag_Id = Pragma_Loop_Invariant
11921 or else Prag_Id = Pragma_Loop_Variant
11922 or else Contains_Loop_Entry (Expr)
11924 Check_Loop_Pragma_Placement;
11926 -- Perform preanalysis to deal with embedded Loop_Entry
11929 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11932 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11933 -- a corresponding Check pragma:
11935 -- pragma Check (name, condition [, msg]);
11937 -- Where name is the identifier matching the pragma name. So
11938 -- rewrite pragma in this manner, transfer the message argument
11939 -- if present, and analyze the result
11941 -- Note: When dealing with a semantically analyzed tree, the
11942 -- information that a Check node N corresponds to a source Assert,
11943 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11944 -- pragma kind of Original_Node(N).
11946 New_Args := New_List (
11947 Make_Pragma_Argument_Association (Loc,
11948 Expression => Make_Identifier (Loc, Pname)),
11949 Make_Pragma_Argument_Association (Sloc (Expr),
11950 Expression => Expr));
11952 if Arg_Count > 1 then
11953 Check_Optional_Identifier (Arg2, Name_Message);
11955 -- Provide semantic annnotations for optional argument, for
11956 -- ASIS use, before rewriting.
11958 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11959 Append_To (New_Args, New_Copy_Tree (Arg2));
11962 -- Rewrite as Check pragma
11966 Chars => Name_Check,
11967 Pragma_Argument_Associations => New_Args));
11972 ----------------------
11973 -- Assertion_Policy --
11974 ----------------------
11976 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11978 -- The following form is Ada 2012 only, but we allow it in all modes
11980 -- Pragma Assertion_Policy (
11981 -- ASSERTION_KIND => POLICY_IDENTIFIER
11982 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11984 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11986 -- RM_ASSERTION_KIND ::= Assert |
11987 -- Static_Predicate |
11988 -- Dynamic_Predicate |
11993 -- Type_Invariant |
11994 -- Type_Invariant'Class
11996 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11998 -- Contract_Cases |
12000 -- Default_Initial_Condition |
12002 -- Initial_Condition |
12003 -- Loop_Invariant |
12009 -- Statement_Assertions
12011 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12012 -- ID_ASSERTION_KIND list contains implementation-defined additions
12013 -- recognized by GNAT. The effect is to control the behavior of
12014 -- identically named aspects and pragmas, depending on the specified
12015 -- policy identifier:
12017 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12019 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12020 -- implementation-defined addition that results in totally ignoring
12021 -- the corresponding assertion. If Disable is specified, then the
12022 -- argument of the assertion is not even analyzed. This is useful
12023 -- when the aspect/pragma argument references entities in a with'ed
12024 -- package that is replaced by a dummy package in the final build.
12026 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12027 -- and Type_Invariant'Class were recognized by the parser and
12028 -- transformed into references to the special internal identifiers
12029 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12030 -- processing is required here.
12032 when Pragma_Assertion_Policy => Assertion_Policy : declare
12033 procedure Resolve_Suppressible (Policy : Node_Id);
12034 -- Converts the assertion policy 'Suppressible' to either Check or
12035 -- Ignore based on whether checks are suppressed via -gnatp.
12037 --------------------------
12038 -- Resolve_Suppressible --
12039 --------------------------
12041 procedure Resolve_Suppressible (Policy : Node_Id) is
12042 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12046 -- Transform policy argument Suppressible into either Ignore or
12047 -- Check depending on whether checks are enabled or suppressed.
12049 if Chars (Arg) = Name_Suppressible then
12050 if Suppress_Checks then
12051 Nam := Name_Ignore;
12056 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12058 end Resolve_Suppressible;
12070 -- This can always appear as a configuration pragma
12072 if Is_Configuration_Pragma then
12075 -- It can also appear in a declarative part or package spec in Ada
12076 -- 2012 mode. We allow this in other modes, but in that case we
12077 -- consider that we have an Ada 2012 pragma on our hands.
12080 Check_Is_In_Decl_Part_Or_Package_Spec;
12084 -- One argument case with no identifier (first form above)
12087 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
12088 or else Chars (Arg1) = No_Name)
12090 Check_Arg_Is_One_Of (Arg1,
12091 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12093 Resolve_Suppressible (Arg1);
12095 -- Treat one argument Assertion_Policy as equivalent to:
12097 -- pragma Check_Policy (Assertion, policy)
12099 -- So rewrite pragma in that manner and link on to the chain
12100 -- of Check_Policy pragmas, marking the pragma as analyzed.
12102 Policy := Get_Pragma_Arg (Arg1);
12106 Chars => Name_Check_Policy,
12107 Pragma_Argument_Associations => New_List (
12108 Make_Pragma_Argument_Association (Loc,
12109 Expression => Make_Identifier (Loc, Name_Assertion)),
12111 Make_Pragma_Argument_Association (Loc,
12113 Make_Identifier (Sloc (Policy), Chars (Policy))))));
12116 -- Here if we have two or more arguments
12119 Check_At_Least_N_Arguments (1);
12122 -- Loop through arguments
12125 while Present (Arg) loop
12126 LocP := Sloc (Arg);
12128 -- Kind must be specified
12130 if Nkind (Arg) /= N_Pragma_Argument_Association
12131 or else Chars (Arg) = No_Name
12134 ("missing assertion kind for pragma%", Arg);
12137 -- Check Kind and Policy have allowed forms
12139 Kind := Chars (Arg);
12140 Policy := Get_Pragma_Arg (Arg);
12142 if not Is_Valid_Assertion_Kind (Kind) then
12144 ("invalid assertion kind for pragma%", Arg);
12147 Check_Arg_Is_One_Of (Arg,
12148 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
12150 Resolve_Suppressible (Arg);
12152 if Kind = Name_Ghost then
12154 -- The Ghost policy must be either Check or Ignore
12155 -- (SPARK RM 6.9(6)).
12157 if not Nam_In (Chars (Policy), Name_Check,
12161 ("argument of pragma % Ghost must be Check or "
12162 & "Ignore", Policy);
12165 -- Pragma Assertion_Policy specifying a Ghost policy
12166 -- cannot occur within a Ghost subprogram or package
12167 -- (SPARK RM 6.9(14)).
12169 if Ghost_Mode > None then
12171 ("pragma % cannot appear within ghost subprogram or "
12176 -- Rewrite the Assertion_Policy pragma as a series of
12177 -- Check_Policy pragmas of the form:
12179 -- Check_Policy (Kind, Policy);
12181 -- Note: the insertion of the pragmas cannot be done with
12182 -- Insert_Action because in the configuration case, there
12183 -- are no scopes on the scope stack and the mechanism will
12186 Insert_Before_And_Analyze (N,
12188 Chars => Name_Check_Policy,
12189 Pragma_Argument_Associations => New_List (
12190 Make_Pragma_Argument_Association (LocP,
12191 Expression => Make_Identifier (LocP, Kind)),
12192 Make_Pragma_Argument_Association (LocP,
12193 Expression => Policy))));
12198 -- Rewrite the Assertion_Policy pragma as null since we have
12199 -- now inserted all the equivalent Check pragmas.
12201 Rewrite (N, Make_Null_Statement (Loc));
12204 end Assertion_Policy;
12206 ------------------------------
12207 -- Assume_No_Invalid_Values --
12208 ------------------------------
12210 -- pragma Assume_No_Invalid_Values (On | Off);
12212 when Pragma_Assume_No_Invalid_Values =>
12214 Check_Valid_Configuration_Pragma;
12215 Check_Arg_Count (1);
12216 Check_No_Identifiers;
12217 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12219 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12220 Assume_No_Invalid_Values := True;
12222 Assume_No_Invalid_Values := False;
12225 --------------------------
12226 -- Attribute_Definition --
12227 --------------------------
12229 -- pragma Attribute_Definition
12230 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12231 -- [Entity =>] LOCAL_NAME,
12232 -- [Expression =>] EXPRESSION | NAME);
12234 when Pragma_Attribute_Definition => Attribute_Definition : declare
12235 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12240 Check_Arg_Count (3);
12241 Check_Optional_Identifier (Arg1, "attribute");
12242 Check_Optional_Identifier (Arg2, "entity");
12243 Check_Optional_Identifier (Arg3, "expression");
12245 if Nkind (Attribute_Designator) /= N_Identifier then
12246 Error_Msg_N ("attribute name expected", Attribute_Designator);
12250 Check_Arg_Is_Local_Name (Arg2);
12252 -- If the attribute is not recognized, then issue a warning (not
12253 -- an error), and ignore the pragma.
12255 Aname := Chars (Attribute_Designator);
12257 if not Is_Attribute_Name (Aname) then
12258 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12262 -- Otherwise, rewrite the pragma as an attribute definition clause
12265 Make_Attribute_Definition_Clause (Loc,
12266 Name => Get_Pragma_Arg (Arg2),
12268 Expression => Get_Pragma_Arg (Arg3)));
12270 end Attribute_Definition;
12272 ------------------------------------------------------------------
12273 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12274 ------------------------------------------------------------------
12276 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12277 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12278 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12279 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12281 when Pragma_Async_Readers
12282 | Pragma_Async_Writers
12283 | Pragma_Effective_Reads
12284 | Pragma_Effective_Writes
12286 Async_Effective : declare
12287 Obj_Decl : Node_Id;
12288 Obj_Id : Entity_Id;
12292 Check_No_Identifiers;
12293 Check_At_Most_N_Arguments (1);
12295 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12297 -- Object declaration
12299 if Nkind (Obj_Decl) = N_Object_Declaration then
12302 -- Otherwise the pragma is associated with an illegal construact
12309 Obj_Id := Defining_Entity (Obj_Decl);
12311 -- Perform minimal verification to ensure that the argument is at
12312 -- least a variable. Subsequent finer grained checks will be done
12313 -- at the end of the declarative region the contains the pragma.
12315 if Ekind (Obj_Id) = E_Variable then
12317 -- A pragma that applies to a Ghost entity becomes Ghost for
12318 -- the purposes of legality checks and removal of ignored Ghost
12321 Mark_Ghost_Pragma (N, Obj_Id);
12323 -- Chain the pragma on the contract for further processing by
12324 -- Analyze_External_Property_In_Decl_Part.
12326 Add_Contract_Item (N, Obj_Id);
12328 -- Analyze the Boolean expression (if any)
12330 if Present (Arg1) then
12331 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12334 -- Otherwise the external property applies to a constant
12337 Error_Pragma ("pragma % must apply to a volatile object");
12339 end Async_Effective;
12345 -- pragma Asynchronous (LOCAL_NAME);
12347 when Pragma_Asynchronous => Asynchronous : declare
12350 Formal : Entity_Id;
12355 procedure Process_Async_Pragma;
12356 -- Common processing for procedure and access-to-procedure case
12358 --------------------------
12359 -- Process_Async_Pragma --
12360 --------------------------
12362 procedure Process_Async_Pragma is
12365 Set_Is_Asynchronous (Nm);
12369 -- The formals should be of mode IN (RM E.4.1(6))
12372 while Present (S) loop
12373 Formal := Defining_Identifier (S);
12375 if Nkind (Formal) = N_Defining_Identifier
12376 and then Ekind (Formal) /= E_In_Parameter
12379 ("pragma% procedure can only have IN parameter",
12386 Set_Is_Asynchronous (Nm);
12387 end Process_Async_Pragma;
12389 -- Start of processing for pragma Asynchronous
12392 Check_Ada_83_Warning;
12393 Check_No_Identifiers;
12394 Check_Arg_Count (1);
12395 Check_Arg_Is_Local_Name (Arg1);
12397 if Debug_Flag_U then
12401 C_Ent := Cunit_Entity (Current_Sem_Unit);
12402 Analyze (Get_Pragma_Arg (Arg1));
12403 Nm := Entity (Get_Pragma_Arg (Arg1));
12405 -- A pragma that applies to a Ghost entity becomes Ghost for the
12406 -- purposes of legality checks and removal of ignored Ghost code.
12408 Mark_Ghost_Pragma (N, Nm);
12410 if not Is_Remote_Call_Interface (C_Ent)
12411 and then not Is_Remote_Types (C_Ent)
12413 -- This pragma should only appear in an RCI or Remote Types
12414 -- unit (RM E.4.1(4)).
12417 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12420 if Ekind (Nm) = E_Procedure
12421 and then Nkind (Parent (Nm)) = N_Procedure_Specification
12423 if not Is_Remote_Call_Interface (Nm) then
12425 ("pragma% cannot be applied on non-remote procedure",
12429 L := Parameter_Specifications (Parent (Nm));
12430 Process_Async_Pragma;
12433 elsif Ekind (Nm) = E_Function then
12435 ("pragma% cannot be applied to function", Arg1);
12437 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12438 if Is_Record_Type (Nm) then
12440 -- A record type that is the Equivalent_Type for a remote
12441 -- access-to-subprogram type.
12443 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12446 -- A non-expanded RAS type (distribution is not enabled)
12448 Decl := Declaration_Node (Nm);
12451 if Nkind (Decl) = N_Full_Type_Declaration
12452 and then Nkind (Type_Definition (Decl)) =
12453 N_Access_Procedure_Definition
12455 L := Parameter_Specifications (Type_Definition (Decl));
12456 Process_Async_Pragma;
12458 if Is_Asynchronous (Nm)
12459 and then Expander_Active
12460 and then Get_PCS_Name /= Name_No_DSA
12462 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12467 ("pragma% cannot reference access-to-function type",
12471 -- Only other possibility is Access-to-class-wide type
12473 elsif Is_Access_Type (Nm)
12474 and then Is_Class_Wide_Type (Designated_Type (Nm))
12476 Check_First_Subtype (Arg1);
12477 Set_Is_Asynchronous (Nm);
12478 if Expander_Active then
12479 RACW_Type_Is_Asynchronous (Nm);
12483 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12491 -- pragma Atomic (LOCAL_NAME);
12493 when Pragma_Atomic =>
12494 Process_Atomic_Independent_Shared_Volatile;
12496 -----------------------
12497 -- Atomic_Components --
12498 -----------------------
12500 -- pragma Atomic_Components (array_LOCAL_NAME);
12502 -- This processing is shared by Volatile_Components
12504 when Pragma_Atomic_Components
12505 | Pragma_Volatile_Components
12507 Atomic_Components : declare
12514 Check_Ada_83_Warning;
12515 Check_No_Identifiers;
12516 Check_Arg_Count (1);
12517 Check_Arg_Is_Local_Name (Arg1);
12518 E_Id := Get_Pragma_Arg (Arg1);
12520 if Etype (E_Id) = Any_Type then
12524 E := Entity (E_Id);
12526 -- A pragma that applies to a Ghost entity becomes Ghost for the
12527 -- purposes of legality checks and removal of ignored Ghost code.
12529 Mark_Ghost_Pragma (N, E);
12530 Check_Duplicate_Pragma (E);
12532 if Rep_Item_Too_Early (E, N)
12534 Rep_Item_Too_Late (E, N)
12539 D := Declaration_Node (E);
12542 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12544 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12545 and then Nkind (D) = N_Object_Declaration
12546 and then Nkind (Object_Definition (D)) =
12547 N_Constrained_Array_Definition)
12549 -- The flag is set on the object, or on the base type
12551 if Nkind (D) /= N_Object_Declaration then
12552 E := Base_Type (E);
12555 -- Atomic implies both Independent and Volatile
12557 if Prag_Id = Pragma_Atomic_Components then
12558 Set_Has_Atomic_Components (E);
12559 Set_Has_Independent_Components (E);
12562 Set_Has_Volatile_Components (E);
12565 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12567 end Atomic_Components;
12569 --------------------
12570 -- Attach_Handler --
12571 --------------------
12573 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12575 when Pragma_Attach_Handler =>
12576 Check_Ada_83_Warning;
12577 Check_No_Identifiers;
12578 Check_Arg_Count (2);
12580 if No_Run_Time_Mode then
12581 Error_Msg_CRT ("Attach_Handler pragma", N);
12583 Check_Interrupt_Or_Attach_Handler;
12585 -- The expression that designates the attribute may depend on a
12586 -- discriminant, and is therefore a per-object expression, to
12587 -- be expanded in the init proc. If expansion is enabled, then
12588 -- perform semantic checks on a copy only.
12593 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12596 -- In Relaxed_RM_Semantics mode, we allow any static
12597 -- integer value, for compatibility with other compilers.
12599 if Relaxed_RM_Semantics
12600 and then Nkind (Parg2) = N_Integer_Literal
12602 Typ := Standard_Integer;
12604 Typ := RTE (RE_Interrupt_ID);
12607 if Expander_Active then
12608 Temp := New_Copy_Tree (Parg2);
12609 Set_Parent (Temp, N);
12610 Preanalyze_And_Resolve (Temp, Typ);
12613 Resolve (Parg2, Typ);
12617 Process_Interrupt_Or_Attach_Handler;
12620 --------------------
12621 -- C_Pass_By_Copy --
12622 --------------------
12624 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12626 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12632 Check_Valid_Configuration_Pragma;
12633 Check_Arg_Count (1);
12634 Check_Optional_Identifier (Arg1, "max_size");
12636 Arg := Get_Pragma_Arg (Arg1);
12637 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12639 Val := Expr_Value (Arg);
12643 ("maximum size for pragma% must be positive", Arg1);
12645 elsif UI_Is_In_Int_Range (Val) then
12646 Default_C_Record_Mechanism := UI_To_Int (Val);
12648 -- If a giant value is given, Int'Last will do well enough.
12649 -- If sometime someone complains that a record larger than
12650 -- two gigabytes is not copied, we will worry about it then.
12653 Default_C_Record_Mechanism := Mechanism_Type'Last;
12655 end C_Pass_By_Copy;
12661 -- pragma Check ([Name =>] CHECK_KIND,
12662 -- [Check =>] Boolean_EXPRESSION
12663 -- [,[Message =>] String_EXPRESSION]);
12665 -- CHECK_KIND ::= IDENTIFIER |
12668 -- Invariant'Class |
12669 -- Type_Invariant'Class
12671 -- The identifiers Assertions and Statement_Assertions are not
12672 -- allowed, since they have special meaning for Check_Policy.
12674 -- WARNING: The code below manages Ghost regions. Return statements
12675 -- must be replaced by gotos which jump to the end of the code and
12676 -- restore the Ghost mode.
12678 when Pragma_Check => Check : declare
12679 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
12680 -- Save the Ghost mode to restore on exit
12688 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12689 -- the mode now to ensure that any nodes generated during analysis
12690 -- and expansion are marked as Ghost.
12692 Set_Ghost_Mode (N);
12695 Check_At_Least_N_Arguments (2);
12696 Check_At_Most_N_Arguments (3);
12697 Check_Optional_Identifier (Arg1, Name_Name);
12698 Check_Optional_Identifier (Arg2, Name_Check);
12700 if Arg_Count = 3 then
12701 Check_Optional_Identifier (Arg3, Name_Message);
12702 Str := Get_Pragma_Arg (Arg3);
12705 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12706 Check_Arg_Is_Identifier (Arg1);
12707 Cname := Chars (Get_Pragma_Arg (Arg1));
12709 -- Check forbidden name Assertions or Statement_Assertions
12712 when Name_Assertions =>
12714 ("""Assertions"" is not allowed as a check kind for "
12715 & "pragma%", Arg1);
12717 when Name_Statement_Assertions =>
12719 ("""Statement_Assertions"" is not allowed as a check kind "
12720 & "for pragma%", Arg1);
12726 -- Check applicable policy. We skip this if Checked/Ignored status
12727 -- is already set (e.g. in the case of a pragma from an aspect).
12729 if Is_Checked (N) or else Is_Ignored (N) then
12732 -- For a non-source pragma that is a rewriting of another pragma,
12733 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12735 elsif Is_Rewrite_Substitution (N)
12736 and then Nkind (Original_Node (N)) = N_Pragma
12737 and then Original_Node (N) /= N
12739 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12740 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12742 -- Otherwise query the applicable policy at this point
12745 case Check_Kind (Cname) is
12746 when Name_Ignore =>
12747 Set_Is_Ignored (N, True);
12748 Set_Is_Checked (N, False);
12751 Set_Is_Ignored (N, False);
12752 Set_Is_Checked (N, True);
12754 -- For disable, rewrite pragma as null statement and skip
12755 -- rest of the analysis of the pragma.
12757 when Name_Disable =>
12758 Rewrite (N, Make_Null_Statement (Loc));
12762 -- No other possibilities
12765 raise Program_Error;
12769 -- If check kind was not Disable, then continue pragma analysis
12771 Expr := Get_Pragma_Arg (Arg2);
12773 -- Deal with SCO generation
12775 if Is_Checked (N) and then not Split_PPC (N) then
12776 Set_SCO_Pragma_Enabled (Loc);
12779 -- Deal with analyzing the string argument
12781 if Arg_Count = 3 then
12783 -- If checks are not on we don't want any expansion (since
12784 -- such expansion would not get properly deleted) but
12785 -- we do want to analyze (to get proper references).
12786 -- The Preanalyze_And_Resolve routine does just what we want
12788 if Is_Ignored (N) then
12789 Preanalyze_And_Resolve (Str, Standard_String);
12791 -- Otherwise we need a proper analysis and expansion
12794 Analyze_And_Resolve (Str, Standard_String);
12798 -- Now you might think we could just do the same with the Boolean
12799 -- expression if checks are off (and expansion is on) and then
12800 -- rewrite the check as a null statement. This would work but we
12801 -- would lose the useful warnings about an assertion being bound
12802 -- to fail even if assertions are turned off.
12804 -- So instead we wrap the boolean expression in an if statement
12805 -- that looks like:
12807 -- if False and then condition then
12811 -- The reason we do this rewriting during semantic analysis rather
12812 -- than as part of normal expansion is that we cannot analyze and
12813 -- expand the code for the boolean expression directly, or it may
12814 -- cause insertion of actions that would escape the attempt to
12815 -- suppress the check code.
12817 -- Note that the Sloc for the if statement corresponds to the
12818 -- argument condition, not the pragma itself. The reason for
12819 -- this is that we may generate a warning if the condition is
12820 -- False at compile time, and we do not want to delete this
12821 -- warning when we delete the if statement.
12823 if Expander_Active and Is_Ignored (N) then
12824 Eloc := Sloc (Expr);
12827 Make_If_Statement (Eloc,
12829 Make_And_Then (Eloc,
12830 Left_Opnd => Make_Identifier (Eloc, Name_False),
12831 Right_Opnd => Expr),
12832 Then_Statements => New_List (
12833 Make_Null_Statement (Eloc))));
12835 -- Now go ahead and analyze the if statement
12837 In_Assertion_Expr := In_Assertion_Expr + 1;
12839 -- One rather special treatment. If we are now in Eliminated
12840 -- overflow mode, then suppress overflow checking since we do
12841 -- not want to drag in the bignum stuff if we are in Ignore
12842 -- mode anyway. This is particularly important if we are using
12843 -- a configurable run time that does not support bignum ops.
12845 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12847 Svo : constant Boolean :=
12848 Scope_Suppress.Suppress (Overflow_Check);
12850 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12851 Scope_Suppress.Suppress (Overflow_Check) := True;
12853 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12854 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12857 -- Not that special case
12863 -- All done with this check
12865 In_Assertion_Expr := In_Assertion_Expr - 1;
12867 -- Check is active or expansion not active. In these cases we can
12868 -- just go ahead and analyze the boolean with no worries.
12871 In_Assertion_Expr := In_Assertion_Expr + 1;
12872 Analyze_And_Resolve (Expr, Any_Boolean);
12873 In_Assertion_Expr := In_Assertion_Expr - 1;
12876 Restore_Ghost_Mode (Saved_GM);
12879 --------------------------
12880 -- Check_Float_Overflow --
12881 --------------------------
12883 -- pragma Check_Float_Overflow;
12885 when Pragma_Check_Float_Overflow =>
12887 Check_Valid_Configuration_Pragma;
12888 Check_Arg_Count (0);
12889 Check_Float_Overflow := not Machine_Overflows_On_Target;
12895 -- pragma Check_Name (check_IDENTIFIER);
12897 when Pragma_Check_Name =>
12899 Check_No_Identifiers;
12900 Check_Valid_Configuration_Pragma;
12901 Check_Arg_Count (1);
12902 Check_Arg_Is_Identifier (Arg1);
12905 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12908 for J in Check_Names.First .. Check_Names.Last loop
12909 if Check_Names.Table (J) = Nam then
12914 Check_Names.Append (Nam);
12921 -- This is the old style syntax, which is still allowed in all modes:
12923 -- pragma Check_Policy ([Name =>] CHECK_KIND
12924 -- [Policy =>] POLICY_IDENTIFIER);
12926 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12928 -- CHECK_KIND ::= IDENTIFIER |
12931 -- Type_Invariant'Class |
12934 -- This is the new style syntax, compatible with Assertion_Policy
12935 -- and also allowed in all modes.
12937 -- Pragma Check_Policy (
12938 -- CHECK_KIND => POLICY_IDENTIFIER
12939 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12941 -- Note: the identifiers Name and Policy are not allowed as
12942 -- Check_Kind values. This avoids ambiguities between the old and
12943 -- new form syntax.
12945 when Pragma_Check_Policy => Check_Policy : declare
12950 Check_At_Least_N_Arguments (1);
12952 -- A Check_Policy pragma can appear either as a configuration
12953 -- pragma, or in a declarative part or a package spec (see RM
12954 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12955 -- followed for Check_Policy).
12957 if not Is_Configuration_Pragma then
12958 Check_Is_In_Decl_Part_Or_Package_Spec;
12961 -- Figure out if we have the old or new syntax. We have the
12962 -- old syntax if the first argument has no identifier, or the
12963 -- identifier is Name.
12965 if Nkind (Arg1) /= N_Pragma_Argument_Association
12966 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12970 Check_Arg_Count (2);
12971 Check_Optional_Identifier (Arg1, Name_Name);
12972 Kind := Get_Pragma_Arg (Arg1);
12973 Rewrite_Assertion_Kind (Kind,
12974 From_Policy => Comes_From_Source (N));
12975 Check_Arg_Is_Identifier (Arg1);
12977 -- Check forbidden check kind
12979 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12980 Error_Msg_Name_2 := Chars (Kind);
12982 ("pragma% does not allow% as check name", Arg1);
12987 Check_Optional_Identifier (Arg2, Name_Policy);
12988 Check_Arg_Is_One_Of
12990 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12992 -- And chain pragma on the Check_Policy_List for search
12994 Set_Next_Pragma (N, Opt.Check_Policy_List);
12995 Opt.Check_Policy_List := N;
12997 -- For the new syntax, what we do is to convert each argument to
12998 -- an old syntax equivalent. We do that because we want to chain
12999 -- old style Check_Policy pragmas for the search (we don't want
13000 -- to have to deal with multiple arguments in the search).
13011 while Present (Arg) loop
13012 LocP := Sloc (Arg);
13013 Argx := Get_Pragma_Arg (Arg);
13015 -- Kind must be specified
13017 if Nkind (Arg) /= N_Pragma_Argument_Association
13018 or else Chars (Arg) = No_Name
13021 ("missing assertion kind for pragma%", Arg);
13024 -- Construct equivalent old form syntax Check_Policy
13025 -- pragma and insert it to get remaining checks.
13029 Chars => Name_Check_Policy,
13030 Pragma_Argument_Associations => New_List (
13031 Make_Pragma_Argument_Association (LocP,
13033 Make_Identifier (LocP, Chars (Arg))),
13034 Make_Pragma_Argument_Association (Sloc (Argx),
13035 Expression => Argx)));
13039 -- For a configuration pragma, insert old form in
13040 -- the corresponding file.
13042 if Is_Configuration_Pragma then
13043 Insert_After (N, New_P);
13047 Insert_Action (N, New_P);
13051 -- Rewrite original Check_Policy pragma to null, since we
13052 -- have converted it into a series of old syntax pragmas.
13054 Rewrite (N, Make_Null_Statement (Loc));
13064 -- pragma Comment (static_string_EXPRESSION)
13066 -- Processing for pragma Comment shares the circuitry for pragma
13067 -- Ident. The only differences are that Ident enforces a limit of 31
13068 -- characters on its argument, and also enforces limitations on
13069 -- placement for DEC compatibility. Pragma Comment shares neither of
13070 -- these restrictions.
13072 -------------------
13073 -- Common_Object --
13074 -------------------
13076 -- pragma Common_Object (
13077 -- [Internal =>] LOCAL_NAME
13078 -- [, [External =>] EXTERNAL_SYMBOL]
13079 -- [, [Size =>] EXTERNAL_SYMBOL]);
13081 -- Processing for this pragma is shared with Psect_Object
13083 ------------------------
13084 -- Compile_Time_Error --
13085 ------------------------
13087 -- pragma Compile_Time_Error
13088 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13090 when Pragma_Compile_Time_Error =>
13092 Process_Compile_Time_Warning_Or_Error;
13094 --------------------------
13095 -- Compile_Time_Warning --
13096 --------------------------
13098 -- pragma Compile_Time_Warning
13099 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13101 when Pragma_Compile_Time_Warning =>
13103 Process_Compile_Time_Warning_Or_Error;
13105 ---------------------------
13106 -- Compiler_Unit_Warning --
13107 ---------------------------
13109 -- pragma Compiler_Unit_Warning;
13113 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13114 -- errors not warnings. This means that we had introduced a big extra
13115 -- inertia to compiler changes, since even if we implemented a new
13116 -- feature, and even if all versions to be used for bootstrapping
13117 -- implemented this new feature, we could not use it, since old
13118 -- compilers would give errors for using this feature in units
13119 -- having Compiler_Unit pragmas.
13121 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13122 -- problem. We no longer have any units mentioning Compiler_Unit,
13123 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13124 -- and thus generates a warning which can be ignored. So that deals
13125 -- with the problem of old compilers not implementing the newer form
13128 -- Newer compilers recognize the new pragma, but generate warning
13129 -- messages instead of errors, which again can be ignored in the
13130 -- case of an old compiler which implements a wanted new feature
13131 -- but at the time felt like warning about it for older compilers.
13133 -- We retain Compiler_Unit so that new compilers can be used to build
13134 -- older run-times that use this pragma. That's an unusual case, but
13135 -- it's easy enough to handle, so why not?
13137 when Pragma_Compiler_Unit
13138 | Pragma_Compiler_Unit_Warning
13141 Check_Arg_Count (0);
13143 -- Only recognized in main unit
13145 if Current_Sem_Unit = Main_Unit then
13146 Compiler_Unit := True;
13149 -----------------------------
13150 -- Complete_Representation --
13151 -----------------------------
13153 -- pragma Complete_Representation;
13155 when Pragma_Complete_Representation =>
13157 Check_Arg_Count (0);
13159 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
13161 ("pragma & must appear within record representation clause");
13164 ----------------------------
13165 -- Complex_Representation --
13166 ----------------------------
13168 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13170 when Pragma_Complex_Representation => Complex_Representation : declare
13177 Check_Arg_Count (1);
13178 Check_Optional_Identifier (Arg1, Name_Entity);
13179 Check_Arg_Is_Local_Name (Arg1);
13180 E_Id := Get_Pragma_Arg (Arg1);
13182 if Etype (E_Id) = Any_Type then
13186 E := Entity (E_Id);
13188 if not Is_Record_Type (E) then
13190 ("argument for pragma% must be record type", Arg1);
13193 Ent := First_Entity (E);
13196 or else No (Next_Entity (Ent))
13197 or else Present (Next_Entity (Next_Entity (Ent)))
13198 or else not Is_Floating_Point_Type (Etype (Ent))
13199 or else Etype (Ent) /= Etype (Next_Entity (Ent))
13202 ("record for pragma% must have two fields of the same "
13203 & "floating-point type", Arg1);
13206 Set_Has_Complex_Representation (Base_Type (E));
13208 -- We need to treat the type has having a non-standard
13209 -- representation, for back-end purposes, even though in
13210 -- general a complex will have the default representation
13211 -- of a record with two real components.
13213 Set_Has_Non_Standard_Rep (Base_Type (E));
13215 end Complex_Representation;
13217 -------------------------
13218 -- Component_Alignment --
13219 -------------------------
13221 -- pragma Component_Alignment (
13222 -- [Form =>] ALIGNMENT_CHOICE
13223 -- [, [Name =>] type_LOCAL_NAME]);
13225 -- ALIGNMENT_CHOICE ::=
13227 -- | Component_Size_4
13231 when Pragma_Component_Alignment => Component_AlignmentP : declare
13232 Args : Args_List (1 .. 2);
13233 Names : constant Name_List (1 .. 2) := (
13237 Form : Node_Id renames Args (1);
13238 Name : Node_Id renames Args (2);
13240 Atype : Component_Alignment_Kind;
13245 Gather_Associations (Names, Args);
13248 Error_Pragma ("missing Form argument for pragma%");
13251 Check_Arg_Is_Identifier (Form);
13253 -- Get proper alignment, note that Default = Component_Size on all
13254 -- machines we have so far, and we want to set this value rather
13255 -- than the default value to indicate that it has been explicitly
13256 -- set (and thus will not get overridden by the default component
13257 -- alignment for the current scope)
13259 if Chars (Form) = Name_Component_Size then
13260 Atype := Calign_Component_Size;
13262 elsif Chars (Form) = Name_Component_Size_4 then
13263 Atype := Calign_Component_Size_4;
13265 elsif Chars (Form) = Name_Default then
13266 Atype := Calign_Component_Size;
13268 elsif Chars (Form) = Name_Storage_Unit then
13269 Atype := Calign_Storage_Unit;
13273 ("invalid Form parameter for pragma%", Form);
13276 -- The pragma appears in a configuration file
13278 if No (Parent (N)) then
13279 Check_Valid_Configuration_Pragma;
13281 -- Capture the component alignment in a global variable when
13282 -- the pragma appears in a configuration file. Note that the
13283 -- scope stack is empty at this point and cannot be used to
13284 -- store the alignment value.
13286 Configuration_Component_Alignment := Atype;
13288 -- Case with no name, supplied, affects scope table entry
13290 elsif No (Name) then
13292 (Scope_Stack.Last).Component_Alignment_Default := Atype;
13294 -- Case of name supplied
13297 Check_Arg_Is_Local_Name (Name);
13299 Typ := Entity (Name);
13302 or else Rep_Item_Too_Early (Typ, N)
13306 Typ := Underlying_Type (Typ);
13309 if not Is_Record_Type (Typ)
13310 and then not Is_Array_Type (Typ)
13313 ("Name parameter of pragma% must identify record or "
13314 & "array type", Name);
13317 -- An explicit Component_Alignment pragma overrides an
13318 -- implicit pragma Pack, but not an explicit one.
13320 if not Has_Pragma_Pack (Base_Type (Typ)) then
13321 Set_Is_Packed (Base_Type (Typ), False);
13322 Set_Component_Alignment (Base_Type (Typ), Atype);
13325 end Component_AlignmentP;
13327 --------------------------------
13328 -- Constant_After_Elaboration --
13329 --------------------------------
13331 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13333 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13335 Obj_Decl : Node_Id;
13336 Obj_Id : Entity_Id;
13340 Check_No_Identifiers;
13341 Check_At_Most_N_Arguments (1);
13343 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13345 -- Object declaration
13347 if Nkind (Obj_Decl) = N_Object_Declaration then
13350 -- Otherwise the pragma is associated with an illegal construct
13357 Obj_Id := Defining_Entity (Obj_Decl);
13359 -- The object declaration must be a library-level variable which
13360 -- is either explicitly initialized or obtains a value during the
13361 -- elaboration of a package body (SPARK RM 3.3.1).
13363 if Ekind (Obj_Id) = E_Variable then
13364 if not Is_Library_Level_Entity (Obj_Id) then
13366 ("pragma % must apply to a library level variable");
13370 -- Otherwise the pragma applies to a constant, which is illegal
13373 Error_Pragma ("pragma % must apply to a variable declaration");
13377 -- A pragma that applies to a Ghost entity becomes Ghost for the
13378 -- purposes of legality checks and removal of ignored Ghost code.
13380 Mark_Ghost_Pragma (N, Obj_Id);
13382 -- Chain the pragma on the contract for completeness
13384 Add_Contract_Item (N, Obj_Id);
13386 -- Analyze the Boolean expression (if any)
13388 if Present (Arg1) then
13389 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13391 end Constant_After_Elaboration;
13393 --------------------
13394 -- Contract_Cases --
13395 --------------------
13397 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13399 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13401 -- CASE_GUARD ::= boolean_EXPRESSION | others
13403 -- CONSEQUENCE ::= boolean_EXPRESSION
13405 -- Characteristics:
13407 -- * Analysis - The annotation undergoes initial checks to verify
13408 -- the legal placement and context. Secondary checks preanalyze the
13411 -- Analyze_Contract_Cases_In_Decl_Part
13413 -- * Expansion - The annotation is expanded during the expansion of
13414 -- the related subprogram [body] contract as performed in:
13416 -- Expand_Subprogram_Contract
13418 -- * Template - The annotation utilizes the generic template of the
13419 -- related subprogram [body] when it is:
13421 -- aspect on subprogram declaration
13422 -- aspect on stand alone subprogram body
13423 -- pragma on stand alone subprogram body
13425 -- The annotation must prepare its own template when it is:
13427 -- pragma on subprogram declaration
13429 -- * Globals - Capture of global references must occur after full
13432 -- * Instance - The annotation is instantiated automatically when
13433 -- the related generic subprogram [body] is instantiated except for
13434 -- the "pragma on subprogram declaration" case. In that scenario
13435 -- the annotation must instantiate itself.
13437 when Pragma_Contract_Cases => Contract_Cases : declare
13438 Spec_Id : Entity_Id;
13439 Subp_Decl : Node_Id;
13443 Check_No_Identifiers;
13444 Check_Arg_Count (1);
13446 -- Ensure the proper placement of the pragma. Contract_Cases must
13447 -- be associated with a subprogram declaration or a body that acts
13451 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13455 if Nkind (Subp_Decl) = N_Entry_Declaration then
13458 -- Generic subprogram
13460 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13463 -- Body acts as spec
13465 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13466 and then No (Corresponding_Spec (Subp_Decl))
13470 -- Body stub acts as spec
13472 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13473 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13479 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13487 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13489 -- A pragma that applies to a Ghost entity becomes Ghost for the
13490 -- purposes of legality checks and removal of ignored Ghost code.
13492 Mark_Ghost_Pragma (N, Spec_Id);
13493 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13495 -- Chain the pragma on the contract for further processing by
13496 -- Analyze_Contract_Cases_In_Decl_Part.
13498 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13500 -- Fully analyze the pragma when it appears inside an entry
13501 -- or subprogram body because it cannot benefit from forward
13504 if Nkind_In (Subp_Decl, N_Entry_Body,
13506 N_Subprogram_Body_Stub)
13508 -- The legality checks of pragma Contract_Cases are affected by
13509 -- the SPARK mode in effect and the volatility of the context.
13510 -- Analyze all pragmas in a specific order.
13512 Analyze_If_Present (Pragma_SPARK_Mode);
13513 Analyze_If_Present (Pragma_Volatile_Function);
13514 Analyze_Contract_Cases_In_Decl_Part (N);
13516 end Contract_Cases;
13522 -- pragma Controlled (first_subtype_LOCAL_NAME);
13524 when Pragma_Controlled => Controlled : declare
13528 Check_No_Identifiers;
13529 Check_Arg_Count (1);
13530 Check_Arg_Is_Local_Name (Arg1);
13531 Arg := Get_Pragma_Arg (Arg1);
13533 if not Is_Entity_Name (Arg)
13534 or else not Is_Access_Type (Entity (Arg))
13536 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13538 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13546 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13547 -- [Entity =>] LOCAL_NAME);
13549 when Pragma_Convention => Convention : declare
13552 pragma Warnings (Off, C);
13553 pragma Warnings (Off, E);
13556 Check_Arg_Order ((Name_Convention, Name_Entity));
13557 Check_Ada_83_Warning;
13558 Check_Arg_Count (2);
13559 Process_Convention (C, E);
13561 -- A pragma that applies to a Ghost entity becomes Ghost for the
13562 -- purposes of legality checks and removal of ignored Ghost code.
13564 Mark_Ghost_Pragma (N, E);
13567 ---------------------------
13568 -- Convention_Identifier --
13569 ---------------------------
13571 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13572 -- [Convention =>] convention_IDENTIFIER);
13574 when Pragma_Convention_Identifier => Convention_Identifier : declare
13580 Check_Arg_Order ((Name_Name, Name_Convention));
13581 Check_Arg_Count (2);
13582 Check_Optional_Identifier (Arg1, Name_Name);
13583 Check_Optional_Identifier (Arg2, Name_Convention);
13584 Check_Arg_Is_Identifier (Arg1);
13585 Check_Arg_Is_Identifier (Arg2);
13586 Idnam := Chars (Get_Pragma_Arg (Arg1));
13587 Cname := Chars (Get_Pragma_Arg (Arg2));
13589 if Is_Convention_Name (Cname) then
13590 Record_Convention_Identifier
13591 (Idnam, Get_Convention_Id (Cname));
13594 ("second arg for % pragma must be convention", Arg2);
13596 end Convention_Identifier;
13602 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13604 when Pragma_CPP_Class =>
13607 if Warn_On_Obsolescent_Feature then
13609 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13610 & "effect; replace it by pragma import?j?", N);
13613 Check_Arg_Count (1);
13617 Chars => Name_Import,
13618 Pragma_Argument_Associations => New_List (
13619 Make_Pragma_Argument_Association (Loc,
13620 Expression => Make_Identifier (Loc, Name_CPP)),
13621 New_Copy (First (Pragma_Argument_Associations (N))))));
13624 ---------------------
13625 -- CPP_Constructor --
13626 ---------------------
13628 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13629 -- [, [External_Name =>] static_string_EXPRESSION ]
13630 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13632 when Pragma_CPP_Constructor => CPP_Constructor : declare
13635 Def_Id : Entity_Id;
13636 Tag_Typ : Entity_Id;
13640 Check_At_Least_N_Arguments (1);
13641 Check_At_Most_N_Arguments (3);
13642 Check_Optional_Identifier (Arg1, Name_Entity);
13643 Check_Arg_Is_Local_Name (Arg1);
13645 Id := Get_Pragma_Arg (Arg1);
13646 Find_Program_Unit_Name (Id);
13648 -- If we did not find the name, we are done
13650 if Etype (Id) = Any_Type then
13654 Def_Id := Entity (Id);
13656 -- Check if already defined as constructor
13658 if Is_Constructor (Def_Id) then
13660 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13664 if Ekind (Def_Id) = E_Function
13665 and then (Is_CPP_Class (Etype (Def_Id))
13666 or else (Is_Class_Wide_Type (Etype (Def_Id))
13668 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13670 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13672 ("'C'P'P constructor must be defined in the scope of "
13673 & "its returned type", Arg1);
13676 if Arg_Count >= 2 then
13677 Set_Imported (Def_Id);
13678 Set_Is_Public (Def_Id);
13679 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
13682 Set_Has_Completion (Def_Id);
13683 Set_Is_Constructor (Def_Id);
13684 Set_Convention (Def_Id, Convention_CPP);
13686 -- Imported C++ constructors are not dispatching primitives
13687 -- because in C++ they don't have a dispatch table slot.
13688 -- However, in Ada the constructor has the profile of a
13689 -- function that returns a tagged type and therefore it has
13690 -- been treated as a primitive operation during semantic
13691 -- analysis. We now remove it from the list of primitive
13692 -- operations of the type.
13694 if Is_Tagged_Type (Etype (Def_Id))
13695 and then not Is_Class_Wide_Type (Etype (Def_Id))
13696 and then Is_Dispatching_Operation (Def_Id)
13698 Tag_Typ := Etype (Def_Id);
13700 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13701 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13705 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13706 Set_Is_Dispatching_Operation (Def_Id, False);
13709 -- For backward compatibility, if the constructor returns a
13710 -- class wide type, and we internally change the return type to
13711 -- the corresponding root type.
13713 if Is_Class_Wide_Type (Etype (Def_Id)) then
13714 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13718 ("pragma% requires function returning a 'C'P'P_Class type",
13721 end CPP_Constructor;
13727 when Pragma_CPP_Virtual =>
13730 if Warn_On_Obsolescent_Feature then
13732 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13740 when Pragma_CPP_Vtable =>
13743 if Warn_On_Obsolescent_Feature then
13745 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13753 -- pragma CPU (EXPRESSION);
13755 when Pragma_CPU => CPU : declare
13756 P : constant Node_Id := Parent (N);
13762 Check_No_Identifiers;
13763 Check_Arg_Count (1);
13767 if Nkind (P) = N_Subprogram_Body then
13768 Check_In_Main_Program;
13770 Arg := Get_Pragma_Arg (Arg1);
13771 Analyze_And_Resolve (Arg, Any_Integer);
13773 Ent := Defining_Unit_Name (Specification (P));
13775 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13776 Ent := Defining_Identifier (Ent);
13781 if not Is_OK_Static_Expression (Arg) then
13782 Flag_Non_Static_Expr
13783 ("main subprogram affinity is not static!", Arg);
13786 -- If constraint error, then we already signalled an error
13788 elsif Raises_Constraint_Error (Arg) then
13791 -- Otherwise check in range
13795 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13796 -- This is the entity System.Multiprocessors.CPU_Range;
13798 Val : constant Uint := Expr_Value (Arg);
13801 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13803 Val > Expr_Value (Type_High_Bound (CPU_Id))
13806 ("main subprogram CPU is out of range", Arg1);
13812 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13816 elsif Nkind (P) = N_Task_Definition then
13817 Arg := Get_Pragma_Arg (Arg1);
13818 Ent := Defining_Identifier (Parent (P));
13820 -- The expression must be analyzed in the special manner
13821 -- described in "Handling of Default and Per-Object
13822 -- Expressions" in sem.ads.
13824 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13826 -- Anything else is incorrect
13832 -- Check duplicate pragma before we chain the pragma in the Rep
13833 -- Item chain of Ent.
13835 Check_Duplicate_Pragma (Ent);
13836 Record_Rep_Item (Ent, N);
13839 --------------------
13840 -- Deadline_Floor --
13841 --------------------
13843 -- pragma Deadline_Floor (time_span_EXPRESSION);
13845 when Pragma_Deadline_Floor => Deadline_Floor : declare
13846 P : constant Node_Id := Parent (N);
13852 Check_No_Identifiers;
13853 Check_Arg_Count (1);
13855 Arg := Get_Pragma_Arg (Arg1);
13857 -- The expression must be analyzed in the special manner described
13858 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
13860 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
13862 -- Only protected types allowed
13864 if Nkind (P) /= N_Protected_Definition then
13868 Ent := Defining_Identifier (Parent (P));
13870 -- Check duplicate pragma before we chain the pragma in the Rep
13871 -- Item chain of Ent.
13873 Check_Duplicate_Pragma (Ent);
13874 Record_Rep_Item (Ent, N);
13876 end Deadline_Floor;
13882 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13884 when Pragma_Debug => Debug : declare
13891 -- The condition for executing the call is that the expander
13892 -- is active and that we are not ignoring this debug pragma.
13897 (Expander_Active and then not Is_Ignored (N)),
13900 if not Is_Ignored (N) then
13901 Set_SCO_Pragma_Enabled (Loc);
13904 if Arg_Count = 2 then
13906 Make_And_Then (Loc,
13907 Left_Opnd => Relocate_Node (Cond),
13908 Right_Opnd => Get_Pragma_Arg (Arg1));
13909 Call := Get_Pragma_Arg (Arg2);
13911 Call := Get_Pragma_Arg (Arg1);
13915 N_Indexed_Component,
13919 N_Selected_Component)
13921 -- If this pragma Debug comes from source, its argument was
13922 -- parsed as a name form (which is syntactically identical).
13923 -- In a generic context a parameterless call will be left as
13924 -- an expanded name (if global) or selected_component if local.
13925 -- Change it to a procedure call statement now.
13927 Change_Name_To_Procedure_Call_Statement (Call);
13929 elsif Nkind (Call) = N_Procedure_Call_Statement then
13931 -- Already in the form of a procedure call statement: nothing
13932 -- to do (could happen in case of an internally generated
13938 -- All other cases: diagnose error
13941 ("argument of pragma ""Debug"" is not procedure call",
13946 -- Rewrite into a conditional with an appropriate condition. We
13947 -- wrap the procedure call in a block so that overhead from e.g.
13948 -- use of the secondary stack does not generate execution overhead
13949 -- for suppressed conditions.
13951 -- Normally the analysis that follows will freeze the subprogram
13952 -- being called. However, if the call is to a null procedure,
13953 -- we want to freeze it before creating the block, because the
13954 -- analysis that follows may be done with expansion disabled, in
13955 -- which case the body will not be generated, leading to spurious
13958 if Nkind (Call) = N_Procedure_Call_Statement
13959 and then Is_Entity_Name (Name (Call))
13961 Analyze (Name (Call));
13962 Freeze_Before (N, Entity (Name (Call)));
13966 Make_Implicit_If_Statement (N,
13968 Then_Statements => New_List (
13969 Make_Block_Statement (Loc,
13970 Handled_Statement_Sequence =>
13971 Make_Handled_Sequence_Of_Statements (Loc,
13972 Statements => New_List (Relocate_Node (Call)))))));
13975 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13976 -- after analysis of the normally rewritten node, to capture all
13977 -- references to entities, which avoids issuing wrong warnings
13978 -- about unused entities.
13980 if GNATprove_Mode then
13981 Rewrite (N, Make_Null_Statement (Loc));
13989 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13991 when Pragma_Debug_Policy =>
13993 Check_Arg_Count (1);
13994 Check_No_Identifiers;
13995 Check_Arg_Is_Identifier (Arg1);
13997 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13998 -- rewrite it that way, and let the rest of the checking come
13999 -- from analyzing the rewritten pragma.
14003 Chars => Name_Check_Policy,
14004 Pragma_Argument_Associations => New_List (
14005 Make_Pragma_Argument_Association (Loc,
14006 Expression => Make_Identifier (Loc, Name_Debug)),
14008 Make_Pragma_Argument_Association (Loc,
14009 Expression => Get_Pragma_Arg (Arg1)))));
14012 -------------------------------
14013 -- Default_Initial_Condition --
14014 -------------------------------
14016 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14018 when Pragma_Default_Initial_Condition => DIC : declare
14025 Check_No_Identifiers;
14026 Check_At_Most_N_Arguments (1);
14030 while Present (Stmt) loop
14032 -- Skip prior pragmas, but check for duplicates
14034 if Nkind (Stmt) = N_Pragma then
14035 if Pragma_Name (Stmt) = Pname then
14042 -- Skip internally generated code. Note that derived type
14043 -- declarations of untagged types with discriminants are
14044 -- rewritten as private type declarations.
14046 elsif not Comes_From_Source (Stmt)
14047 and then Nkind (Stmt) /= N_Private_Type_Declaration
14051 -- The associated private type [extension] has been found, stop
14054 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
14055 N_Private_Type_Declaration)
14057 Typ := Defining_Entity (Stmt);
14060 -- The pragma does not apply to a legal construct, issue an
14061 -- error and stop the analysis.
14068 Stmt := Prev (Stmt);
14071 -- The pragma does not apply to a legal construct, issue an error
14072 -- and stop the analysis.
14079 -- A pragma that applies to a Ghost entity becomes Ghost for the
14080 -- purposes of legality checks and removal of ignored Ghost code.
14082 Mark_Ghost_Pragma (N, Typ);
14084 -- The pragma signals that the type defines its own DIC assertion
14087 Set_Has_Own_DIC (Typ);
14089 -- Chain the pragma on the rep item chain for further processing
14091 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14093 -- Create the declaration of the procedure which verifies the
14094 -- assertion expression of pragma DIC at runtime.
14096 Build_DIC_Procedure_Declaration (Typ);
14099 ----------------------------------
14100 -- Default_Scalar_Storage_Order --
14101 ----------------------------------
14103 -- pragma Default_Scalar_Storage_Order
14104 -- (High_Order_First | Low_Order_First);
14106 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
14107 Default : Character;
14111 Check_Arg_Count (1);
14113 -- Default_Scalar_Storage_Order can appear as a configuration
14114 -- pragma, or in a declarative part of a package spec.
14116 if not Is_Configuration_Pragma then
14117 Check_Is_In_Decl_Part_Or_Package_Spec;
14120 Check_No_Identifiers;
14121 Check_Arg_Is_One_Of
14122 (Arg1, Name_High_Order_First, Name_Low_Order_First);
14123 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14124 Default := Fold_Upper (Name_Buffer (1));
14126 if not Support_Nondefault_SSO_On_Target
14127 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
14129 if Warn_On_Unrecognized_Pragma then
14131 ("non-default Scalar_Storage_Order not supported "
14132 & "on target?g?", N);
14134 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
14137 -- Here set the specified default
14140 Opt.Default_SSO := Default;
14144 --------------------------
14145 -- Default_Storage_Pool --
14146 --------------------------
14148 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14150 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
14155 Check_Arg_Count (1);
14157 -- Default_Storage_Pool can appear as a configuration pragma, or
14158 -- in a declarative part of a package spec.
14160 if not Is_Configuration_Pragma then
14161 Check_Is_In_Decl_Part_Or_Package_Spec;
14164 if From_Aspect_Specification (N) then
14166 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
14168 if not In_Open_Scopes (E) then
14170 ("aspect must apply to package or subprogram", N);
14175 if Present (Arg1) then
14176 Pool := Get_Pragma_Arg (Arg1);
14178 -- Case of Default_Storage_Pool (null);
14180 if Nkind (Pool) = N_Null then
14183 -- This is an odd case, this is not really an expression,
14184 -- so we don't have a type for it. So just set the type to
14187 Set_Etype (Pool, Empty);
14189 -- Case of Default_Storage_Pool (storage_pool_NAME);
14192 -- If it's a configuration pragma, then the only allowed
14193 -- argument is "null".
14195 if Is_Configuration_Pragma then
14196 Error_Pragma_Arg ("NULL expected", Arg1);
14199 -- The expected type for a non-"null" argument is
14200 -- Root_Storage_Pool'Class, and the pool must be a variable.
14202 Analyze_And_Resolve
14203 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
14205 if Is_Variable (Pool) then
14207 -- A pragma that applies to a Ghost entity becomes Ghost
14208 -- for the purposes of legality checks and removal of
14209 -- ignored Ghost code.
14211 Mark_Ghost_Pragma (N, Entity (Pool));
14215 ("default storage pool must be a variable", Arg1);
14219 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14220 -- access type will use this information to set the appropriate
14221 -- attributes of the access type.
14223 Default_Pool := Pool;
14225 end Default_Storage_Pool;
14231 -- pragma Depends (DEPENDENCY_RELATION);
14233 -- DEPENDENCY_RELATION ::=
14235 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14237 -- DEPENDENCY_CLAUSE ::=
14238 -- OUTPUT_LIST =>[+] INPUT_LIST
14239 -- | NULL_DEPENDENCY_CLAUSE
14241 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14243 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14245 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14247 -- OUTPUT ::= NAME | FUNCTION_RESULT
14250 -- where FUNCTION_RESULT is a function Result attribute_reference
14252 -- Characteristics:
14254 -- * Analysis - The annotation undergoes initial checks to verify
14255 -- the legal placement and context. Secondary checks fully analyze
14256 -- the dependency clauses in:
14258 -- Analyze_Depends_In_Decl_Part
14260 -- * Expansion - None.
14262 -- * Template - The annotation utilizes the generic template of the
14263 -- related subprogram [body] when it is:
14265 -- aspect on subprogram declaration
14266 -- aspect on stand alone subprogram body
14267 -- pragma on stand alone subprogram body
14269 -- The annotation must prepare its own template when it is:
14271 -- pragma on subprogram declaration
14273 -- * Globals - Capture of global references must occur after full
14276 -- * Instance - The annotation is instantiated automatically when
14277 -- the related generic subprogram [body] is instantiated except for
14278 -- the "pragma on subprogram declaration" case. In that scenario
14279 -- the annotation must instantiate itself.
14281 when Pragma_Depends => Depends : declare
14283 Spec_Id : Entity_Id;
14284 Subp_Decl : Node_Id;
14287 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14291 -- Chain the pragma on the contract for further processing by
14292 -- Analyze_Depends_In_Decl_Part.
14294 Add_Contract_Item (N, Spec_Id);
14296 -- Fully analyze the pragma when it appears inside an entry
14297 -- or subprogram body because it cannot benefit from forward
14300 if Nkind_In (Subp_Decl, N_Entry_Body,
14302 N_Subprogram_Body_Stub)
14304 -- The legality checks of pragmas Depends and Global are
14305 -- affected by the SPARK mode in effect and the volatility
14306 -- of the context. In addition these two pragmas are subject
14307 -- to an inherent order:
14312 -- Analyze all these pragmas in the order outlined above
14314 Analyze_If_Present (Pragma_SPARK_Mode);
14315 Analyze_If_Present (Pragma_Volatile_Function);
14316 Analyze_If_Present (Pragma_Global);
14317 Analyze_Depends_In_Decl_Part (N);
14322 ---------------------
14323 -- Detect_Blocking --
14324 ---------------------
14326 -- pragma Detect_Blocking;
14328 when Pragma_Detect_Blocking =>
14330 Check_Arg_Count (0);
14331 Check_Valid_Configuration_Pragma;
14332 Detect_Blocking := True;
14334 ------------------------------------
14335 -- Disable_Atomic_Synchronization --
14336 ------------------------------------
14338 -- pragma Disable_Atomic_Synchronization [(Entity)];
14340 when Pragma_Disable_Atomic_Synchronization =>
14342 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14344 -------------------
14345 -- Discard_Names --
14346 -------------------
14348 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14350 when Pragma_Discard_Names => Discard_Names : declare
14355 Check_Ada_83_Warning;
14357 -- Deal with configuration pragma case
14359 if Arg_Count = 0 and then Is_Configuration_Pragma then
14360 Global_Discard_Names := True;
14363 -- Otherwise, check correct appropriate context
14366 Check_Is_In_Decl_Part_Or_Package_Spec;
14368 if Arg_Count = 0 then
14370 -- If there is no parameter, then from now on this pragma
14371 -- applies to any enumeration, exception or tagged type
14372 -- defined in the current declarative part, and recursively
14373 -- to any nested scope.
14375 Set_Discard_Names (Current_Scope);
14379 Check_Arg_Count (1);
14380 Check_Optional_Identifier (Arg1, Name_On);
14381 Check_Arg_Is_Local_Name (Arg1);
14383 E_Id := Get_Pragma_Arg (Arg1);
14385 if Etype (E_Id) = Any_Type then
14388 E := Entity (E_Id);
14391 -- A pragma that applies to a Ghost entity becomes Ghost for
14392 -- the purposes of legality checks and removal of ignored
14395 Mark_Ghost_Pragma (N, E);
14397 if (Is_First_Subtype (E)
14399 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14400 or else Ekind (E) = E_Exception
14402 Set_Discard_Names (E);
14403 Record_Rep_Item (E, N);
14407 ("inappropriate entity for pragma%", Arg1);
14413 ------------------------
14414 -- Dispatching_Domain --
14415 ------------------------
14417 -- pragma Dispatching_Domain (EXPRESSION);
14419 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14420 P : constant Node_Id := Parent (N);
14426 Check_No_Identifiers;
14427 Check_Arg_Count (1);
14429 -- This pragma is born obsolete, but not the aspect
14431 if not From_Aspect_Specification (N) then
14433 (No_Obsolescent_Features, Pragma_Identifier (N));
14436 if Nkind (P) = N_Task_Definition then
14437 Arg := Get_Pragma_Arg (Arg1);
14438 Ent := Defining_Identifier (Parent (P));
14440 -- A pragma that applies to a Ghost entity becomes Ghost for
14441 -- the purposes of legality checks and removal of ignored Ghost
14444 Mark_Ghost_Pragma (N, Ent);
14446 -- The expression must be analyzed in the special manner
14447 -- described in "Handling of Default and Per-Object
14448 -- Expressions" in sem.ads.
14450 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14452 -- Check duplicate pragma before we chain the pragma in the Rep
14453 -- Item chain of Ent.
14455 Check_Duplicate_Pragma (Ent);
14456 Record_Rep_Item (Ent, N);
14458 -- Anything else is incorrect
14463 end Dispatching_Domain;
14469 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14471 when Pragma_Elaborate => Elaborate : declare
14476 -- Pragma must be in context items list of a compilation unit
14478 if not Is_In_Context_Clause then
14482 -- Must be at least one argument
14484 if Arg_Count = 0 then
14485 Error_Pragma ("pragma% requires at least one argument");
14488 -- In Ada 83 mode, there can be no items following it in the
14489 -- context list except other pragmas and implicit with clauses
14490 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14491 -- placement rule does not apply.
14493 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14495 while Present (Citem) loop
14496 if Nkind (Citem) = N_Pragma
14497 or else (Nkind (Citem) = N_With_Clause
14498 and then Implicit_With (Citem))
14503 ("(Ada 83) pragma% must be at end of context clause");
14510 -- Finally, the arguments must all be units mentioned in a with
14511 -- clause in the same context clause. Note we already checked (in
14512 -- Par.Prag) that the arguments are all identifiers or selected
14516 Outer : while Present (Arg) loop
14517 Citem := First (List_Containing (N));
14518 Inner : while Citem /= N loop
14519 if Nkind (Citem) = N_With_Clause
14520 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14522 Set_Elaborate_Present (Citem, True);
14523 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14525 -- With the pragma present, elaboration calls on
14526 -- subprograms from the named unit need no further
14527 -- checks, as long as the pragma appears in the current
14528 -- compilation unit. If the pragma appears in some unit
14529 -- in the context, there might still be a need for an
14530 -- Elaborate_All_Desirable from the current compilation
14531 -- to the named unit, so we keep the check enabled.
14533 if In_Extended_Main_Source_Unit (N) then
14535 -- This does not apply in SPARK mode, where we allow
14536 -- pragma Elaborate, but we don't trust it to be right
14537 -- so we will still insist on the Elaborate_All.
14539 if SPARK_Mode /= On then
14540 Set_Suppress_Elaboration_Warnings
14541 (Entity (Name (Citem)));
14553 ("argument of pragma% is not withed unit", Arg);
14559 -- Give a warning if operating in static mode with one of the
14560 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14563 and not Dynamic_Elaboration_Checks
14565 -- pragma Elaborate not allowed in SPARK mode anyway. We
14566 -- already complained about it, no point in generating any
14567 -- further complaint.
14569 and SPARK_Mode /= On
14572 ("?l?use of pragma Elaborate may not be safe", N);
14574 ("?l?use pragma Elaborate_All instead if possible", N);
14578 -------------------
14579 -- Elaborate_All --
14580 -------------------
14582 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14584 when Pragma_Elaborate_All => Elaborate_All : declare
14589 Check_Ada_83_Warning;
14591 -- Pragma must be in context items list of a compilation unit
14593 if not Is_In_Context_Clause then
14597 -- Must be at least one argument
14599 if Arg_Count = 0 then
14600 Error_Pragma ("pragma% requires at least one argument");
14603 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14604 -- have to appear at the end of the context clause, but may
14605 -- appear mixed in with other items, even in Ada 83 mode.
14607 -- Final check: the arguments must all be units mentioned in
14608 -- a with clause in the same context clause. Note that we
14609 -- already checked (in Par.Prag) that all the arguments are
14610 -- either identifiers or selected components.
14613 Outr : while Present (Arg) loop
14614 Citem := First (List_Containing (N));
14615 Innr : while Citem /= N loop
14616 if Nkind (Citem) = N_With_Clause
14617 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14619 Set_Elaborate_All_Present (Citem, True);
14620 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14622 -- Suppress warnings and elaboration checks on the named
14623 -- unit if the pragma is in the current compilation, as
14624 -- for pragma Elaborate.
14626 if In_Extended_Main_Source_Unit (N) then
14627 Set_Suppress_Elaboration_Warnings
14628 (Entity (Name (Citem)));
14637 Set_Error_Posted (N);
14639 ("argument of pragma% is not withed unit", Arg);
14646 --------------------
14647 -- Elaborate_Body --
14648 --------------------
14650 -- pragma Elaborate_Body [( library_unit_NAME )];
14652 when Pragma_Elaborate_Body => Elaborate_Body : declare
14653 Cunit_Node : Node_Id;
14654 Cunit_Ent : Entity_Id;
14657 Check_Ada_83_Warning;
14658 Check_Valid_Library_Unit_Pragma;
14660 if Nkind (N) = N_Null_Statement then
14664 Cunit_Node := Cunit (Current_Sem_Unit);
14665 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14667 -- A pragma that applies to a Ghost entity becomes Ghost for the
14668 -- purposes of legality checks and removal of ignored Ghost code.
14670 Mark_Ghost_Pragma (N, Cunit_Ent);
14672 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14675 Error_Pragma ("pragma% must refer to a spec, not a body");
14677 Set_Body_Required (Cunit_Node, True);
14678 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14680 -- If we are in dynamic elaboration mode, then we suppress
14681 -- elaboration warnings for the unit, since it is definitely
14682 -- fine NOT to do dynamic checks at the first level (and such
14683 -- checks will be suppressed because no elaboration boolean
14684 -- is created for Elaborate_Body packages).
14686 -- But in the static model of elaboration, Elaborate_Body is
14687 -- definitely NOT good enough to ensure elaboration safety on
14688 -- its own, since the body may WITH other units that are not
14689 -- safe from an elaboration point of view, so a client must
14690 -- still do an Elaborate_All on such units.
14692 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14693 -- Elaborate_Body always suppressed elab warnings.
14695 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14696 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14699 end Elaborate_Body;
14701 ------------------------
14702 -- Elaboration_Checks --
14703 ------------------------
14705 -- pragma Elaboration_Checks (Static | Dynamic);
14707 when Pragma_Elaboration_Checks =>
14709 Check_Arg_Count (1);
14710 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14712 -- Set flag accordingly (ignore attempt at dynamic elaboration
14713 -- checks in SPARK mode).
14715 Dynamic_Elaboration_Checks :=
14716 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14722 -- pragma Eliminate (
14723 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14724 -- [,[Entity =>] IDENTIFIER |
14725 -- SELECTED_COMPONENT |
14727 -- [, OVERLOADING_RESOLUTION]);
14729 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14732 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14733 -- FUNCTION_PROFILE
14735 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14737 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14738 -- Result_Type => result_SUBTYPE_NAME]
14740 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14741 -- SUBTYPE_NAME ::= STRING_LITERAL
14743 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14744 -- SOURCE_TRACE ::= STRING_LITERAL
14746 when Pragma_Eliminate => Eliminate : declare
14747 Args : Args_List (1 .. 5);
14748 Names : constant Name_List (1 .. 5) := (
14751 Name_Parameter_Types,
14753 Name_Source_Location);
14755 Unit_Name : Node_Id renames Args (1);
14756 Entity : Node_Id renames Args (2);
14757 Parameter_Types : Node_Id renames Args (3);
14758 Result_Type : Node_Id renames Args (4);
14759 Source_Location : Node_Id renames Args (5);
14763 Check_Valid_Configuration_Pragma;
14764 Gather_Associations (Names, Args);
14766 if No (Unit_Name) then
14767 Error_Pragma ("missing Unit_Name argument for pragma%");
14771 and then (Present (Parameter_Types)
14773 Present (Result_Type)
14775 Present (Source_Location))
14777 Error_Pragma ("missing Entity argument for pragma%");
14780 if (Present (Parameter_Types)
14782 Present (Result_Type))
14784 Present (Source_Location)
14787 ("parameter profile and source location cannot be used "
14788 & "together in pragma%");
14791 Process_Eliminate_Pragma
14800 -----------------------------------
14801 -- Enable_Atomic_Synchronization --
14802 -----------------------------------
14804 -- pragma Enable_Atomic_Synchronization [(Entity)];
14806 when Pragma_Enable_Atomic_Synchronization =>
14808 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14815 -- [ Convention =>] convention_IDENTIFIER,
14816 -- [ Entity =>] LOCAL_NAME
14817 -- [, [External_Name =>] static_string_EXPRESSION ]
14818 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14820 when Pragma_Export => Export : declare
14822 Def_Id : Entity_Id;
14824 pragma Warnings (Off, C);
14827 Check_Ada_83_Warning;
14831 Name_External_Name,
14834 Check_At_Least_N_Arguments (2);
14835 Check_At_Most_N_Arguments (4);
14837 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14838 -- pragma Export (Entity, "external name");
14840 if Relaxed_RM_Semantics
14841 and then Arg_Count = 2
14842 and then Nkind (Expression (Arg2)) = N_String_Literal
14845 Def_Id := Get_Pragma_Arg (Arg1);
14848 if not Is_Entity_Name (Def_Id) then
14849 Error_Pragma_Arg ("entity name required", Arg1);
14852 Def_Id := Entity (Def_Id);
14853 Set_Exported (Def_Id, Arg1);
14856 Process_Convention (C, Def_Id);
14858 -- A pragma that applies to a Ghost entity becomes Ghost for
14859 -- the purposes of legality checks and removal of ignored Ghost
14862 Mark_Ghost_Pragma (N, Def_Id);
14864 if Ekind (Def_Id) /= E_Constant then
14865 Note_Possible_Modification
14866 (Get_Pragma_Arg (Arg2), Sure => False);
14869 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
14870 Set_Exported (Def_Id, Arg2);
14873 -- If the entity is a deferred constant, propagate the information
14874 -- to the full view, because gigi elaborates the full view only.
14876 if Ekind (Def_Id) = E_Constant
14877 and then Present (Full_View (Def_Id))
14880 Id2 : constant Entity_Id := Full_View (Def_Id);
14882 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14883 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14884 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14889 ---------------------
14890 -- Export_Function --
14891 ---------------------
14893 -- pragma Export_Function (
14894 -- [Internal =>] LOCAL_NAME
14895 -- [, [External =>] EXTERNAL_SYMBOL]
14896 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14897 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14898 -- [, [Mechanism =>] MECHANISM]
14899 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14901 -- EXTERNAL_SYMBOL ::=
14903 -- | static_string_EXPRESSION
14905 -- PARAMETER_TYPES ::=
14907 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14909 -- TYPE_DESIGNATOR ::=
14911 -- | subtype_Name ' Access
14915 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14917 -- MECHANISM_ASSOCIATION ::=
14918 -- [formal_parameter_NAME =>] MECHANISM_NAME
14920 -- MECHANISM_NAME ::=
14924 when Pragma_Export_Function => Export_Function : declare
14925 Args : Args_List (1 .. 6);
14926 Names : constant Name_List (1 .. 6) := (
14929 Name_Parameter_Types,
14932 Name_Result_Mechanism);
14934 Internal : Node_Id renames Args (1);
14935 External : Node_Id renames Args (2);
14936 Parameter_Types : Node_Id renames Args (3);
14937 Result_Type : Node_Id renames Args (4);
14938 Mechanism : Node_Id renames Args (5);
14939 Result_Mechanism : Node_Id renames Args (6);
14943 Gather_Associations (Names, Args);
14944 Process_Extended_Import_Export_Subprogram_Pragma (
14945 Arg_Internal => Internal,
14946 Arg_External => External,
14947 Arg_Parameter_Types => Parameter_Types,
14948 Arg_Result_Type => Result_Type,
14949 Arg_Mechanism => Mechanism,
14950 Arg_Result_Mechanism => Result_Mechanism);
14951 end Export_Function;
14953 -------------------
14954 -- Export_Object --
14955 -------------------
14957 -- pragma Export_Object (
14958 -- [Internal =>] LOCAL_NAME
14959 -- [, [External =>] EXTERNAL_SYMBOL]
14960 -- [, [Size =>] EXTERNAL_SYMBOL]);
14962 -- EXTERNAL_SYMBOL ::=
14964 -- | static_string_EXPRESSION
14966 -- PARAMETER_TYPES ::=
14968 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14970 -- TYPE_DESIGNATOR ::=
14972 -- | subtype_Name ' Access
14976 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14978 -- MECHANISM_ASSOCIATION ::=
14979 -- [formal_parameter_NAME =>] MECHANISM_NAME
14981 -- MECHANISM_NAME ::=
14985 when Pragma_Export_Object => Export_Object : declare
14986 Args : Args_List (1 .. 3);
14987 Names : constant Name_List (1 .. 3) := (
14992 Internal : Node_Id renames Args (1);
14993 External : Node_Id renames Args (2);
14994 Size : Node_Id renames Args (3);
14998 Gather_Associations (Names, Args);
14999 Process_Extended_Import_Export_Object_Pragma (
15000 Arg_Internal => Internal,
15001 Arg_External => External,
15005 ----------------------
15006 -- Export_Procedure --
15007 ----------------------
15009 -- pragma Export_Procedure (
15010 -- [Internal =>] LOCAL_NAME
15011 -- [, [External =>] EXTERNAL_SYMBOL]
15012 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15013 -- [, [Mechanism =>] MECHANISM]);
15015 -- EXTERNAL_SYMBOL ::=
15017 -- | static_string_EXPRESSION
15019 -- PARAMETER_TYPES ::=
15021 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15023 -- TYPE_DESIGNATOR ::=
15025 -- | subtype_Name ' Access
15029 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15031 -- MECHANISM_ASSOCIATION ::=
15032 -- [formal_parameter_NAME =>] MECHANISM_NAME
15034 -- MECHANISM_NAME ::=
15038 when Pragma_Export_Procedure => Export_Procedure : declare
15039 Args : Args_List (1 .. 4);
15040 Names : constant Name_List (1 .. 4) := (
15043 Name_Parameter_Types,
15046 Internal : Node_Id renames Args (1);
15047 External : Node_Id renames Args (2);
15048 Parameter_Types : Node_Id renames Args (3);
15049 Mechanism : Node_Id renames Args (4);
15053 Gather_Associations (Names, Args);
15054 Process_Extended_Import_Export_Subprogram_Pragma (
15055 Arg_Internal => Internal,
15056 Arg_External => External,
15057 Arg_Parameter_Types => Parameter_Types,
15058 Arg_Mechanism => Mechanism);
15059 end Export_Procedure;
15065 -- pragma Export_Value (
15066 -- [Value =>] static_integer_EXPRESSION,
15067 -- [Link_Name =>] static_string_EXPRESSION);
15069 when Pragma_Export_Value =>
15071 Check_Arg_Order ((Name_Value, Name_Link_Name));
15072 Check_Arg_Count (2);
15074 Check_Optional_Identifier (Arg1, Name_Value);
15075 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
15077 Check_Optional_Identifier (Arg2, Name_Link_Name);
15078 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
15080 -----------------------------
15081 -- Export_Valued_Procedure --
15082 -----------------------------
15084 -- pragma Export_Valued_Procedure (
15085 -- [Internal =>] LOCAL_NAME
15086 -- [, [External =>] EXTERNAL_SYMBOL,]
15087 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15088 -- [, [Mechanism =>] MECHANISM]);
15090 -- EXTERNAL_SYMBOL ::=
15092 -- | static_string_EXPRESSION
15094 -- PARAMETER_TYPES ::=
15096 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15098 -- TYPE_DESIGNATOR ::=
15100 -- | subtype_Name ' Access
15104 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15106 -- MECHANISM_ASSOCIATION ::=
15107 -- [formal_parameter_NAME =>] MECHANISM_NAME
15109 -- MECHANISM_NAME ::=
15113 when Pragma_Export_Valued_Procedure =>
15114 Export_Valued_Procedure : declare
15115 Args : Args_List (1 .. 4);
15116 Names : constant Name_List (1 .. 4) := (
15119 Name_Parameter_Types,
15122 Internal : Node_Id renames Args (1);
15123 External : Node_Id renames Args (2);
15124 Parameter_Types : Node_Id renames Args (3);
15125 Mechanism : Node_Id renames Args (4);
15129 Gather_Associations (Names, Args);
15130 Process_Extended_Import_Export_Subprogram_Pragma (
15131 Arg_Internal => Internal,
15132 Arg_External => External,
15133 Arg_Parameter_Types => Parameter_Types,
15134 Arg_Mechanism => Mechanism);
15135 end Export_Valued_Procedure;
15137 -------------------
15138 -- Extend_System --
15139 -------------------
15141 -- pragma Extend_System ([Name =>] Identifier);
15143 when Pragma_Extend_System =>
15145 Check_Valid_Configuration_Pragma;
15146 Check_Arg_Count (1);
15147 Check_Optional_Identifier (Arg1, Name_Name);
15148 Check_Arg_Is_Identifier (Arg1);
15150 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15153 and then Name_Buffer (1 .. 4) = "aux_"
15155 if Present (System_Extend_Pragma_Arg) then
15156 if Chars (Get_Pragma_Arg (Arg1)) =
15157 Chars (Expression (System_Extend_Pragma_Arg))
15161 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
15162 Error_Pragma ("pragma% conflicts with that #");
15166 System_Extend_Pragma_Arg := Arg1;
15168 if not GNAT_Mode then
15169 System_Extend_Unit := Arg1;
15173 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
15176 ------------------------
15177 -- Extensions_Allowed --
15178 ------------------------
15180 -- pragma Extensions_Allowed (ON | OFF);
15182 when Pragma_Extensions_Allowed =>
15184 Check_Arg_Count (1);
15185 Check_No_Identifiers;
15186 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
15188 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
15189 Extensions_Allowed := True;
15190 Ada_Version := Ada_Version_Type'Last;
15193 Extensions_Allowed := False;
15194 Ada_Version := Ada_Version_Explicit;
15195 Ada_Version_Pragma := Empty;
15198 ------------------------
15199 -- Extensions_Visible --
15200 ------------------------
15202 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15204 -- Characteristics:
15206 -- * Analysis - The annotation is fully analyzed immediately upon
15207 -- elaboration as its expression must be static.
15209 -- * Expansion - None.
15211 -- * Template - The annotation utilizes the generic template of the
15212 -- related subprogram [body] when it is:
15214 -- aspect on subprogram declaration
15215 -- aspect on stand alone subprogram body
15216 -- pragma on stand alone subprogram body
15218 -- The annotation must prepare its own template when it is:
15220 -- pragma on subprogram declaration
15222 -- * Globals - Capture of global references must occur after full
15225 -- * Instance - The annotation is instantiated automatically when
15226 -- the related generic subprogram [body] is instantiated except for
15227 -- the "pragma on subprogram declaration" case. In that scenario
15228 -- the annotation must instantiate itself.
15230 when Pragma_Extensions_Visible => Extensions_Visible : declare
15231 Formal : Entity_Id;
15232 Has_OK_Formal : Boolean := False;
15233 Spec_Id : Entity_Id;
15234 Subp_Decl : Node_Id;
15238 Check_No_Identifiers;
15239 Check_At_Most_N_Arguments (1);
15242 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15244 -- Abstract subprogram declaration
15246 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15249 -- Generic subprogram declaration
15251 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15254 -- Body acts as spec
15256 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15257 and then No (Corresponding_Spec (Subp_Decl))
15261 -- Body stub acts as spec
15263 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15264 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15268 -- Subprogram declaration
15270 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15273 -- Otherwise the pragma is associated with an illegal construct
15276 Error_Pragma ("pragma % must apply to a subprogram");
15280 -- Mark the pragma as Ghost if the related subprogram is also
15281 -- Ghost. This also ensures that any expansion performed further
15282 -- below will produce Ghost nodes.
15284 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15285 Mark_Ghost_Pragma (N, Spec_Id);
15287 -- Chain the pragma on the contract for completeness
15289 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15291 -- The legality checks of pragma Extension_Visible are affected
15292 -- by the SPARK mode in effect. Analyze all pragmas in specific
15295 Analyze_If_Present (Pragma_SPARK_Mode);
15297 -- Examine the formals of the related subprogram
15299 Formal := First_Formal (Spec_Id);
15300 while Present (Formal) loop
15302 -- At least one of the formals is of a specific tagged type,
15303 -- the pragma is legal.
15305 if Is_Specific_Tagged_Type (Etype (Formal)) then
15306 Has_OK_Formal := True;
15309 -- A generic subprogram with at least one formal of a private
15310 -- type ensures the legality of the pragma because the actual
15311 -- may be specifically tagged. Note that this is verified by
15312 -- the check above at instantiation time.
15314 elsif Is_Private_Type (Etype (Formal))
15315 and then Is_Generic_Type (Etype (Formal))
15317 Has_OK_Formal := True;
15321 Next_Formal (Formal);
15324 if not Has_OK_Formal then
15325 Error_Msg_Name_1 := Pname;
15326 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15328 ("\subprogram & lacks parameter of specific tagged or "
15329 & "generic private type", N, Spec_Id);
15334 -- Analyze the Boolean expression (if any)
15336 if Present (Arg1) then
15337 Check_Static_Boolean_Expression
15338 (Expression (Get_Argument (N, Spec_Id)));
15340 end Extensions_Visible;
15346 -- pragma External (
15347 -- [ Convention =>] convention_IDENTIFIER,
15348 -- [ Entity =>] LOCAL_NAME
15349 -- [, [External_Name =>] static_string_EXPRESSION ]
15350 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15352 when Pragma_External => External : declare
15355 pragma Warnings (Off, C);
15362 Name_External_Name,
15364 Check_At_Least_N_Arguments (2);
15365 Check_At_Most_N_Arguments (4);
15366 Process_Convention (C, E);
15368 -- A pragma that applies to a Ghost entity becomes Ghost for the
15369 -- purposes of legality checks and removal of ignored Ghost code.
15371 Mark_Ghost_Pragma (N, E);
15373 Note_Possible_Modification
15374 (Get_Pragma_Arg (Arg2), Sure => False);
15375 Process_Interface_Name (E, Arg3, Arg4, N);
15376 Set_Exported (E, Arg2);
15379 --------------------------
15380 -- External_Name_Casing --
15381 --------------------------
15383 -- pragma External_Name_Casing (
15384 -- UPPERCASE | LOWERCASE
15385 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15387 when Pragma_External_Name_Casing =>
15389 Check_No_Identifiers;
15391 if Arg_Count = 2 then
15392 Check_Arg_Is_One_Of
15393 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15395 case Chars (Get_Pragma_Arg (Arg2)) is
15397 Opt.External_Name_Exp_Casing := As_Is;
15399 when Name_Uppercase =>
15400 Opt.External_Name_Exp_Casing := Uppercase;
15402 when Name_Lowercase =>
15403 Opt.External_Name_Exp_Casing := Lowercase;
15410 Check_Arg_Count (1);
15413 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15415 case Chars (Get_Pragma_Arg (Arg1)) is
15416 when Name_Uppercase =>
15417 Opt.External_Name_Imp_Casing := Uppercase;
15419 when Name_Lowercase =>
15420 Opt.External_Name_Imp_Casing := Lowercase;
15430 -- pragma Fast_Math;
15432 when Pragma_Fast_Math =>
15434 Check_No_Identifiers;
15435 Check_Valid_Configuration_Pragma;
15438 --------------------------
15439 -- Favor_Top_Level --
15440 --------------------------
15442 -- pragma Favor_Top_Level (type_NAME);
15444 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15449 Check_No_Identifiers;
15450 Check_Arg_Count (1);
15451 Check_Arg_Is_Local_Name (Arg1);
15452 Typ := Entity (Get_Pragma_Arg (Arg1));
15454 -- A pragma that applies to a Ghost entity becomes Ghost for the
15455 -- purposes of legality checks and removal of ignored Ghost code.
15457 Mark_Ghost_Pragma (N, Typ);
15459 -- If it's an access-to-subprogram type (in particular, not a
15460 -- subtype), set the flag on that type.
15462 if Is_Access_Subprogram_Type (Typ) then
15463 Set_Can_Use_Internal_Rep (Typ, False);
15465 -- Otherwise it's an error (name denotes the wrong sort of entity)
15469 ("access-to-subprogram type expected",
15470 Get_Pragma_Arg (Arg1));
15472 end Favor_Top_Level;
15474 ---------------------------
15475 -- Finalize_Storage_Only --
15476 ---------------------------
15478 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15480 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15481 Assoc : constant Node_Id := Arg1;
15482 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15487 Check_No_Identifiers;
15488 Check_Arg_Count (1);
15489 Check_Arg_Is_Local_Name (Arg1);
15491 Find_Type (Type_Id);
15492 Typ := Entity (Type_Id);
15495 or else Rep_Item_Too_Early (Typ, N)
15499 Typ := Underlying_Type (Typ);
15502 if not Is_Controlled (Typ) then
15503 Error_Pragma ("pragma% must specify controlled type");
15506 Check_First_Subtype (Arg1);
15508 if Finalize_Storage_Only (Typ) then
15509 Error_Pragma ("duplicate pragma%, only one allowed");
15511 elsif not Rep_Item_Too_Late (Typ, N) then
15512 Set_Finalize_Storage_Only (Base_Type (Typ), True);
15514 end Finalize_Storage;
15520 -- pragma Ghost [ (boolean_EXPRESSION) ];
15522 when Pragma_Ghost => Ghost : declare
15526 Orig_Stmt : Node_Id;
15527 Prev_Id : Entity_Id;
15532 Check_No_Identifiers;
15533 Check_At_Most_N_Arguments (1);
15537 while Present (Stmt) loop
15539 -- Skip prior pragmas, but check for duplicates
15541 if Nkind (Stmt) = N_Pragma then
15542 if Pragma_Name (Stmt) = Pname then
15549 -- Task unit declared without a definition cannot be subject to
15550 -- pragma Ghost (SPARK RM 6.9(19)).
15552 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15553 N_Task_Type_Declaration)
15555 Error_Pragma ("pragma % cannot apply to a task type");
15558 -- Skip internally generated code
15560 elsif not Comes_From_Source (Stmt) then
15561 Orig_Stmt := Original_Node (Stmt);
15563 -- When pragma Ghost applies to an untagged derivation, the
15564 -- derivation is transformed into a [sub]type declaration.
15566 if Nkind_In (Stmt, N_Full_Type_Declaration,
15567 N_Subtype_Declaration)
15568 and then Comes_From_Source (Orig_Stmt)
15569 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15570 and then Nkind (Type_Definition (Orig_Stmt)) =
15571 N_Derived_Type_Definition
15573 Id := Defining_Entity (Stmt);
15576 -- When pragma Ghost applies to an object declaration which
15577 -- is initialized by means of a function call that returns
15578 -- on the secondary stack, the object declaration becomes a
15581 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15582 and then Comes_From_Source (Orig_Stmt)
15583 and then Nkind (Orig_Stmt) = N_Object_Declaration
15585 Id := Defining_Entity (Stmt);
15588 -- When pragma Ghost applies to an expression function, the
15589 -- expression function is transformed into a subprogram.
15591 elsif Nkind (Stmt) = N_Subprogram_Declaration
15592 and then Comes_From_Source (Orig_Stmt)
15593 and then Nkind (Orig_Stmt) = N_Expression_Function
15595 Id := Defining_Entity (Stmt);
15599 -- The pragma applies to a legal construct, stop the traversal
15601 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15602 N_Full_Type_Declaration,
15603 N_Generic_Subprogram_Declaration,
15604 N_Object_Declaration,
15605 N_Private_Extension_Declaration,
15606 N_Private_Type_Declaration,
15607 N_Subprogram_Declaration,
15608 N_Subtype_Declaration)
15610 Id := Defining_Entity (Stmt);
15613 -- The pragma does not apply to a legal construct, issue an
15614 -- error and stop the analysis.
15618 ("pragma % must apply to an object, package, subprogram "
15623 Stmt := Prev (Stmt);
15626 Context := Parent (N);
15628 -- Handle compilation units
15630 if Nkind (Context) = N_Compilation_Unit_Aux then
15631 Context := Unit (Parent (Context));
15634 -- Protected and task types cannot be subject to pragma Ghost
15635 -- (SPARK RM 6.9(19)).
15637 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15639 Error_Pragma ("pragma % cannot apply to a protected type");
15642 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15643 Error_Pragma ("pragma % cannot apply to a task type");
15649 -- When pragma Ghost is associated with a [generic] package, it
15650 -- appears in the visible declarations.
15652 if Nkind (Context) = N_Package_Specification
15653 and then Present (Visible_Declarations (Context))
15654 and then List_Containing (N) = Visible_Declarations (Context)
15656 Id := Defining_Entity (Context);
15658 -- Pragma Ghost applies to a stand alone subprogram body
15660 elsif Nkind (Context) = N_Subprogram_Body
15661 and then No (Corresponding_Spec (Context))
15663 Id := Defining_Entity (Context);
15665 -- Pragma Ghost applies to a subprogram declaration that acts
15666 -- as a compilation unit.
15668 elsif Nkind (Context) = N_Subprogram_Declaration then
15669 Id := Defining_Entity (Context);
15675 ("pragma % must apply to an object, package, subprogram or "
15680 -- Handle completions of types and constants that are subject to
15683 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15684 Prev_Id := Incomplete_Or_Partial_View (Id);
15686 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15687 Error_Msg_Name_1 := Pname;
15689 -- The full declaration of a deferred constant cannot be
15690 -- subject to pragma Ghost unless the deferred declaration
15691 -- is also Ghost (SPARK RM 6.9(9)).
15693 if Ekind (Prev_Id) = E_Constant then
15694 Error_Msg_Name_1 := Pname;
15695 Error_Msg_NE (Fix_Error
15696 ("pragma % must apply to declaration of deferred "
15697 & "constant &"), N, Id);
15700 -- Pragma Ghost may appear on the full view of an incomplete
15701 -- type because the incomplete declaration lacks aspects and
15702 -- cannot be subject to pragma Ghost.
15704 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15707 -- The full declaration of a type cannot be subject to
15708 -- pragma Ghost unless the partial view is also Ghost
15709 -- (SPARK RM 6.9(9)).
15712 Error_Msg_NE (Fix_Error
15713 ("pragma % must apply to partial view of type &"),
15719 -- A synchronized object cannot be subject to pragma Ghost
15720 -- (SPARK RM 6.9(19)).
15722 elsif Ekind (Id) = E_Variable then
15723 if Is_Protected_Type (Etype (Id)) then
15724 Error_Pragma ("pragma % cannot apply to a protected object");
15727 elsif Is_Task_Type (Etype (Id)) then
15728 Error_Pragma ("pragma % cannot apply to a task object");
15733 -- Analyze the Boolean expression (if any)
15735 if Present (Arg1) then
15736 Expr := Get_Pragma_Arg (Arg1);
15738 Analyze_And_Resolve (Expr, Standard_Boolean);
15740 if Is_OK_Static_Expression (Expr) then
15742 -- "Ghostness" cannot be turned off once enabled within a
15743 -- region (SPARK RM 6.9(6)).
15745 if Is_False (Expr_Value (Expr))
15746 and then Ghost_Mode > None
15749 ("pragma % with value False cannot appear in enabled "
15754 -- Otherwie the expression is not static
15758 ("expression of pragma % must be static", Expr);
15763 Set_Is_Ghost_Entity (Id);
15770 -- pragma Global (GLOBAL_SPECIFICATION);
15772 -- GLOBAL_SPECIFICATION ::=
15775 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15777 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15779 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15780 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15781 -- GLOBAL_ITEM ::= NAME
15783 -- Characteristics:
15785 -- * Analysis - The annotation undergoes initial checks to verify
15786 -- the legal placement and context. Secondary checks fully analyze
15787 -- the dependency clauses in:
15789 -- Analyze_Global_In_Decl_Part
15791 -- * Expansion - None.
15793 -- * Template - The annotation utilizes the generic template of the
15794 -- related subprogram [body] when it is:
15796 -- aspect on subprogram declaration
15797 -- aspect on stand alone subprogram body
15798 -- pragma on stand alone subprogram body
15800 -- The annotation must prepare its own template when it is:
15802 -- pragma on subprogram declaration
15804 -- * Globals - Capture of global references must occur after full
15807 -- * Instance - The annotation is instantiated automatically when
15808 -- the related generic subprogram [body] is instantiated except for
15809 -- the "pragma on subprogram declaration" case. In that scenario
15810 -- the annotation must instantiate itself.
15812 when Pragma_Global => Global : declare
15814 Spec_Id : Entity_Id;
15815 Subp_Decl : Node_Id;
15818 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15822 -- Chain the pragma on the contract for further processing by
15823 -- Analyze_Global_In_Decl_Part.
15825 Add_Contract_Item (N, Spec_Id);
15827 -- Fully analyze the pragma when it appears inside an entry
15828 -- or subprogram body because it cannot benefit from forward
15831 if Nkind_In (Subp_Decl, N_Entry_Body,
15833 N_Subprogram_Body_Stub)
15835 -- The legality checks of pragmas Depends and Global are
15836 -- affected by the SPARK mode in effect and the volatility
15837 -- of the context. In addition these two pragmas are subject
15838 -- to an inherent order:
15843 -- Analyze all these pragmas in the order outlined above
15845 Analyze_If_Present (Pragma_SPARK_Mode);
15846 Analyze_If_Present (Pragma_Volatile_Function);
15847 Analyze_Global_In_Decl_Part (N);
15848 Analyze_If_Present (Pragma_Depends);
15857 -- pragma Ident (static_string_EXPRESSION)
15859 -- Note: pragma Comment shares this processing. Pragma Ident is
15860 -- identical in effect to pragma Commment.
15862 when Pragma_Comment
15870 Check_Arg_Count (1);
15871 Check_No_Identifiers;
15872 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15875 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15882 GP := Parent (Parent (N));
15884 if Nkind_In (GP, N_Package_Declaration,
15885 N_Generic_Package_Declaration)
15890 -- If we have a compilation unit, then record the ident value,
15891 -- checking for improper duplication.
15893 if Nkind (GP) = N_Compilation_Unit then
15894 CS := Ident_String (Current_Sem_Unit);
15896 if Present (CS) then
15898 -- If we have multiple instances, concatenate them, but
15899 -- not in ASIS, where we want the original tree.
15901 if not ASIS_Mode then
15902 Start_String (Strval (CS));
15903 Store_String_Char (' ');
15904 Store_String_Chars (Strval (Str));
15905 Set_Strval (CS, End_String);
15909 Set_Ident_String (Current_Sem_Unit, Str);
15912 -- For subunits, we just ignore the Ident, since in GNAT these
15913 -- are not separate object files, and hence not separate units
15914 -- in the unit table.
15916 elsif Nkind (GP) = N_Subunit then
15922 -------------------
15923 -- Ignore_Pragma --
15924 -------------------
15926 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15928 -- Entirely handled in the parser, nothing to do here
15930 when Pragma_Ignore_Pragma =>
15933 ----------------------------
15934 -- Implementation_Defined --
15935 ----------------------------
15937 -- pragma Implementation_Defined (LOCAL_NAME);
15939 -- Marks previously declared entity as implementation defined. For
15940 -- an overloaded entity, applies to the most recent homonym.
15942 -- pragma Implementation_Defined;
15944 -- The form with no arguments appears anywhere within a scope, most
15945 -- typically a package spec, and indicates that all entities that are
15946 -- defined within the package spec are Implementation_Defined.
15948 when Pragma_Implementation_Defined => Implementation_Defined : declare
15953 Check_No_Identifiers;
15955 -- Form with no arguments
15957 if Arg_Count = 0 then
15958 Set_Is_Implementation_Defined (Current_Scope);
15960 -- Form with one argument
15963 Check_Arg_Count (1);
15964 Check_Arg_Is_Local_Name (Arg1);
15965 Ent := Entity (Get_Pragma_Arg (Arg1));
15966 Set_Is_Implementation_Defined (Ent);
15968 end Implementation_Defined;
15974 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15976 -- IMPLEMENTATION_KIND ::=
15977 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15979 -- "By_Any" and "Optional" are treated as synonyms in order to
15980 -- support Ada 2012 aspect Synchronization.
15982 when Pragma_Implemented => Implemented : declare
15983 Proc_Id : Entity_Id;
15988 Check_Arg_Count (2);
15989 Check_No_Identifiers;
15990 Check_Arg_Is_Identifier (Arg1);
15991 Check_Arg_Is_Local_Name (Arg1);
15992 Check_Arg_Is_One_Of (Arg2,
15995 Name_By_Protected_Procedure,
15998 -- Extract the name of the local procedure
16000 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
16002 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16003 -- primitive procedure of a synchronized tagged type.
16005 if Ekind (Proc_Id) = E_Procedure
16006 and then Is_Primitive (Proc_Id)
16007 and then Present (First_Formal (Proc_Id))
16009 Typ := Etype (First_Formal (Proc_Id));
16011 if Is_Tagged_Type (Typ)
16014 -- Check for a protected, a synchronized or a task interface
16016 ((Is_Interface (Typ)
16017 and then Is_Synchronized_Interface (Typ))
16019 -- Check for a protected type or a task type that implements
16023 (Is_Concurrent_Record_Type (Typ)
16024 and then Present (Interfaces (Typ)))
16026 -- In analysis-only mode, examine original protected type
16029 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
16030 and then Present (Interface_List (Parent (Typ))))
16032 -- Check for a private record extension with keyword
16036 (Ekind_In (Typ, E_Record_Type_With_Private,
16037 E_Record_Subtype_With_Private)
16038 and then Synchronized_Present (Parent (Typ))))
16043 ("controlling formal must be of synchronized tagged type",
16048 -- Procedures declared inside a protected type must be accepted
16050 elsif Ekind (Proc_Id) = E_Procedure
16051 and then Is_Protected_Type (Scope (Proc_Id))
16055 -- The first argument is not a primitive procedure
16059 ("pragma % must be applied to a primitive procedure", Arg1);
16063 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16064 -- By_Protected_Procedure to the primitive procedure of a task
16067 if Chars (Arg2) = Name_By_Protected_Procedure
16068 and then Is_Interface (Typ)
16069 and then Is_Task_Interface (Typ)
16072 ("implementation kind By_Protected_Procedure cannot be "
16073 & "applied to a task interface primitive", Arg2);
16077 Record_Rep_Item (Proc_Id, N);
16080 ----------------------
16081 -- Implicit_Packing --
16082 ----------------------
16084 -- pragma Implicit_Packing;
16086 when Pragma_Implicit_Packing =>
16088 Check_Arg_Count (0);
16089 Implicit_Packing := True;
16096 -- [Convention =>] convention_IDENTIFIER,
16097 -- [Entity =>] LOCAL_NAME
16098 -- [, [External_Name =>] static_string_EXPRESSION ]
16099 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16101 when Pragma_Import =>
16102 Check_Ada_83_Warning;
16106 Name_External_Name,
16109 Check_At_Least_N_Arguments (2);
16110 Check_At_Most_N_Arguments (4);
16111 Process_Import_Or_Interface;
16113 ---------------------
16114 -- Import_Function --
16115 ---------------------
16117 -- pragma Import_Function (
16118 -- [Internal =>] LOCAL_NAME,
16119 -- [, [External =>] EXTERNAL_SYMBOL]
16120 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16121 -- [, [Result_Type =>] SUBTYPE_MARK]
16122 -- [, [Mechanism =>] MECHANISM]
16123 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16125 -- EXTERNAL_SYMBOL ::=
16127 -- | static_string_EXPRESSION
16129 -- PARAMETER_TYPES ::=
16131 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16133 -- TYPE_DESIGNATOR ::=
16135 -- | subtype_Name ' Access
16139 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16141 -- MECHANISM_ASSOCIATION ::=
16142 -- [formal_parameter_NAME =>] MECHANISM_NAME
16144 -- MECHANISM_NAME ::=
16148 when Pragma_Import_Function => Import_Function : declare
16149 Args : Args_List (1 .. 6);
16150 Names : constant Name_List (1 .. 6) := (
16153 Name_Parameter_Types,
16156 Name_Result_Mechanism);
16158 Internal : Node_Id renames Args (1);
16159 External : Node_Id renames Args (2);
16160 Parameter_Types : Node_Id renames Args (3);
16161 Result_Type : Node_Id renames Args (4);
16162 Mechanism : Node_Id renames Args (5);
16163 Result_Mechanism : Node_Id renames Args (6);
16167 Gather_Associations (Names, Args);
16168 Process_Extended_Import_Export_Subprogram_Pragma (
16169 Arg_Internal => Internal,
16170 Arg_External => External,
16171 Arg_Parameter_Types => Parameter_Types,
16172 Arg_Result_Type => Result_Type,
16173 Arg_Mechanism => Mechanism,
16174 Arg_Result_Mechanism => Result_Mechanism);
16175 end Import_Function;
16177 -------------------
16178 -- Import_Object --
16179 -------------------
16181 -- pragma Import_Object (
16182 -- [Internal =>] LOCAL_NAME
16183 -- [, [External =>] EXTERNAL_SYMBOL]
16184 -- [, [Size =>] EXTERNAL_SYMBOL]);
16186 -- EXTERNAL_SYMBOL ::=
16188 -- | static_string_EXPRESSION
16190 when Pragma_Import_Object => Import_Object : declare
16191 Args : Args_List (1 .. 3);
16192 Names : constant Name_List (1 .. 3) := (
16197 Internal : Node_Id renames Args (1);
16198 External : Node_Id renames Args (2);
16199 Size : Node_Id renames Args (3);
16203 Gather_Associations (Names, Args);
16204 Process_Extended_Import_Export_Object_Pragma (
16205 Arg_Internal => Internal,
16206 Arg_External => External,
16210 ----------------------
16211 -- Import_Procedure --
16212 ----------------------
16214 -- pragma Import_Procedure (
16215 -- [Internal =>] LOCAL_NAME
16216 -- [, [External =>] EXTERNAL_SYMBOL]
16217 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16218 -- [, [Mechanism =>] MECHANISM]);
16220 -- EXTERNAL_SYMBOL ::=
16222 -- | static_string_EXPRESSION
16224 -- PARAMETER_TYPES ::=
16226 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16228 -- TYPE_DESIGNATOR ::=
16230 -- | subtype_Name ' Access
16234 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16236 -- MECHANISM_ASSOCIATION ::=
16237 -- [formal_parameter_NAME =>] MECHANISM_NAME
16239 -- MECHANISM_NAME ::=
16243 when Pragma_Import_Procedure => Import_Procedure : declare
16244 Args : Args_List (1 .. 4);
16245 Names : constant Name_List (1 .. 4) := (
16248 Name_Parameter_Types,
16251 Internal : Node_Id renames Args (1);
16252 External : Node_Id renames Args (2);
16253 Parameter_Types : Node_Id renames Args (3);
16254 Mechanism : Node_Id renames Args (4);
16258 Gather_Associations (Names, Args);
16259 Process_Extended_Import_Export_Subprogram_Pragma (
16260 Arg_Internal => Internal,
16261 Arg_External => External,
16262 Arg_Parameter_Types => Parameter_Types,
16263 Arg_Mechanism => Mechanism);
16264 end Import_Procedure;
16266 -----------------------------
16267 -- Import_Valued_Procedure --
16268 -----------------------------
16270 -- pragma Import_Valued_Procedure (
16271 -- [Internal =>] LOCAL_NAME
16272 -- [, [External =>] EXTERNAL_SYMBOL]
16273 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16274 -- [, [Mechanism =>] MECHANISM]);
16276 -- EXTERNAL_SYMBOL ::=
16278 -- | static_string_EXPRESSION
16280 -- PARAMETER_TYPES ::=
16282 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16284 -- TYPE_DESIGNATOR ::=
16286 -- | subtype_Name ' Access
16290 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16292 -- MECHANISM_ASSOCIATION ::=
16293 -- [formal_parameter_NAME =>] MECHANISM_NAME
16295 -- MECHANISM_NAME ::=
16299 when Pragma_Import_Valued_Procedure =>
16300 Import_Valued_Procedure : declare
16301 Args : Args_List (1 .. 4);
16302 Names : constant Name_List (1 .. 4) := (
16305 Name_Parameter_Types,
16308 Internal : Node_Id renames Args (1);
16309 External : Node_Id renames Args (2);
16310 Parameter_Types : Node_Id renames Args (3);
16311 Mechanism : Node_Id renames Args (4);
16315 Gather_Associations (Names, Args);
16316 Process_Extended_Import_Export_Subprogram_Pragma (
16317 Arg_Internal => Internal,
16318 Arg_External => External,
16319 Arg_Parameter_Types => Parameter_Types,
16320 Arg_Mechanism => Mechanism);
16321 end Import_Valued_Procedure;
16327 -- pragma Independent (LOCAL_NAME);
16329 when Pragma_Independent =>
16330 Process_Atomic_Independent_Shared_Volatile;
16332 ----------------------------
16333 -- Independent_Components --
16334 ----------------------------
16336 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16338 when Pragma_Independent_Components => Independent_Components : declare
16346 Check_Ada_83_Warning;
16348 Check_No_Identifiers;
16349 Check_Arg_Count (1);
16350 Check_Arg_Is_Local_Name (Arg1);
16351 E_Id := Get_Pragma_Arg (Arg1);
16353 if Etype (E_Id) = Any_Type then
16357 E := Entity (E_Id);
16359 -- A pragma that applies to a Ghost entity becomes Ghost for the
16360 -- purposes of legality checks and removal of ignored Ghost code.
16362 Mark_Ghost_Pragma (N, E);
16364 -- Check duplicate before we chain ourselves
16366 Check_Duplicate_Pragma (E);
16368 -- Check appropriate entity
16370 if Rep_Item_Too_Early (E, N)
16372 Rep_Item_Too_Late (E, N)
16377 D := Declaration_Node (E);
16380 -- The flag is set on the base type, or on the object
16382 if K = N_Full_Type_Declaration
16383 and then (Is_Array_Type (E) or else Is_Record_Type (E))
16385 Set_Has_Independent_Components (Base_Type (E));
16386 Record_Independence_Check (N, Base_Type (E));
16388 -- For record type, set all components independent
16390 if Is_Record_Type (E) then
16391 C := First_Component (E);
16392 while Present (C) loop
16393 Set_Is_Independent (C);
16394 Next_Component (C);
16398 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16399 and then Nkind (D) = N_Object_Declaration
16400 and then Nkind (Object_Definition (D)) =
16401 N_Constrained_Array_Definition
16403 Set_Has_Independent_Components (E);
16404 Record_Independence_Check (N, E);
16407 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16409 end Independent_Components;
16411 -----------------------
16412 -- Initial_Condition --
16413 -----------------------
16415 -- pragma Initial_Condition (boolean_EXPRESSION);
16417 -- Characteristics:
16419 -- * Analysis - The annotation undergoes initial checks to verify
16420 -- the legal placement and context. Secondary checks preanalyze the
16423 -- Analyze_Initial_Condition_In_Decl_Part
16425 -- * Expansion - The annotation is expanded during the expansion of
16426 -- the package body whose declaration is subject to the annotation
16429 -- Expand_Pragma_Initial_Condition
16431 -- * Template - The annotation utilizes the generic template of the
16432 -- related package declaration.
16434 -- * Globals - Capture of global references must occur after full
16437 -- * Instance - The annotation is instantiated automatically when
16438 -- the related generic package is instantiated.
16440 when Pragma_Initial_Condition => Initial_Condition : declare
16441 Pack_Decl : Node_Id;
16442 Pack_Id : Entity_Id;
16446 Check_No_Identifiers;
16447 Check_Arg_Count (1);
16449 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16451 -- Ensure the proper placement of the pragma. Initial_Condition
16452 -- must be associated with a package declaration.
16454 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16455 N_Package_Declaration)
16459 -- Otherwise the pragma is associated with an illegal context
16466 Pack_Id := Defining_Entity (Pack_Decl);
16468 -- A pragma that applies to a Ghost entity becomes Ghost for the
16469 -- purposes of legality checks and removal of ignored Ghost code.
16471 Mark_Ghost_Pragma (N, Pack_Id);
16473 -- Chain the pragma on the contract for further processing by
16474 -- Analyze_Initial_Condition_In_Decl_Part.
16476 Add_Contract_Item (N, Pack_Id);
16478 -- The legality checks of pragmas Abstract_State, Initializes, and
16479 -- Initial_Condition are affected by the SPARK mode in effect. In
16480 -- addition, these three pragmas are subject to an inherent order:
16482 -- 1) Abstract_State
16484 -- 3) Initial_Condition
16486 -- Analyze all these pragmas in the order outlined above
16488 Analyze_If_Present (Pragma_SPARK_Mode);
16489 Analyze_If_Present (Pragma_Abstract_State);
16490 Analyze_If_Present (Pragma_Initializes);
16491 end Initial_Condition;
16493 ------------------------
16494 -- Initialize_Scalars --
16495 ------------------------
16497 -- pragma Initialize_Scalars;
16499 when Pragma_Initialize_Scalars =>
16501 Check_Arg_Count (0);
16502 Check_Valid_Configuration_Pragma;
16503 Check_Restriction (No_Initialize_Scalars, N);
16505 -- Initialize_Scalars creates false positives in CodePeer, and
16506 -- incorrect negative results in GNATprove mode, so ignore this
16507 -- pragma in these modes.
16509 if not Restriction_Active (No_Initialize_Scalars)
16510 and then not (CodePeer_Mode or GNATprove_Mode)
16512 Init_Or_Norm_Scalars := True;
16513 Initialize_Scalars := True;
16520 -- pragma Initializes (INITIALIZATION_LIST);
16522 -- INITIALIZATION_LIST ::=
16524 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16526 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16531 -- | (INPUT {, INPUT})
16535 -- Characteristics:
16537 -- * Analysis - The annotation undergoes initial checks to verify
16538 -- the legal placement and context. Secondary checks preanalyze the
16541 -- Analyze_Initializes_In_Decl_Part
16543 -- * Expansion - None.
16545 -- * Template - The annotation utilizes the generic template of the
16546 -- related package declaration.
16548 -- * Globals - Capture of global references must occur after full
16551 -- * Instance - The annotation is instantiated automatically when
16552 -- the related generic package is instantiated.
16554 when Pragma_Initializes => Initializes : declare
16555 Pack_Decl : Node_Id;
16556 Pack_Id : Entity_Id;
16560 Check_No_Identifiers;
16561 Check_Arg_Count (1);
16563 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16565 -- Ensure the proper placement of the pragma. Initializes must be
16566 -- associated with a package declaration.
16568 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16569 N_Package_Declaration)
16573 -- Otherwise the pragma is associated with an illegal construc
16580 Pack_Id := Defining_Entity (Pack_Decl);
16582 -- A pragma that applies to a Ghost entity becomes Ghost for the
16583 -- purposes of legality checks and removal of ignored Ghost code.
16585 Mark_Ghost_Pragma (N, Pack_Id);
16586 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16588 -- Chain the pragma on the contract for further processing by
16589 -- Analyze_Initializes_In_Decl_Part.
16591 Add_Contract_Item (N, Pack_Id);
16593 -- The legality checks of pragmas Abstract_State, Initializes, and
16594 -- Initial_Condition are affected by the SPARK mode in effect. In
16595 -- addition, these three pragmas are subject to an inherent order:
16597 -- 1) Abstract_State
16599 -- 3) Initial_Condition
16601 -- Analyze all these pragmas in the order outlined above
16603 Analyze_If_Present (Pragma_SPARK_Mode);
16604 Analyze_If_Present (Pragma_Abstract_State);
16605 Analyze_If_Present (Pragma_Initial_Condition);
16612 -- pragma Inline ( NAME {, NAME} );
16614 when Pragma_Inline =>
16616 -- Pragma always active unless in GNATprove mode. It is disabled
16617 -- in GNATprove mode because frontend inlining is applied
16618 -- independently of pragmas Inline and Inline_Always for
16619 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16622 if not GNATprove_Mode then
16624 -- Inline status is Enabled if option -gnatn is specified.
16625 -- However this status determines only the value of the
16626 -- Is_Inlined flag on the subprogram and does not prevent
16627 -- the pragma itself from being recorded for later use,
16628 -- in particular for a later modification of Is_Inlined
16629 -- independently of the -gnatn option.
16631 -- In other words, if -gnatn is specified for a unit, then
16632 -- all Inline pragmas processed for the compilation of this
16633 -- unit, including those in the spec of other units, are
16634 -- activated, so subprograms will be inlined across units.
16636 -- If -gnatn is not specified, no Inline pragma is activated
16637 -- here, which means that subprograms will not be inlined
16638 -- across units. The Is_Inlined flag will nevertheless be
16639 -- set later when bodies are analyzed, so subprograms will
16640 -- be inlined within the unit.
16642 if Inline_Active then
16643 Process_Inline (Enabled);
16645 Process_Inline (Disabled);
16649 -------------------
16650 -- Inline_Always --
16651 -------------------
16653 -- pragma Inline_Always ( NAME {, NAME} );
16655 when Pragma_Inline_Always =>
16658 -- Pragma always active unless in CodePeer mode or GNATprove
16659 -- mode. It is disabled in CodePeer mode because inlining is
16660 -- not helpful, and enabling it caused walk order issues. It
16661 -- is disabled in GNATprove mode because frontend inlining is
16662 -- applied independently of pragmas Inline and Inline_Always for
16663 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16666 if not CodePeer_Mode and not GNATprove_Mode then
16667 Process_Inline (Enabled);
16670 --------------------
16671 -- Inline_Generic --
16672 --------------------
16674 -- pragma Inline_Generic (NAME {, NAME});
16676 when Pragma_Inline_Generic =>
16678 Process_Generic_List;
16680 ----------------------
16681 -- Inspection_Point --
16682 ----------------------
16684 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16686 when Pragma_Inspection_Point => Inspection_Point : declare
16693 if Arg_Count > 0 then
16696 Exp := Get_Pragma_Arg (Arg);
16699 if not Is_Entity_Name (Exp)
16700 or else not Is_Object (Entity (Exp))
16702 Error_Pragma_Arg ("object name required", Arg);
16706 exit when No (Arg);
16709 end Inspection_Point;
16715 -- pragma Interface (
16716 -- [ Convention =>] convention_IDENTIFIER,
16717 -- [ Entity =>] LOCAL_NAME
16718 -- [, [External_Name =>] static_string_EXPRESSION ]
16719 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16721 when Pragma_Interface =>
16726 Name_External_Name,
16728 Check_At_Least_N_Arguments (2);
16729 Check_At_Most_N_Arguments (4);
16730 Process_Import_Or_Interface;
16732 -- In Ada 2005, the permission to use Interface (a reserved word)
16733 -- as a pragma name is considered an obsolescent feature, and this
16734 -- pragma was already obsolescent in Ada 95.
16736 if Ada_Version >= Ada_95 then
16738 (No_Obsolescent_Features, Pragma_Identifier (N));
16740 if Warn_On_Obsolescent_Feature then
16742 ("pragma Interface is an obsolescent feature?j?", N);
16744 ("|use pragma Import instead?j?", N);
16748 --------------------
16749 -- Interface_Name --
16750 --------------------
16752 -- pragma Interface_Name (
16753 -- [ Entity =>] LOCAL_NAME
16754 -- [,[External_Name =>] static_string_EXPRESSION ]
16755 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16757 when Pragma_Interface_Name => Interface_Name : declare
16759 Def_Id : Entity_Id;
16760 Hom_Id : Entity_Id;
16766 ((Name_Entity, Name_External_Name, Name_Link_Name));
16767 Check_At_Least_N_Arguments (2);
16768 Check_At_Most_N_Arguments (3);
16769 Id := Get_Pragma_Arg (Arg1);
16772 -- This is obsolete from Ada 95 on, but it is an implementation
16773 -- defined pragma, so we do not consider that it violates the
16774 -- restriction (No_Obsolescent_Features).
16776 if Ada_Version >= Ada_95 then
16777 if Warn_On_Obsolescent_Feature then
16779 ("pragma Interface_Name is an obsolescent feature?j?", N);
16781 ("|use pragma Import instead?j?", N);
16785 if not Is_Entity_Name (Id) then
16787 ("first argument for pragma% must be entity name", Arg1);
16788 elsif Etype (Id) = Any_Type then
16791 Def_Id := Entity (Id);
16794 -- Special DEC-compatible processing for the object case, forces
16795 -- object to be imported.
16797 if Ekind (Def_Id) = E_Variable then
16798 Kill_Size_Check_Code (Def_Id);
16799 Note_Possible_Modification (Id, Sure => False);
16801 -- Initialization is not allowed for imported variable
16803 if Present (Expression (Parent (Def_Id)))
16804 and then Comes_From_Source (Expression (Parent (Def_Id)))
16806 Error_Msg_Sloc := Sloc (Def_Id);
16808 ("no initialization allowed for declaration of& #",
16812 -- For compatibility, support VADS usage of providing both
16813 -- pragmas Interface and Interface_Name to obtain the effect
16814 -- of a single Import pragma.
16816 if Is_Imported (Def_Id)
16817 and then Present (First_Rep_Item (Def_Id))
16818 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16819 and then Pragma_Name (First_Rep_Item (Def_Id)) =
16824 Set_Imported (Def_Id);
16827 Set_Is_Public (Def_Id);
16828 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16831 -- Otherwise must be subprogram
16833 elsif not Is_Subprogram (Def_Id) then
16835 ("argument of pragma% is not subprogram", Arg1);
16838 Check_At_Most_N_Arguments (3);
16842 -- Loop through homonyms
16845 Def_Id := Get_Base_Subprogram (Hom_Id);
16847 if Is_Imported (Def_Id) then
16848 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
16852 exit when From_Aspect_Specification (N);
16853 Hom_Id := Homonym (Hom_Id);
16855 exit when No (Hom_Id)
16856 or else Scope (Hom_Id) /= Current_Scope;
16861 ("argument of pragma% is not imported subprogram",
16865 end Interface_Name;
16867 -----------------------
16868 -- Interrupt_Handler --
16869 -----------------------
16871 -- pragma Interrupt_Handler (handler_NAME);
16873 when Pragma_Interrupt_Handler =>
16874 Check_Ada_83_Warning;
16875 Check_Arg_Count (1);
16876 Check_No_Identifiers;
16878 if No_Run_Time_Mode then
16879 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16881 Check_Interrupt_Or_Attach_Handler;
16882 Process_Interrupt_Or_Attach_Handler;
16885 ------------------------
16886 -- Interrupt_Priority --
16887 ------------------------
16889 -- pragma Interrupt_Priority [(EXPRESSION)];
16891 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16892 P : constant Node_Id := Parent (N);
16897 Check_Ada_83_Warning;
16899 if Arg_Count /= 0 then
16900 Arg := Get_Pragma_Arg (Arg1);
16901 Check_Arg_Count (1);
16902 Check_No_Identifiers;
16904 -- The expression must be analyzed in the special manner
16905 -- described in "Handling of Default and Per-Object
16906 -- Expressions" in sem.ads.
16908 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16911 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16916 Ent := Defining_Identifier (Parent (P));
16918 -- Check duplicate pragma before we chain the pragma in the Rep
16919 -- Item chain of Ent.
16921 Check_Duplicate_Pragma (Ent);
16922 Record_Rep_Item (Ent, N);
16924 -- Check the No_Task_At_Interrupt_Priority restriction
16926 if Nkind (P) = N_Task_Definition then
16927 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16930 end Interrupt_Priority;
16932 ---------------------
16933 -- Interrupt_State --
16934 ---------------------
16936 -- pragma Interrupt_State (
16937 -- [Name =>] INTERRUPT_ID,
16938 -- [State =>] INTERRUPT_STATE);
16940 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16941 -- INTERRUPT_STATE => System | Runtime | User
16943 -- Note: if the interrupt id is given as an identifier, then it must
16944 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16945 -- given as a static integer expression which must be in the range of
16946 -- Ada.Interrupts.Interrupt_ID.
16948 when Pragma_Interrupt_State => Interrupt_State : declare
16949 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16950 -- This is the entity Ada.Interrupts.Interrupt_ID;
16952 State_Type : Character;
16953 -- Set to 's'/'r'/'u' for System/Runtime/User
16956 -- Index to entry in Interrupt_States table
16959 -- Value of interrupt
16961 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16962 -- The first argument to the pragma
16964 Int_Ent : Entity_Id;
16965 -- Interrupt entity in Ada.Interrupts.Names
16969 Check_Arg_Order ((Name_Name, Name_State));
16970 Check_Arg_Count (2);
16972 Check_Optional_Identifier (Arg1, Name_Name);
16973 Check_Optional_Identifier (Arg2, Name_State);
16974 Check_Arg_Is_Identifier (Arg2);
16976 -- First argument is identifier
16978 if Nkind (Arg1X) = N_Identifier then
16980 -- Search list of names in Ada.Interrupts.Names
16982 Int_Ent := First_Entity (RTE (RE_Names));
16984 if No (Int_Ent) then
16985 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16987 elsif Chars (Int_Ent) = Chars (Arg1X) then
16988 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16992 Next_Entity (Int_Ent);
16995 -- First argument is not an identifier, so it must be a static
16996 -- expression of type Ada.Interrupts.Interrupt_ID.
16999 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
17000 Int_Val := Expr_Value (Arg1X);
17002 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
17004 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
17007 ("value not in range of type "
17008 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
17014 case Chars (Get_Pragma_Arg (Arg2)) is
17015 when Name_Runtime => State_Type := 'r';
17016 when Name_System => State_Type := 's';
17017 when Name_User => State_Type := 'u';
17020 Error_Pragma_Arg ("invalid interrupt state", Arg2);
17023 -- Check if entry is already stored
17025 IST_Num := Interrupt_States.First;
17027 -- If entry not found, add it
17029 if IST_Num > Interrupt_States.Last then
17030 Interrupt_States.Append
17031 ((Interrupt_Number => UI_To_Int (Int_Val),
17032 Interrupt_State => State_Type,
17033 Pragma_Loc => Loc));
17036 -- Case of entry for the same entry
17038 elsif Int_Val = Interrupt_States.Table (IST_Num).
17041 -- If state matches, done, no need to make redundant entry
17044 State_Type = Interrupt_States.Table (IST_Num).
17047 -- Otherwise if state does not match, error
17050 Interrupt_States.Table (IST_Num).Pragma_Loc;
17052 ("state conflicts with that given #", Arg2);
17056 IST_Num := IST_Num + 1;
17058 end Interrupt_State;
17064 -- pragma Invariant
17065 -- ([Entity =>] type_LOCAL_NAME,
17066 -- [Check =>] EXPRESSION
17067 -- [,[Message =>] String_Expression]);
17069 when Pragma_Invariant => Invariant : declare
17076 Check_At_Least_N_Arguments (2);
17077 Check_At_Most_N_Arguments (3);
17078 Check_Optional_Identifier (Arg1, Name_Entity);
17079 Check_Optional_Identifier (Arg2, Name_Check);
17081 if Arg_Count = 3 then
17082 Check_Optional_Identifier (Arg3, Name_Message);
17083 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
17086 Check_Arg_Is_Local_Name (Arg1);
17088 Typ_Arg := Get_Pragma_Arg (Arg1);
17089 Find_Type (Typ_Arg);
17090 Typ := Entity (Typ_Arg);
17092 -- Nothing to do of the related type is erroneous in some way
17094 if Typ = Any_Type then
17097 -- AI12-0041: Invariants are allowed in interface types
17099 elsif Is_Interface (Typ) then
17102 -- An invariant must apply to a private type, or appear in the
17103 -- private part of a package spec and apply to a completion.
17104 -- a class-wide invariant can only appear on a private declaration
17105 -- or private extension, not a completion.
17107 -- A [class-wide] invariant may be associated a [limited] private
17108 -- type or a private extension.
17110 elsif Ekind_In (Typ, E_Limited_Private_Type,
17112 E_Record_Type_With_Private)
17116 -- A non-class-wide invariant may be associated with the full view
17117 -- of a [limited] private type or a private extension.
17119 elsif Has_Private_Declaration (Typ)
17120 and then not Class_Present (N)
17124 -- A class-wide invariant may appear on the partial view only
17126 elsif Class_Present (N) then
17128 ("pragma % only allowed for private type", Arg1);
17131 -- A regular invariant may appear on both views
17135 ("pragma % only allowed for private type or corresponding "
17136 & "full view", Arg1);
17140 -- An invariant associated with an abstract type (this includes
17141 -- interfaces) must be class-wide.
17143 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
17145 ("pragma % not allowed for abstract type", Arg1);
17149 -- A pragma that applies to a Ghost entity becomes Ghost for the
17150 -- purposes of legality checks and removal of ignored Ghost code.
17152 Mark_Ghost_Pragma (N, Typ);
17154 -- The pragma defines a type-specific invariant, the type is said
17155 -- to have invariants of its "own".
17157 Set_Has_Own_Invariants (Typ);
17159 -- If the invariant is class-wide, then it can be inherited by
17160 -- derived or interface implementing types. The type is said to
17161 -- have "inheritable" invariants.
17163 if Class_Present (N) then
17164 Set_Has_Inheritable_Invariants (Typ);
17167 -- Chain the pragma on to the rep item chain, for processing when
17168 -- the type is frozen.
17170 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
17172 -- Create the declaration of the invariant procedure that will
17173 -- verify the invariant at run time. Interfaces are treated as the
17174 -- partial view of a private type in order to achieve uniformity
17175 -- with the general case. As a result, an interface receives only
17176 -- a "partial" invariant procedure, which is never called.
17178 Build_Invariant_Procedure_Declaration
17180 Partial_Invariant => Is_Interface (Typ));
17187 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17189 when Pragma_Keep_Names => Keep_Names : declare
17194 Check_Arg_Count (1);
17195 Check_Optional_Identifier (Arg1, Name_On);
17196 Check_Arg_Is_Local_Name (Arg1);
17198 Arg := Get_Pragma_Arg (Arg1);
17201 if Etype (Arg) = Any_Type then
17205 if not Is_Entity_Name (Arg)
17206 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
17209 ("pragma% requires a local enumeration type", Arg1);
17212 Set_Discard_Names (Entity (Arg), False);
17219 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17221 when Pragma_License =>
17224 -- Do not analyze pragma any further in CodePeer mode, to avoid
17225 -- extraneous errors in this implementation-dependent pragma,
17226 -- which has a different profile on other compilers.
17228 if CodePeer_Mode then
17232 Check_Arg_Count (1);
17233 Check_No_Identifiers;
17234 Check_Valid_Configuration_Pragma;
17235 Check_Arg_Is_Identifier (Arg1);
17238 Sind : constant Source_File_Index :=
17239 Source_Index (Current_Sem_Unit);
17242 case Chars (Get_Pragma_Arg (Arg1)) is
17244 Set_License (Sind, GPL);
17246 when Name_Modified_GPL =>
17247 Set_License (Sind, Modified_GPL);
17249 when Name_Restricted =>
17250 Set_License (Sind, Restricted);
17252 when Name_Unrestricted =>
17253 Set_License (Sind, Unrestricted);
17256 Error_Pragma_Arg ("invalid license name", Arg1);
17264 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17266 when Pragma_Link_With => Link_With : declare
17272 if Operating_Mode = Generate_Code
17273 and then In_Extended_Main_Source_Unit (N)
17275 Check_At_Least_N_Arguments (1);
17276 Check_No_Identifiers;
17277 Check_Is_In_Decl_Part_Or_Package_Spec;
17278 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17282 while Present (Arg) loop
17283 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17285 -- Store argument, converting sequences of spaces to a
17286 -- single null character (this is one of the differences
17287 -- in processing between Link_With and Linker_Options).
17289 Arg_Store : declare
17290 C : constant Char_Code := Get_Char_Code (' ');
17291 S : constant String_Id :=
17292 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17293 L : constant Nat := String_Length (S);
17296 procedure Skip_Spaces;
17297 -- Advance F past any spaces
17303 procedure Skip_Spaces is
17305 while F <= L and then Get_String_Char (S, F) = C loop
17310 -- Start of processing for Arg_Store
17313 Skip_Spaces; -- skip leading spaces
17315 -- Loop through characters, changing any embedded
17316 -- sequence of spaces to a single null character (this
17317 -- is how Link_With/Linker_Options differ)
17320 if Get_String_Char (S, F) = C then
17323 Store_String_Char (ASCII.NUL);
17326 Store_String_Char (Get_String_Char (S, F));
17334 if Present (Arg) then
17335 Store_String_Char (ASCII.NUL);
17339 Store_Linker_Option_String (End_String);
17347 -- pragma Linker_Alias (
17348 -- [Entity =>] LOCAL_NAME
17349 -- [Target =>] static_string_EXPRESSION);
17351 when Pragma_Linker_Alias =>
17353 Check_Arg_Order ((Name_Entity, Name_Target));
17354 Check_Arg_Count (2);
17355 Check_Optional_Identifier (Arg1, Name_Entity);
17356 Check_Optional_Identifier (Arg2, Name_Target);
17357 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17358 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17360 -- The only processing required is to link this item on to the
17361 -- list of rep items for the given entity. This is accomplished
17362 -- by the call to Rep_Item_Too_Late (when no error is detected
17363 -- and False is returned).
17365 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17368 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17371 ------------------------
17372 -- Linker_Constructor --
17373 ------------------------
17375 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17377 -- Code is shared with Linker_Destructor
17379 -----------------------
17380 -- Linker_Destructor --
17381 -----------------------
17383 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17385 when Pragma_Linker_Constructor
17386 | Pragma_Linker_Destructor
17388 Linker_Constructor : declare
17394 Check_Arg_Count (1);
17395 Check_No_Identifiers;
17396 Check_Arg_Is_Local_Name (Arg1);
17397 Arg1_X := Get_Pragma_Arg (Arg1);
17399 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17401 if not Is_Library_Level_Entity (Proc) then
17403 ("argument for pragma% must be library level entity", Arg1);
17406 -- The only processing required is to link this item on to the
17407 -- list of rep items for the given entity. This is accomplished
17408 -- by the call to Rep_Item_Too_Late (when no error is detected
17409 -- and False is returned).
17411 if Rep_Item_Too_Late (Proc, N) then
17414 Set_Has_Gigi_Rep_Item (Proc);
17416 end Linker_Constructor;
17418 --------------------
17419 -- Linker_Options --
17420 --------------------
17422 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17424 when Pragma_Linker_Options => Linker_Options : declare
17428 Check_Ada_83_Warning;
17429 Check_No_Identifiers;
17430 Check_Arg_Count (1);
17431 Check_Is_In_Decl_Part_Or_Package_Spec;
17432 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17433 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17436 while Present (Arg) loop
17437 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17438 Store_String_Char (ASCII.NUL);
17440 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17444 if Operating_Mode = Generate_Code
17445 and then In_Extended_Main_Source_Unit (N)
17447 Store_Linker_Option_String (End_String);
17449 end Linker_Options;
17451 --------------------
17452 -- Linker_Section --
17453 --------------------
17455 -- pragma Linker_Section (
17456 -- [Entity =>] LOCAL_NAME
17457 -- [Section =>] static_string_EXPRESSION);
17459 when Pragma_Linker_Section => Linker_Section : declare
17464 Ghost_Error_Posted : Boolean := False;
17465 -- Flag set when an error concerning the illegal mix of Ghost and
17466 -- non-Ghost subprograms is emitted.
17468 Ghost_Id : Entity_Id := Empty;
17469 -- The entity of the first Ghost subprogram encountered while
17470 -- processing the arguments of the pragma.
17474 Check_Arg_Order ((Name_Entity, Name_Section));
17475 Check_Arg_Count (2);
17476 Check_Optional_Identifier (Arg1, Name_Entity);
17477 Check_Optional_Identifier (Arg2, Name_Section);
17478 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17479 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17481 -- Check kind of entity
17483 Arg := Get_Pragma_Arg (Arg1);
17484 Ent := Entity (Arg);
17486 case Ekind (Ent) is
17488 -- Objects (constants and variables) and types. For these cases
17489 -- all we need to do is to set the Linker_Section_pragma field,
17490 -- checking that we do not have a duplicate.
17496 LPE := Linker_Section_Pragma (Ent);
17498 if Present (LPE) then
17499 Error_Msg_Sloc := Sloc (LPE);
17501 ("Linker_Section already specified for &#", Arg1, Ent);
17504 Set_Linker_Section_Pragma (Ent, N);
17506 -- A pragma that applies to a Ghost entity becomes Ghost for
17507 -- the purposes of legality checks and removal of ignored
17510 Mark_Ghost_Pragma (N, Ent);
17514 when Subprogram_Kind =>
17516 -- Aspect case, entity already set
17518 if From_Aspect_Specification (N) then
17519 Set_Linker_Section_Pragma
17520 (Entity (Corresponding_Aspect (N)), N);
17522 -- Pragma case, we must climb the homonym chain, but skip
17523 -- any for which the linker section is already set.
17527 if No (Linker_Section_Pragma (Ent)) then
17528 Set_Linker_Section_Pragma (Ent, N);
17530 -- A pragma that applies to a Ghost entity becomes
17531 -- Ghost for the purposes of legality checks and
17532 -- removal of ignored Ghost code.
17534 Mark_Ghost_Pragma (N, Ent);
17536 -- Capture the entity of the first Ghost subprogram
17537 -- being processed for error detection purposes.
17539 if Is_Ghost_Entity (Ent) then
17540 if No (Ghost_Id) then
17544 -- Otherwise the subprogram is non-Ghost. It is
17545 -- illegal to mix references to Ghost and non-Ghost
17546 -- entities (SPARK RM 6.9).
17548 elsif Present (Ghost_Id)
17549 and then not Ghost_Error_Posted
17551 Ghost_Error_Posted := True;
17553 Error_Msg_Name_1 := Pname;
17555 ("pragma % cannot mention ghost and "
17556 & "non-ghost subprograms", N);
17558 Error_Msg_Sloc := Sloc (Ghost_Id);
17560 ("\& # declared as ghost", N, Ghost_Id);
17562 Error_Msg_Sloc := Sloc (Ent);
17564 ("\& # declared as non-ghost", N, Ent);
17568 Ent := Homonym (Ent);
17570 or else Scope (Ent) /= Current_Scope;
17574 -- All other cases are illegal
17578 ("pragma% applies only to objects, subprograms, and types",
17581 end Linker_Section;
17587 -- pragma List (On | Off)
17589 -- There is nothing to do here, since we did all the processing for
17590 -- this pragma in Par.Prag (so that it works properly even in syntax
17593 when Pragma_List =>
17600 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17602 when Pragma_Lock_Free => Lock_Free : declare
17603 P : constant Node_Id := Parent (N);
17609 Check_No_Identifiers;
17610 Check_At_Most_N_Arguments (1);
17612 -- Protected definition case
17614 if Nkind (P) = N_Protected_Definition then
17615 Ent := Defining_Identifier (Parent (P));
17619 if Arg_Count = 1 then
17620 Arg := Get_Pragma_Arg (Arg1);
17621 Val := Is_True (Static_Boolean (Arg));
17623 -- No arguments (expression is considered to be True)
17629 -- Check duplicate pragma before we chain the pragma in the Rep
17630 -- Item chain of Ent.
17632 Check_Duplicate_Pragma (Ent);
17633 Record_Rep_Item (Ent, N);
17634 Set_Uses_Lock_Free (Ent, Val);
17636 -- Anything else is incorrect placement
17643 --------------------
17644 -- Locking_Policy --
17645 --------------------
17647 -- pragma Locking_Policy (policy_IDENTIFIER);
17649 when Pragma_Locking_Policy => declare
17650 subtype LP_Range is Name_Id
17651 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17656 Check_Ada_83_Warning;
17657 Check_Arg_Count (1);
17658 Check_No_Identifiers;
17659 Check_Arg_Is_Locking_Policy (Arg1);
17660 Check_Valid_Configuration_Pragma;
17661 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17664 when Name_Ceiling_Locking => LP := 'C';
17665 when Name_Concurrent_Readers_Locking => LP := 'R';
17666 when Name_Inheritance_Locking => LP := 'I';
17669 if Locking_Policy /= ' '
17670 and then Locking_Policy /= LP
17672 Error_Msg_Sloc := Locking_Policy_Sloc;
17673 Error_Pragma ("locking policy incompatible with policy#");
17675 -- Set new policy, but always preserve System_Location since we
17676 -- like the error message with the run time name.
17679 Locking_Policy := LP;
17681 if Locking_Policy_Sloc /= System_Location then
17682 Locking_Policy_Sloc := Loc;
17687 -------------------
17688 -- Loop_Optimize --
17689 -------------------
17691 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17693 -- OPTIMIZATION_HINT ::=
17694 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17696 when Pragma_Loop_Optimize => Loop_Optimize : declare
17701 Check_At_Least_N_Arguments (1);
17702 Check_No_Identifiers;
17704 Hint := First (Pragma_Argument_Associations (N));
17705 while Present (Hint) loop
17706 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17714 Check_Loop_Pragma_Placement;
17721 -- pragma Loop_Variant
17722 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17724 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17726 -- CHANGE_DIRECTION ::= Increases | Decreases
17728 when Pragma_Loop_Variant => Loop_Variant : declare
17733 Check_At_Least_N_Arguments (1);
17734 Check_Loop_Pragma_Placement;
17736 -- Process all increasing / decreasing expressions
17738 Variant := First (Pragma_Argument_Associations (N));
17739 while Present (Variant) loop
17740 if not Nam_In (Chars (Variant), Name_Decreases,
17743 Error_Pragma_Arg ("wrong change modifier", Variant);
17746 Preanalyze_Assert_Expression
17747 (Expression (Variant), Any_Discrete);
17753 -----------------------
17754 -- Machine_Attribute --
17755 -----------------------
17757 -- pragma Machine_Attribute (
17758 -- [Entity =>] LOCAL_NAME,
17759 -- [Attribute_Name =>] static_string_EXPRESSION
17760 -- [, [Info =>] static_EXPRESSION] );
17762 when Pragma_Machine_Attribute => Machine_Attribute : declare
17763 Def_Id : Entity_Id;
17767 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17769 if Arg_Count = 3 then
17770 Check_Optional_Identifier (Arg3, Name_Info);
17771 Check_Arg_Is_OK_Static_Expression (Arg3);
17773 Check_Arg_Count (2);
17776 Check_Optional_Identifier (Arg1, Name_Entity);
17777 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17778 Check_Arg_Is_Local_Name (Arg1);
17779 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17780 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17782 if Is_Access_Type (Def_Id) then
17783 Def_Id := Designated_Type (Def_Id);
17786 if Rep_Item_Too_Early (Def_Id, N) then
17790 Def_Id := Underlying_Type (Def_Id);
17792 -- The only processing required is to link this item on to the
17793 -- list of rep items for the given entity. This is accomplished
17794 -- by the call to Rep_Item_Too_Late (when no error is detected
17795 -- and False is returned).
17797 if Rep_Item_Too_Late (Def_Id, N) then
17800 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17802 end Machine_Attribute;
17809 -- (MAIN_OPTION [, MAIN_OPTION]);
17812 -- [STACK_SIZE =>] static_integer_EXPRESSION
17813 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17814 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17816 when Pragma_Main => Main : declare
17817 Args : Args_List (1 .. 3);
17818 Names : constant Name_List (1 .. 3) := (
17820 Name_Task_Stack_Size_Default,
17821 Name_Time_Slicing_Enabled);
17827 Gather_Associations (Names, Args);
17829 for J in 1 .. 2 loop
17830 if Present (Args (J)) then
17831 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17835 if Present (Args (3)) then
17836 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17840 while Present (Nod) loop
17841 if Nkind (Nod) = N_Pragma
17842 and then Pragma_Name (Nod) = Name_Main
17844 Error_Msg_Name_1 := Pname;
17845 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17856 -- pragma Main_Storage
17857 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17859 -- MAIN_STORAGE_OPTION ::=
17860 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17861 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17863 when Pragma_Main_Storage => Main_Storage : declare
17864 Args : Args_List (1 .. 2);
17865 Names : constant Name_List (1 .. 2) := (
17866 Name_Working_Storage,
17873 Gather_Associations (Names, Args);
17875 for J in 1 .. 2 loop
17876 if Present (Args (J)) then
17877 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17881 Check_In_Main_Program;
17884 while Present (Nod) loop
17885 if Nkind (Nod) = N_Pragma
17886 and then Pragma_Name (Nod) = Name_Main_Storage
17888 Error_Msg_Name_1 := Pname;
17889 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17896 ----------------------
17897 -- Max_Queue_Length --
17898 ----------------------
17900 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17902 when Pragma_Max_Queue_Length => Max_Queue_Length : declare
17904 Entry_Decl : Node_Id;
17905 Entry_Id : Entity_Id;
17910 Check_Arg_Count (1);
17913 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
17915 -- Entry declaration
17917 if Nkind (Entry_Decl) = N_Entry_Declaration then
17919 -- Entry illegally within a task
17921 if Nkind (Parent (N)) = N_Task_Definition then
17922 Error_Pragma ("pragma % cannot apply to task entries");
17926 Entry_Id := Unique_Defining_Entity (Entry_Decl);
17928 -- Otherwise the pragma is associated with an illegal construct
17931 Error_Pragma ("pragma % must apply to a protected entry");
17935 -- Mark the pragma as Ghost if the related subprogram is also
17936 -- Ghost. This also ensures that any expansion performed further
17937 -- below will produce Ghost nodes.
17939 Mark_Ghost_Pragma (N, Entry_Id);
17941 -- Analyze the Integer expression
17943 Arg := Get_Pragma_Arg (Arg1);
17944 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
17946 Val := Expr_Value (Arg);
17950 ("argument for pragma% must be positive", Arg1);
17952 elsif not UI_Is_In_Int_Range (Val) then
17954 ("argument for pragma% out of range of Integer", Arg1);
17958 -- Manually substitute the expression value of the pragma argument
17959 -- if it's not an integer literal because this is not taken care
17960 -- of automatically elsewhere.
17962 if Nkind (Arg) /= N_Integer_Literal then
17963 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
17966 Record_Rep_Item (Entry_Id, N);
17967 end Max_Queue_Length;
17973 -- pragma Memory_Size (NUMERIC_LITERAL)
17975 when Pragma_Memory_Size =>
17978 -- Memory size is simply ignored
17980 Check_No_Identifiers;
17981 Check_Arg_Count (1);
17982 Check_Arg_Is_Integer_Literal (Arg1);
17990 -- The only correct use of this pragma is on its own in a file, in
17991 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17992 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17993 -- check for a file containing nothing but a No_Body pragma). If we
17994 -- attempt to process it during normal semantics processing, it means
17995 -- it was misplaced.
17997 when Pragma_No_Body =>
18001 -----------------------------
18002 -- No_Elaboration_Code_All --
18003 -----------------------------
18005 -- pragma No_Elaboration_Code_All;
18007 when Pragma_No_Elaboration_Code_All =>
18009 Check_Valid_Library_Unit_Pragma;
18011 if Nkind (N) = N_Null_Statement then
18015 -- Must appear for a spec or generic spec
18017 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
18018 N_Generic_Package_Declaration,
18019 N_Generic_Subprogram_Declaration,
18020 N_Package_Declaration,
18021 N_Subprogram_Declaration)
18025 ("pragma% can only occur for package "
18026 & "or subprogram spec"));
18029 -- Set flag in unit table
18031 Set_No_Elab_Code_All (Current_Sem_Unit);
18033 -- Set restriction No_Elaboration_Code if this is the main unit
18035 if Current_Sem_Unit = Main_Unit then
18036 Set_Restriction (No_Elaboration_Code, N);
18039 -- If we are in the main unit or in an extended main source unit,
18040 -- then we also add it to the configuration restrictions so that
18041 -- it will apply to all units in the extended main source.
18043 if Current_Sem_Unit = Main_Unit
18044 or else In_Extended_Main_Source_Unit (N)
18046 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
18049 -- If in main extended unit, activate transitive with test
18051 if In_Extended_Main_Source_Unit (N) then
18052 Opt.No_Elab_Code_All_Pragma := N;
18055 --------------------------
18056 -- No_Heap_Finalization --
18057 --------------------------
18059 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18061 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
18062 Context : constant Node_Id := Parent (N);
18063 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
18069 Check_No_Identifiers;
18071 -- The pragma appears in a configuration file
18073 if No (Context) then
18074 Check_Arg_Count (0);
18075 Check_Valid_Configuration_Pragma;
18077 -- Detect a duplicate pragma
18079 if Present (No_Heap_Finalization_Pragma) then
18082 Prev => No_Heap_Finalization_Pragma);
18086 No_Heap_Finalization_Pragma := N;
18088 -- Otherwise the pragma should be associated with a library-level
18089 -- named access-to-object type.
18092 Check_Arg_Count (1);
18093 Check_Arg_Is_Local_Name (Arg1);
18095 Find_Type (Typ_Arg);
18096 Typ := Entity (Typ_Arg);
18098 -- The type being subjected to the pragma is erroneous
18100 if Typ = Any_Type then
18101 Error_Pragma ("cannot find type referenced by pragma %");
18103 -- The pragma is applied to an incomplete or generic formal
18104 -- type way too early.
18106 elsif Rep_Item_Too_Early (Typ, N) then
18110 Typ := Underlying_Type (Typ);
18113 -- The pragma must apply to an access-to-object type
18115 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
18118 -- Give a detailed error message on all other access type kinds
18120 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
18122 ("pragma % cannot apply to access protected subprogram "
18125 elsif Ekind (Typ) = E_Access_Subprogram_Type then
18127 ("pragma % cannot apply to access subprogram type");
18129 elsif Is_Anonymous_Access_Type (Typ) then
18131 ("pragma % cannot apply to anonymous access type");
18133 -- Give a general error message in case the pragma applies to a
18134 -- non-access type.
18138 ("pragma % must apply to library level access type");
18141 -- At this point the argument denotes an access-to-object type.
18142 -- Ensure that the type is declared at the library level.
18144 if Is_Library_Level_Entity (Typ) then
18147 -- Quietly ignore an access-to-object type originally declared
18148 -- at the library level within a generic, but instantiated at
18149 -- a non-library level. As a result the access-to-object type
18150 -- "loses" its No_Heap_Finalization property.
18152 elsif In_Instance then
18157 ("pragma % must apply to library level access type");
18160 -- Detect a duplicate pragma
18162 if Present (No_Heap_Finalization_Pragma) then
18165 Prev => No_Heap_Finalization_Pragma);
18169 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
18171 if Present (Prev) then
18179 Record_Rep_Item (Typ, N);
18181 end No_Heap_Finalization;
18187 -- pragma No_Inline ( NAME {, NAME} );
18189 when Pragma_No_Inline =>
18191 Process_Inline (Suppressed);
18197 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18199 when Pragma_No_Return => No_Return : declare
18205 Ghost_Error_Posted : Boolean := False;
18206 -- Flag set when an error concerning the illegal mix of Ghost and
18207 -- non-Ghost subprograms is emitted.
18209 Ghost_Id : Entity_Id := Empty;
18210 -- The entity of the first Ghost procedure encountered while
18211 -- processing the arguments of the pragma.
18215 Check_At_Least_N_Arguments (1);
18217 -- Loop through arguments of pragma
18220 while Present (Arg) loop
18221 Check_Arg_Is_Local_Name (Arg);
18222 Id := Get_Pragma_Arg (Arg);
18225 if not Is_Entity_Name (Id) then
18226 Error_Pragma_Arg ("entity name required", Arg);
18229 if Etype (Id) = Any_Type then
18233 -- Loop to find matching procedures
18239 and then Scope (E) = Current_Scope
18241 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
18243 -- Check that the pragma is not applied to a body.
18244 -- First check the specless body case, to give a
18245 -- different error message. These checks do not apply
18246 -- if Relaxed_RM_Semantics, to accommodate other Ada
18247 -- compilers. Disable these checks under -gnatd.J.
18249 if not Debug_Flag_Dot_JJ then
18250 if Nkind (Parent (Declaration_Node (E))) =
18252 and then not Relaxed_RM_Semantics
18255 ("pragma% requires separate spec and must come "
18259 -- Now the "specful" body case
18261 if Rep_Item_Too_Late (E, N) then
18268 -- A pragma that applies to a Ghost entity becomes Ghost
18269 -- for the purposes of legality checks and removal of
18270 -- ignored Ghost code.
18272 Mark_Ghost_Pragma (N, E);
18274 -- Capture the entity of the first Ghost procedure being
18275 -- processed for error detection purposes.
18277 if Is_Ghost_Entity (E) then
18278 if No (Ghost_Id) then
18282 -- Otherwise the subprogram is non-Ghost. It is illegal
18283 -- to mix references to Ghost and non-Ghost entities
18286 elsif Present (Ghost_Id)
18287 and then not Ghost_Error_Posted
18289 Ghost_Error_Posted := True;
18291 Error_Msg_Name_1 := Pname;
18293 ("pragma % cannot mention ghost and non-ghost "
18294 & "procedures", N);
18296 Error_Msg_Sloc := Sloc (Ghost_Id);
18297 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
18299 Error_Msg_Sloc := Sloc (E);
18300 Error_Msg_NE ("\& # declared as non-ghost", N, E);
18303 -- Set flag on any alias as well
18305 if Is_Overloadable (E) and then Present (Alias (E)) then
18306 Set_No_Return (Alias (E));
18312 exit when From_Aspect_Specification (N);
18316 -- If entity in not in current scope it may be the enclosing
18317 -- suprogram body to which the aspect applies.
18320 if Entity (Id) = Current_Scope
18321 and then From_Aspect_Specification (N)
18323 Set_No_Return (Entity (Id));
18325 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
18337 -- pragma No_Run_Time;
18339 -- Note: this pragma is retained for backwards compatibility. See
18340 -- body of Rtsfind for full details on its handling.
18342 when Pragma_No_Run_Time =>
18344 Check_Valid_Configuration_Pragma;
18345 Check_Arg_Count (0);
18347 -- Remove backward compatibility if Build_Type is FSF or GPL and
18348 -- generate a warning.
18351 Ignore : constant Boolean := Build_Type in FSF .. GPL;
18354 Error_Pragma ("pragma% is ignored, has no effect??");
18356 No_Run_Time_Mode := True;
18357 Configurable_Run_Time_Mode := True;
18359 -- Set Duration to 32 bits if word size is 32
18361 if Ttypes.System_Word_Size = 32 then
18362 Duration_32_Bits_On_Target := True;
18365 -- Set appropriate restrictions
18367 Set_Restriction (No_Finalization, N);
18368 Set_Restriction (No_Exception_Handlers, N);
18369 Set_Restriction (Max_Tasks, N, 0);
18370 Set_Restriction (No_Tasking, N);
18374 -----------------------
18375 -- No_Tagged_Streams --
18376 -----------------------
18378 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18380 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
18386 Check_At_Most_N_Arguments (1);
18388 -- One argument case
18390 if Arg_Count = 1 then
18391 Check_Optional_Identifier (Arg1, Name_Entity);
18392 Check_Arg_Is_Local_Name (Arg1);
18393 E_Id := Get_Pragma_Arg (Arg1);
18395 if Etype (E_Id) = Any_Type then
18399 E := Entity (E_Id);
18401 Check_Duplicate_Pragma (E);
18403 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
18405 ("argument for pragma% must be root tagged type", Arg1);
18408 if Rep_Item_Too_Early (E, N)
18410 Rep_Item_Too_Late (E, N)
18414 Set_No_Tagged_Streams_Pragma (E, N);
18417 -- Zero argument case
18420 Check_Is_In_Decl_Part_Or_Package_Spec;
18421 No_Tagged_Streams := N;
18423 end No_Tagged_Strms;
18425 ------------------------
18426 -- No_Strict_Aliasing --
18427 ------------------------
18429 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18431 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
18436 Check_At_Most_N_Arguments (1);
18438 if Arg_Count = 0 then
18439 Check_Valid_Configuration_Pragma;
18440 Opt.No_Strict_Aliasing := True;
18443 Check_Optional_Identifier (Arg2, Name_Entity);
18444 Check_Arg_Is_Local_Name (Arg1);
18445 E_Id := Entity (Get_Pragma_Arg (Arg1));
18447 if E_Id = Any_Type then
18449 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
18450 Error_Pragma_Arg ("pragma% requires access type", Arg1);
18453 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
18455 end No_Strict_Aliasing;
18457 -----------------------
18458 -- Normalize_Scalars --
18459 -----------------------
18461 -- pragma Normalize_Scalars;
18463 when Pragma_Normalize_Scalars =>
18464 Check_Ada_83_Warning;
18465 Check_Arg_Count (0);
18466 Check_Valid_Configuration_Pragma;
18468 -- Normalize_Scalars creates false positives in CodePeer, and
18469 -- incorrect negative results in GNATprove mode, so ignore this
18470 -- pragma in these modes.
18472 if not (CodePeer_Mode or GNATprove_Mode) then
18473 Normalize_Scalars := True;
18474 Init_Or_Norm_Scalars := True;
18481 -- pragma Obsolescent;
18483 -- pragma Obsolescent (
18484 -- [Message =>] static_string_EXPRESSION
18485 -- [,[Version =>] Ada_05]]);
18487 -- pragma Obsolescent (
18488 -- [Entity =>] NAME
18489 -- [,[Message =>] static_string_EXPRESSION
18490 -- [,[Version =>] Ada_05]] );
18492 when Pragma_Obsolescent => Obsolescent : declare
18496 procedure Set_Obsolescent (E : Entity_Id);
18497 -- Given an entity Ent, mark it as obsolescent if appropriate
18499 ---------------------
18500 -- Set_Obsolescent --
18501 ---------------------
18503 procedure Set_Obsolescent (E : Entity_Id) is
18512 -- A pragma that applies to a Ghost entity becomes Ghost for
18513 -- the purposes of legality checks and removal of ignored Ghost
18516 Mark_Ghost_Pragma (N, E);
18518 -- Entity name was given
18520 if Present (Ename) then
18522 -- If entity name matches, we are fine. Save entity in
18523 -- pragma argument, for ASIS use.
18525 if Chars (Ename) = Chars (Ent) then
18526 Set_Entity (Ename, Ent);
18527 Generate_Reference (Ent, Ename);
18529 -- If entity name does not match, only possibility is an
18530 -- enumeration literal from an enumeration type declaration.
18532 elsif Ekind (Ent) /= E_Enumeration_Type then
18534 ("pragma % entity name does not match declaration");
18537 Ent := First_Literal (E);
18541 ("pragma % entity name does not match any "
18542 & "enumeration literal");
18544 elsif Chars (Ent) = Chars (Ename) then
18545 Set_Entity (Ename, Ent);
18546 Generate_Reference (Ent, Ename);
18550 Ent := Next_Literal (Ent);
18556 -- Ent points to entity to be marked
18558 if Arg_Count >= 1 then
18560 -- Deal with static string argument
18562 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18563 S := Strval (Get_Pragma_Arg (Arg1));
18565 for J in 1 .. String_Length (S) loop
18566 if not In_Character_Range (Get_String_Char (S, J)) then
18568 ("pragma% argument does not allow wide characters",
18573 Obsolescent_Warnings.Append
18574 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18576 -- Check for Ada_05 parameter
18578 if Arg_Count /= 1 then
18579 Check_Arg_Count (2);
18582 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18585 Check_Arg_Is_Identifier (Argx);
18587 if Chars (Argx) /= Name_Ada_05 then
18588 Error_Msg_Name_2 := Name_Ada_05;
18590 ("only allowed argument for pragma% is %", Argx);
18593 if Ada_Version_Explicit < Ada_2005
18594 or else not Warn_On_Ada_2005_Compatibility
18602 -- Set flag if pragma active
18605 Set_Is_Obsolescent (Ent);
18609 end Set_Obsolescent;
18611 -- Start of processing for pragma Obsolescent
18616 Check_At_Most_N_Arguments (3);
18618 -- See if first argument specifies an entity name
18622 (Chars (Arg1) = Name_Entity
18624 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18626 N_Operator_Symbol))
18628 Ename := Get_Pragma_Arg (Arg1);
18630 -- Eliminate first argument, so we can share processing
18634 Arg_Count := Arg_Count - 1;
18636 -- No Entity name argument given
18642 if Arg_Count >= 1 then
18643 Check_Optional_Identifier (Arg1, Name_Message);
18645 if Arg_Count = 2 then
18646 Check_Optional_Identifier (Arg2, Name_Version);
18650 -- Get immediately preceding declaration
18653 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18657 -- Cases where we do not follow anything other than another pragma
18661 -- First case: library level compilation unit declaration with
18662 -- the pragma immediately following the declaration.
18664 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18666 (Defining_Entity (Unit (Parent (Parent (N)))));
18669 -- Case 2: library unit placement for package
18673 Ent : constant Entity_Id := Find_Lib_Unit_Name;
18675 if Is_Package_Or_Generic_Package (Ent) then
18676 Set_Obsolescent (Ent);
18682 -- Cases where we must follow a declaration, including an
18683 -- abstract subprogram declaration, which is not in the
18684 -- other node subtypes.
18687 if Nkind (Decl) not in N_Declaration
18688 and then Nkind (Decl) not in N_Later_Decl_Item
18689 and then Nkind (Decl) not in N_Generic_Declaration
18690 and then Nkind (Decl) not in N_Renaming_Declaration
18691 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18694 ("pragma% misplaced, "
18695 & "must immediately follow a declaration");
18698 Set_Obsolescent (Defining_Entity (Decl));
18708 -- pragma Optimize (Time | Space | Off);
18710 -- The actual check for optimize is done in Gigi. Note that this
18711 -- pragma does not actually change the optimization setting, it
18712 -- simply checks that it is consistent with the pragma.
18714 when Pragma_Optimize =>
18715 Check_No_Identifiers;
18716 Check_Arg_Count (1);
18717 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18719 ------------------------
18720 -- Optimize_Alignment --
18721 ------------------------
18723 -- pragma Optimize_Alignment (Time | Space | Off);
18725 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18727 Check_No_Identifiers;
18728 Check_Arg_Count (1);
18729 Check_Valid_Configuration_Pragma;
18732 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18735 when Name_Off => Opt.Optimize_Alignment := 'O';
18736 when Name_Space => Opt.Optimize_Alignment := 'S';
18737 when Name_Time => Opt.Optimize_Alignment := 'T';
18740 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18744 -- Set indication that mode is set locally. If we are in fact in a
18745 -- configuration pragma file, this setting is harmless since the
18746 -- switch will get reset anyway at the start of each unit.
18748 Optimize_Alignment_Local := True;
18749 end Optimize_Alignment;
18755 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18757 when Pragma_Ordered => Ordered : declare
18758 Assoc : constant Node_Id := Arg1;
18764 Check_No_Identifiers;
18765 Check_Arg_Count (1);
18766 Check_Arg_Is_Local_Name (Arg1);
18768 Type_Id := Get_Pragma_Arg (Assoc);
18769 Find_Type (Type_Id);
18770 Typ := Entity (Type_Id);
18772 if Typ = Any_Type then
18775 Typ := Underlying_Type (Typ);
18778 if not Is_Enumeration_Type (Typ) then
18779 Error_Pragma ("pragma% must specify enumeration type");
18782 Check_First_Subtype (Arg1);
18783 Set_Has_Pragma_Ordered (Base_Type (Typ));
18786 -------------------
18787 -- Overflow_Mode --
18788 -------------------
18790 -- pragma Overflow_Mode
18791 -- ([General => ] MODE [, [Assertions => ] MODE]);
18793 -- MODE := STRICT | MINIMIZED | ELIMINATED
18795 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18796 -- since System.Bignums makes this assumption. This is true of nearly
18797 -- all (all?) targets.
18799 when Pragma_Overflow_Mode => Overflow_Mode : declare
18800 function Get_Overflow_Mode
18802 Arg : Node_Id) return Overflow_Mode_Type;
18803 -- Function to process one pragma argument, Arg. If an identifier
18804 -- is present, it must be Name. Mode type is returned if a valid
18805 -- argument exists, otherwise an error is signalled.
18807 -----------------------
18808 -- Get_Overflow_Mode --
18809 -----------------------
18811 function Get_Overflow_Mode
18813 Arg : Node_Id) return Overflow_Mode_Type
18815 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18818 Check_Optional_Identifier (Arg, Name);
18819 Check_Arg_Is_Identifier (Argx);
18821 if Chars (Argx) = Name_Strict then
18824 elsif Chars (Argx) = Name_Minimized then
18827 elsif Chars (Argx) = Name_Eliminated then
18828 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18830 ("Eliminated not implemented on this target", Argx);
18836 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18838 end Get_Overflow_Mode;
18840 -- Start of processing for Overflow_Mode
18844 Check_At_Least_N_Arguments (1);
18845 Check_At_Most_N_Arguments (2);
18847 -- Process first argument
18849 Scope_Suppress.Overflow_Mode_General :=
18850 Get_Overflow_Mode (Name_General, Arg1);
18852 -- Case of only one argument
18854 if Arg_Count = 1 then
18855 Scope_Suppress.Overflow_Mode_Assertions :=
18856 Scope_Suppress.Overflow_Mode_General;
18858 -- Case of two arguments present
18861 Scope_Suppress.Overflow_Mode_Assertions :=
18862 Get_Overflow_Mode (Name_Assertions, Arg2);
18866 --------------------------
18867 -- Overriding Renamings --
18868 --------------------------
18870 -- pragma Overriding_Renamings;
18872 when Pragma_Overriding_Renamings =>
18874 Check_Arg_Count (0);
18875 Check_Valid_Configuration_Pragma;
18876 Overriding_Renamings := True;
18882 -- pragma Pack (first_subtype_LOCAL_NAME);
18884 when Pragma_Pack => Pack : declare
18885 Assoc : constant Node_Id := Arg1;
18887 Ignore : Boolean := False;
18892 Check_No_Identifiers;
18893 Check_Arg_Count (1);
18894 Check_Arg_Is_Local_Name (Arg1);
18895 Type_Id := Get_Pragma_Arg (Assoc);
18897 if not Is_Entity_Name (Type_Id)
18898 or else not Is_Type (Entity (Type_Id))
18901 ("argument for pragma% must be type or subtype", Arg1);
18904 Find_Type (Type_Id);
18905 Typ := Entity (Type_Id);
18908 or else Rep_Item_Too_Early (Typ, N)
18912 Typ := Underlying_Type (Typ);
18915 -- A pragma that applies to a Ghost entity becomes Ghost for the
18916 -- purposes of legality checks and removal of ignored Ghost code.
18918 Mark_Ghost_Pragma (N, Typ);
18920 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18921 Error_Pragma ("pragma% must specify array or record type");
18924 Check_First_Subtype (Arg1);
18925 Check_Duplicate_Pragma (Typ);
18929 if Is_Array_Type (Typ) then
18930 Ctyp := Component_Type (Typ);
18932 -- Ignore pack that does nothing
18934 if Known_Static_Esize (Ctyp)
18935 and then Known_Static_RM_Size (Ctyp)
18936 and then Esize (Ctyp) = RM_Size (Ctyp)
18937 and then Addressable (Esize (Ctyp))
18942 -- Process OK pragma Pack. Note that if there is a separate
18943 -- component clause present, the Pack will be cancelled. This
18944 -- processing is in Freeze.
18946 if not Rep_Item_Too_Late (Typ, N) then
18948 -- In CodePeer mode, we do not need complex front-end
18949 -- expansions related to pragma Pack, so disable handling
18952 if CodePeer_Mode then
18955 -- Normal case where we do the pack action
18959 Set_Is_Packed (Base_Type (Typ));
18960 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18963 Set_Has_Pragma_Pack (Base_Type (Typ));
18967 -- For record types, the pack is always effective
18969 else pragma Assert (Is_Record_Type (Typ));
18970 if not Rep_Item_Too_Late (Typ, N) then
18971 Set_Is_Packed (Base_Type (Typ));
18972 Set_Has_Pragma_Pack (Base_Type (Typ));
18973 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18984 -- There is nothing to do here, since we did all the processing for
18985 -- this pragma in Par.Prag (so that it works properly even in syntax
18988 when Pragma_Page =>
18995 -- pragma Part_Of (ABSTRACT_STATE);
18997 -- ABSTRACT_STATE ::= NAME
18999 when Pragma_Part_Of => Part_Of : declare
19000 procedure Propagate_Part_Of
19001 (Pack_Id : Entity_Id;
19002 State_Id : Entity_Id;
19003 Instance : Node_Id);
19004 -- Propagate the Part_Of indicator to all abstract states and
19005 -- objects declared in the visible state space of a package
19006 -- denoted by Pack_Id. State_Id is the encapsulating state.
19007 -- Instance is the package instantiation node.
19009 -----------------------
19010 -- Propagate_Part_Of --
19011 -----------------------
19013 procedure Propagate_Part_Of
19014 (Pack_Id : Entity_Id;
19015 State_Id : Entity_Id;
19016 Instance : Node_Id)
19018 Has_Item : Boolean := False;
19019 -- Flag set when the visible state space contains at least one
19020 -- abstract state or variable.
19022 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
19023 -- Propagate the Part_Of indicator to all abstract states and
19024 -- objects declared in the visible state space of a package
19025 -- denoted by Pack_Id.
19027 -----------------------
19028 -- Propagate_Part_Of --
19029 -----------------------
19031 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
19032 Constits : Elist_Id;
19033 Item_Id : Entity_Id;
19036 -- Traverse the entity chain of the package and set relevant
19037 -- attributes of abstract states and objects declared in the
19038 -- visible state space of the package.
19040 Item_Id := First_Entity (Pack_Id);
19041 while Present (Item_Id)
19042 and then not In_Private_Part (Item_Id)
19044 -- Do not consider internally generated items
19046 if not Comes_From_Source (Item_Id) then
19049 -- The Part_Of indicator turns an abstract state or an
19050 -- object into a constituent of the encapsulating state.
19052 elsif Ekind_In (Item_Id, E_Abstract_State,
19057 Constits := Part_Of_Constituents (State_Id);
19059 if No (Constits) then
19060 Constits := New_Elmt_List;
19061 Set_Part_Of_Constituents (State_Id, Constits);
19064 Append_Elmt (Item_Id, Constits);
19065 Set_Encapsulating_State (Item_Id, State_Id);
19067 -- Recursively handle nested packages and instantiations
19069 elsif Ekind (Item_Id) = E_Package then
19070 Propagate_Part_Of (Item_Id);
19073 Next_Entity (Item_Id);
19075 end Propagate_Part_Of;
19077 -- Start of processing for Propagate_Part_Of
19080 Propagate_Part_Of (Pack_Id);
19082 -- Detect a package instantiation that is subject to a Part_Of
19083 -- indicator, but has no visible state.
19085 if not Has_Item then
19087 ("package instantiation & has Part_Of indicator but "
19088 & "lacks visible state", Instance, Pack_Id);
19090 end Propagate_Part_Of;
19094 Constits : Elist_Id;
19096 Encap_Id : Entity_Id;
19097 Item_Id : Entity_Id;
19101 -- Start of processing for Part_Of
19105 Check_No_Identifiers;
19106 Check_Arg_Count (1);
19108 Stmt := Find_Related_Context (N, Do_Checks => True);
19110 -- Object declaration
19112 if Nkind (Stmt) = N_Object_Declaration then
19115 -- Package instantiation
19117 elsif Nkind (Stmt) = N_Package_Instantiation then
19120 -- Single concurrent type declaration
19122 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
19125 -- Otherwise the pragma is associated with an illegal construct
19132 -- Extract the entity of the related object declaration or package
19133 -- instantiation. In the case of the instantiation, use the entity
19134 -- of the instance spec.
19136 if Nkind (Stmt) = N_Package_Instantiation then
19137 Stmt := Instance_Spec (Stmt);
19140 Item_Id := Defining_Entity (Stmt);
19142 -- A pragma that applies to a Ghost entity becomes Ghost for the
19143 -- purposes of legality checks and removal of ignored Ghost code.
19145 Mark_Ghost_Pragma (N, Item_Id);
19147 -- Chain the pragma on the contract for further processing by
19148 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19150 Add_Contract_Item (N, Item_Id);
19152 -- A variable may act as constituent of a single concurrent type
19153 -- which in turn could be declared after the variable. Due to this
19154 -- discrepancy, the full analysis of indicator Part_Of is delayed
19155 -- until the end of the enclosing declarative region (see routine
19156 -- Analyze_Part_Of_In_Decl_Part).
19158 if Ekind (Item_Id) = E_Variable then
19161 -- Otherwise indicator Part_Of applies to a constant or a package
19165 Encap := Get_Pragma_Arg (Arg1);
19167 -- Detect any discrepancies between the placement of the
19168 -- constant or package instantiation with respect to state
19169 -- space and the encapsulating state.
19173 Item_Id => Item_Id,
19175 Encap_Id => Encap_Id,
19179 pragma Assert (Present (Encap_Id));
19181 if Ekind (Item_Id) = E_Constant then
19182 Constits := Part_Of_Constituents (Encap_Id);
19184 if No (Constits) then
19185 Constits := New_Elmt_List;
19186 Set_Part_Of_Constituents (Encap_Id, Constits);
19189 Append_Elmt (Item_Id, Constits);
19190 Set_Encapsulating_State (Item_Id, Encap_Id);
19192 -- Propagate the Part_Of indicator to the visible state
19193 -- space of the package instantiation.
19197 (Pack_Id => Item_Id,
19198 State_Id => Encap_Id,
19205 ----------------------------------
19206 -- Partition_Elaboration_Policy --
19207 ----------------------------------
19209 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19211 when Pragma_Partition_Elaboration_Policy => PEP : declare
19212 subtype PEP_Range is Name_Id
19213 range First_Partition_Elaboration_Policy_Name
19214 .. Last_Partition_Elaboration_Policy_Name;
19215 PEP_Val : PEP_Range;
19220 Check_Arg_Count (1);
19221 Check_No_Identifiers;
19222 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
19223 Check_Valid_Configuration_Pragma;
19224 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
19227 when Name_Concurrent => PEP := 'C';
19228 when Name_Sequential => PEP := 'S';
19231 if Partition_Elaboration_Policy /= ' '
19232 and then Partition_Elaboration_Policy /= PEP
19234 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
19236 ("partition elaboration policy incompatible with policy#");
19238 -- Set new policy, but always preserve System_Location since we
19239 -- like the error message with the run time name.
19242 Partition_Elaboration_Policy := PEP;
19244 if Partition_Elaboration_Policy_Sloc /= System_Location then
19245 Partition_Elaboration_Policy_Sloc := Loc;
19254 -- pragma Passive [(PASSIVE_FORM)];
19256 -- PASSIVE_FORM ::= Semaphore | No
19258 when Pragma_Passive =>
19261 if Nkind (Parent (N)) /= N_Task_Definition then
19262 Error_Pragma ("pragma% must be within task definition");
19265 if Arg_Count /= 0 then
19266 Check_Arg_Count (1);
19267 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
19270 ----------------------------------
19271 -- Preelaborable_Initialization --
19272 ----------------------------------
19274 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19276 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
19281 Check_Arg_Count (1);
19282 Check_No_Identifiers;
19283 Check_Arg_Is_Identifier (Arg1);
19284 Check_Arg_Is_Local_Name (Arg1);
19285 Check_First_Subtype (Arg1);
19286 Ent := Entity (Get_Pragma_Arg (Arg1));
19288 -- A pragma that applies to a Ghost entity becomes Ghost for the
19289 -- purposes of legality checks and removal of ignored Ghost code.
19291 Mark_Ghost_Pragma (N, Ent);
19293 -- The pragma may come from an aspect on a private declaration,
19294 -- even if the freeze point at which this is analyzed in the
19295 -- private part after the full view.
19297 if Has_Private_Declaration (Ent)
19298 and then From_Aspect_Specification (N)
19302 -- Check appropriate type argument
19304 elsif Is_Private_Type (Ent)
19305 or else Is_Protected_Type (Ent)
19306 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
19308 -- AI05-0028: The pragma applies to all composite types. Note
19309 -- that we apply this binding interpretation to earlier versions
19310 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19311 -- choice since there are other compilers that do the same.
19313 or else Is_Composite_Type (Ent)
19319 ("pragma % can only be applied to private, formal derived, "
19320 & "protected, or composite type", Arg1);
19323 -- Give an error if the pragma is applied to a protected type that
19324 -- does not qualify (due to having entries, or due to components
19325 -- that do not qualify).
19327 if Is_Protected_Type (Ent)
19328 and then not Has_Preelaborable_Initialization (Ent)
19331 ("protected type & does not have preelaborable "
19332 & "initialization", Ent);
19334 -- Otherwise mark the type as definitely having preelaborable
19338 Set_Known_To_Have_Preelab_Init (Ent);
19341 if Has_Pragma_Preelab_Init (Ent)
19342 and then Warn_On_Redundant_Constructs
19344 Error_Pragma ("?r?duplicate pragma%!");
19346 Set_Has_Pragma_Preelab_Init (Ent);
19350 --------------------
19351 -- Persistent_BSS --
19352 --------------------
19354 -- pragma Persistent_BSS [(object_NAME)];
19356 when Pragma_Persistent_BSS => Persistent_BSS : declare
19363 Check_At_Most_N_Arguments (1);
19365 -- Case of application to specific object (one argument)
19367 if Arg_Count = 1 then
19368 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19370 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
19372 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
19375 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
19378 Ent := Entity (Get_Pragma_Arg (Arg1));
19380 -- A pragma that applies to a Ghost entity becomes Ghost for
19381 -- the purposes of legality checks and removal of ignored Ghost
19384 Mark_Ghost_Pragma (N, Ent);
19386 -- Check for duplication before inserting in list of
19387 -- representation items.
19389 Check_Duplicate_Pragma (Ent);
19391 if Rep_Item_Too_Late (Ent, N) then
19395 Decl := Parent (Ent);
19397 if Present (Expression (Decl)) then
19399 ("object for pragma% cannot have initialization", Arg1);
19402 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
19404 ("object type for pragma% is not potentially persistent",
19409 Make_Linker_Section_Pragma
19410 (Ent, Sloc (N), ".persistent.bss");
19411 Insert_After (N, Prag);
19414 -- Case of use as configuration pragma with no arguments
19417 Check_Valid_Configuration_Pragma;
19418 Persistent_BSS_Mode := True;
19420 end Persistent_BSS;
19422 --------------------
19423 -- Rename_Pragma --
19424 --------------------
19426 -- pragma Rename_Pragma (
19427 -- [New_Name =>] IDENTIFIER,
19428 -- [Renamed =>] pragma_IDENTIFIER);
19430 when Pragma_Rename_Pragma => Rename_Pragma : declare
19431 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
19432 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
19436 Check_Valid_Configuration_Pragma;
19437 Check_Arg_Count (2);
19438 Check_Optional_Identifier (Arg1, Name_New_Name);
19439 Check_Optional_Identifier (Arg2, Name_Renamed);
19441 if Nkind (New_Name) /= N_Identifier then
19442 Error_Pragma_Arg ("identifier expected", Arg1);
19445 if Nkind (Old_Name) /= N_Identifier then
19446 Error_Pragma_Arg ("identifier expected", Arg2);
19449 -- The New_Name arg should not be an existing pragma (but we allow
19450 -- it; it's just a warning). The Old_Name arg must be an existing
19453 if Is_Pragma_Name (Chars (New_Name)) then
19454 Error_Pragma_Arg ("??pragma is already defined", Arg1);
19457 if not Is_Pragma_Name (Chars (Old_Name)) then
19458 Error_Pragma_Arg ("existing pragma name expected", Arg1);
19461 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
19468 -- pragma Polling (ON | OFF);
19470 when Pragma_Polling =>
19472 Check_Arg_Count (1);
19473 Check_No_Identifiers;
19474 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19475 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
19477 -----------------------------------
19478 -- Post/Post_Class/Postcondition --
19479 -----------------------------------
19481 -- pragma Post (Boolean_EXPRESSION);
19482 -- pragma Post_Class (Boolean_EXPRESSION);
19483 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19484 -- [,[Message =>] String_EXPRESSION]);
19486 -- Characteristics:
19488 -- * Analysis - The annotation undergoes initial checks to verify
19489 -- the legal placement and context. Secondary checks preanalyze the
19492 -- Analyze_Pre_Post_Condition_In_Decl_Part
19494 -- * Expansion - The annotation is expanded during the expansion of
19495 -- the related subprogram [body] contract as performed in:
19497 -- Expand_Subprogram_Contract
19499 -- * Template - The annotation utilizes the generic template of the
19500 -- related subprogram [body] when it is:
19502 -- aspect on subprogram declaration
19503 -- aspect on stand alone subprogram body
19504 -- pragma on stand alone subprogram body
19506 -- The annotation must prepare its own template when it is:
19508 -- pragma on subprogram declaration
19510 -- * Globals - Capture of global references must occur after full
19513 -- * Instance - The annotation is instantiated automatically when
19514 -- the related generic subprogram [body] is instantiated except for
19515 -- the "pragma on subprogram declaration" case. In that scenario
19516 -- the annotation must instantiate itself.
19519 | Pragma_Post_Class
19520 | Pragma_Postcondition
19522 Analyze_Pre_Post_Condition;
19524 --------------------------------
19525 -- Pre/Pre_Class/Precondition --
19526 --------------------------------
19528 -- pragma Pre (Boolean_EXPRESSION);
19529 -- pragma Pre_Class (Boolean_EXPRESSION);
19530 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19531 -- [,[Message =>] String_EXPRESSION]);
19533 -- Characteristics:
19535 -- * Analysis - The annotation undergoes initial checks to verify
19536 -- the legal placement and context. Secondary checks preanalyze the
19539 -- Analyze_Pre_Post_Condition_In_Decl_Part
19541 -- * Expansion - The annotation is expanded during the expansion of
19542 -- the related subprogram [body] contract as performed in:
19544 -- Expand_Subprogram_Contract
19546 -- * Template - The annotation utilizes the generic template of the
19547 -- related subprogram [body] when it is:
19549 -- aspect on subprogram declaration
19550 -- aspect on stand alone subprogram body
19551 -- pragma on stand alone subprogram body
19553 -- The annotation must prepare its own template when it is:
19555 -- pragma on subprogram declaration
19557 -- * Globals - Capture of global references must occur after full
19560 -- * Instance - The annotation is instantiated automatically when
19561 -- the related generic subprogram [body] is instantiated except for
19562 -- the "pragma on subprogram declaration" case. In that scenario
19563 -- the annotation must instantiate itself.
19567 | Pragma_Precondition
19569 Analyze_Pre_Post_Condition;
19575 -- pragma Predicate
19576 -- ([Entity =>] type_LOCAL_NAME,
19577 -- [Check =>] boolean_EXPRESSION);
19579 when Pragma_Predicate => Predicate : declare
19586 Check_Arg_Count (2);
19587 Check_Optional_Identifier (Arg1, Name_Entity);
19588 Check_Optional_Identifier (Arg2, Name_Check);
19590 Check_Arg_Is_Local_Name (Arg1);
19592 Type_Id := Get_Pragma_Arg (Arg1);
19593 Find_Type (Type_Id);
19594 Typ := Entity (Type_Id);
19596 if Typ = Any_Type then
19600 -- A pragma that applies to a Ghost entity becomes Ghost for the
19601 -- purposes of legality checks and removal of ignored Ghost code.
19603 Mark_Ghost_Pragma (N, Typ);
19605 -- The remaining processing is simply to link the pragma on to
19606 -- the rep item chain, for processing when the type is frozen.
19607 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19608 -- mark the type as having predicates.
19610 -- If the current policy for predicate checking is Ignore mark the
19611 -- subtype accordingly. In the case of predicates we consider them
19612 -- enabled unless Ignore is specified (either directly or with a
19613 -- general Assertion_Policy pragma) to preserve existing warnings.
19615 Set_Has_Predicates (Typ);
19616 Set_Predicates_Ignored (Typ,
19617 Present (Check_Policy_List)
19619 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
19620 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19623 -----------------------
19624 -- Predicate_Failure --
19625 -----------------------
19627 -- pragma Predicate_Failure
19628 -- ([Entity =>] type_LOCAL_NAME,
19629 -- [Message =>] string_EXPRESSION);
19631 when Pragma_Predicate_Failure => Predicate_Failure : declare
19638 Check_Arg_Count (2);
19639 Check_Optional_Identifier (Arg1, Name_Entity);
19640 Check_Optional_Identifier (Arg2, Name_Message);
19642 Check_Arg_Is_Local_Name (Arg1);
19644 Type_Id := Get_Pragma_Arg (Arg1);
19645 Find_Type (Type_Id);
19646 Typ := Entity (Type_Id);
19648 if Typ = Any_Type then
19652 -- A pragma that applies to a Ghost entity becomes Ghost for the
19653 -- purposes of legality checks and removal of ignored Ghost code.
19655 Mark_Ghost_Pragma (N, Typ);
19657 -- The remaining processing is simply to link the pragma on to
19658 -- the rep item chain, for processing when the type is frozen.
19659 -- This is accomplished by a call to Rep_Item_Too_Late.
19661 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19662 end Predicate_Failure;
19668 -- pragma Preelaborate [(library_unit_NAME)];
19670 -- Set the flag Is_Preelaborated of program unit name entity
19672 when Pragma_Preelaborate => Preelaborate : declare
19673 Pa : constant Node_Id := Parent (N);
19674 Pk : constant Node_Kind := Nkind (Pa);
19678 Check_Ada_83_Warning;
19679 Check_Valid_Library_Unit_Pragma;
19681 if Nkind (N) = N_Null_Statement then
19685 Ent := Find_Lib_Unit_Name;
19687 -- A pragma that applies to a Ghost entity becomes Ghost for the
19688 -- purposes of legality checks and removal of ignored Ghost code.
19690 Mark_Ghost_Pragma (N, Ent);
19691 Check_Duplicate_Pragma (Ent);
19693 -- This filters out pragmas inside generic parents that show up
19694 -- inside instantiations. Pragmas that come from aspects in the
19695 -- unit are not ignored.
19697 if Present (Ent) then
19698 if Pk = N_Package_Specification
19699 and then Present (Generic_Parent (Pa))
19700 and then not From_Aspect_Specification (N)
19705 if not Debug_Flag_U then
19706 Set_Is_Preelaborated (Ent);
19707 Set_Suppress_Elaboration_Warnings (Ent);
19713 -------------------------------
19714 -- Prefix_Exception_Messages --
19715 -------------------------------
19717 -- pragma Prefix_Exception_Messages;
19719 when Pragma_Prefix_Exception_Messages =>
19721 Check_Valid_Configuration_Pragma;
19722 Check_Arg_Count (0);
19723 Prefix_Exception_Messages := True;
19729 -- pragma Priority (EXPRESSION);
19731 when Pragma_Priority => Priority : declare
19732 P : constant Node_Id := Parent (N);
19737 Check_No_Identifiers;
19738 Check_Arg_Count (1);
19742 if Nkind (P) = N_Subprogram_Body then
19743 Check_In_Main_Program;
19745 Ent := Defining_Unit_Name (Specification (P));
19747 if Nkind (Ent) = N_Defining_Program_Unit_Name then
19748 Ent := Defining_Identifier (Ent);
19751 Arg := Get_Pragma_Arg (Arg1);
19752 Analyze_And_Resolve (Arg, Standard_Integer);
19756 if not Is_OK_Static_Expression (Arg) then
19757 Flag_Non_Static_Expr
19758 ("main subprogram priority is not static!", Arg);
19761 -- If constraint error, then we already signalled an error
19763 elsif Raises_Constraint_Error (Arg) then
19766 -- Otherwise check in range except if Relaxed_RM_Semantics
19767 -- where we ignore the value if out of range.
19770 if not Relaxed_RM_Semantics
19771 and then not Is_In_Range (Arg, RTE (RE_Priority))
19774 ("main subprogram priority is out of range", Arg1);
19777 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19781 -- Load an arbitrary entity from System.Tasking.Stages or
19782 -- System.Tasking.Restricted.Stages (depending on the
19783 -- supported profile) to make sure that one of these packages
19784 -- is implicitly with'ed, since we need to have the tasking
19785 -- run time active for the pragma Priority to have any effect.
19786 -- Previously we with'ed the package System.Tasking, but this
19787 -- package does not trigger the required initialization of the
19788 -- run-time library.
19791 Discard : Entity_Id;
19792 pragma Warnings (Off, Discard);
19794 if Restricted_Profile then
19795 Discard := RTE (RE_Activate_Restricted_Tasks);
19797 Discard := RTE (RE_Activate_Tasks);
19801 -- Task or Protected, must be of type Integer
19803 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19804 Arg := Get_Pragma_Arg (Arg1);
19805 Ent := Defining_Identifier (Parent (P));
19807 -- The expression must be analyzed in the special manner
19808 -- described in "Handling of Default and Per-Object
19809 -- Expressions" in sem.ads.
19811 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19813 if not Is_OK_Static_Expression (Arg) then
19814 Check_Restriction (Static_Priorities, Arg);
19817 -- Anything else is incorrect
19823 -- Check duplicate pragma before we chain the pragma in the Rep
19824 -- Item chain of Ent.
19826 Check_Duplicate_Pragma (Ent);
19827 Record_Rep_Item (Ent, N);
19830 -----------------------------------
19831 -- Priority_Specific_Dispatching --
19832 -----------------------------------
19834 -- pragma Priority_Specific_Dispatching (
19835 -- policy_IDENTIFIER,
19836 -- first_priority_EXPRESSION,
19837 -- last_priority_EXPRESSION);
19839 when Pragma_Priority_Specific_Dispatching =>
19840 Priority_Specific_Dispatching : declare
19841 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19842 -- This is the entity System.Any_Priority;
19845 Lower_Bound : Node_Id;
19846 Upper_Bound : Node_Id;
19852 Check_Arg_Count (3);
19853 Check_No_Identifiers;
19854 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19855 Check_Valid_Configuration_Pragma;
19856 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19857 DP := Fold_Upper (Name_Buffer (1));
19859 Lower_Bound := Get_Pragma_Arg (Arg2);
19860 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19861 Lower_Val := Expr_Value (Lower_Bound);
19863 Upper_Bound := Get_Pragma_Arg (Arg3);
19864 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19865 Upper_Val := Expr_Value (Upper_Bound);
19867 -- It is not allowed to use Task_Dispatching_Policy and
19868 -- Priority_Specific_Dispatching in the same partition.
19870 if Task_Dispatching_Policy /= ' ' then
19871 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19873 ("pragma% incompatible with Task_Dispatching_Policy#");
19875 -- Check lower bound in range
19877 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19879 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19882 ("first_priority is out of range", Arg2);
19884 -- Check upper bound in range
19886 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19888 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19891 ("last_priority is out of range", Arg3);
19893 -- Check that the priority range is valid
19895 elsif Lower_Val > Upper_Val then
19897 ("last_priority_expression must be greater than or equal to "
19898 & "first_priority_expression");
19900 -- Store the new policy, but always preserve System_Location since
19901 -- we like the error message with the run-time name.
19904 -- Check overlapping in the priority ranges specified in other
19905 -- Priority_Specific_Dispatching pragmas within the same
19906 -- partition. We can only check those we know about.
19909 Specific_Dispatching.First .. Specific_Dispatching.Last
19911 if Specific_Dispatching.Table (J).First_Priority in
19912 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19913 or else Specific_Dispatching.Table (J).Last_Priority in
19914 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19917 Specific_Dispatching.Table (J).Pragma_Loc;
19919 ("priority range overlaps with "
19920 & "Priority_Specific_Dispatching#");
19924 -- The use of Priority_Specific_Dispatching is incompatible
19925 -- with Task_Dispatching_Policy.
19927 if Task_Dispatching_Policy /= ' ' then
19928 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19930 ("Priority_Specific_Dispatching incompatible "
19931 & "with Task_Dispatching_Policy#");
19934 -- The use of Priority_Specific_Dispatching forces ceiling
19937 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19938 Error_Msg_Sloc := Locking_Policy_Sloc;
19940 ("Priority_Specific_Dispatching incompatible "
19941 & "with Locking_Policy#");
19943 -- Set the Ceiling_Locking policy, but preserve System_Location
19944 -- since we like the error message with the run time name.
19947 Locking_Policy := 'C';
19949 if Locking_Policy_Sloc /= System_Location then
19950 Locking_Policy_Sloc := Loc;
19954 -- Add entry in the table
19956 Specific_Dispatching.Append
19957 ((Dispatching_Policy => DP,
19958 First_Priority => UI_To_Int (Lower_Val),
19959 Last_Priority => UI_To_Int (Upper_Val),
19960 Pragma_Loc => Loc));
19962 end Priority_Specific_Dispatching;
19968 -- pragma Profile (profile_IDENTIFIER);
19970 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19972 when Pragma_Profile =>
19974 Check_Arg_Count (1);
19975 Check_Valid_Configuration_Pragma;
19976 Check_No_Identifiers;
19979 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19982 if Chars (Argx) = Name_Ravenscar then
19983 Set_Ravenscar_Profile (Ravenscar, N);
19985 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19986 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19988 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
19989 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
19991 elsif Chars (Argx) = Name_Restricted then
19992 Set_Profile_Restrictions
19994 N, Warn => Treat_Restrictions_As_Warnings);
19996 elsif Chars (Argx) = Name_Rational then
19997 Set_Rational_Profile;
19999 elsif Chars (Argx) = Name_No_Implementation_Extensions then
20000 Set_Profile_Restrictions
20001 (No_Implementation_Extensions,
20002 N, Warn => Treat_Restrictions_As_Warnings);
20005 Error_Pragma_Arg ("& is not a valid profile", Argx);
20009 ----------------------
20010 -- Profile_Warnings --
20011 ----------------------
20013 -- pragma Profile_Warnings (profile_IDENTIFIER);
20015 -- profile_IDENTIFIER => Restricted | Ravenscar
20017 when Pragma_Profile_Warnings =>
20019 Check_Arg_Count (1);
20020 Check_Valid_Configuration_Pragma;
20021 Check_No_Identifiers;
20024 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20027 if Chars (Argx) = Name_Ravenscar then
20028 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
20030 elsif Chars (Argx) = Name_Restricted then
20031 Set_Profile_Restrictions (Restricted, N, Warn => True);
20033 elsif Chars (Argx) = Name_No_Implementation_Extensions then
20034 Set_Profile_Restrictions
20035 (No_Implementation_Extensions, N, Warn => True);
20038 Error_Pragma_Arg ("& is not a valid profile", Argx);
20042 --------------------------
20043 -- Propagate_Exceptions --
20044 --------------------------
20046 -- pragma Propagate_Exceptions;
20048 -- Note: this pragma is obsolete and has no effect
20050 when Pragma_Propagate_Exceptions =>
20052 Check_Arg_Count (0);
20054 if Warn_On_Obsolescent_Feature then
20056 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20057 "and has no effect?j?", N);
20060 -----------------------------
20061 -- Provide_Shift_Operators --
20062 -----------------------------
20064 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20066 when Pragma_Provide_Shift_Operators =>
20067 Provide_Shift_Operators : declare
20070 procedure Declare_Shift_Operator (Nam : Name_Id);
20071 -- Insert declaration and pragma Instrinsic for named shift op
20073 ----------------------------
20074 -- Declare_Shift_Operator --
20075 ----------------------------
20077 procedure Declare_Shift_Operator (Nam : Name_Id) is
20083 Make_Subprogram_Declaration (Loc,
20084 Make_Function_Specification (Loc,
20085 Defining_Unit_Name =>
20086 Make_Defining_Identifier (Loc, Chars => Nam),
20088 Result_Definition =>
20089 Make_Identifier (Loc, Chars => Chars (Ent)),
20091 Parameter_Specifications => New_List (
20092 Make_Parameter_Specification (Loc,
20093 Defining_Identifier =>
20094 Make_Defining_Identifier (Loc, Name_Value),
20096 Make_Identifier (Loc, Chars => Chars (Ent))),
20098 Make_Parameter_Specification (Loc,
20099 Defining_Identifier =>
20100 Make_Defining_Identifier (Loc, Name_Amount),
20102 New_Occurrence_Of (Standard_Natural, Loc)))));
20106 Chars => Name_Import,
20107 Pragma_Argument_Associations => New_List (
20108 Make_Pragma_Argument_Association (Loc,
20109 Expression => Make_Identifier (Loc, Name_Intrinsic)),
20110 Make_Pragma_Argument_Association (Loc,
20111 Expression => Make_Identifier (Loc, Nam))));
20113 Insert_After (N, Import);
20114 Insert_After (N, Func);
20115 end Declare_Shift_Operator;
20117 -- Start of processing for Provide_Shift_Operators
20121 Check_Arg_Count (1);
20122 Check_Arg_Is_Local_Name (Arg1);
20124 Arg1 := Get_Pragma_Arg (Arg1);
20126 -- We must have an entity name
20128 if not Is_Entity_Name (Arg1) then
20130 ("pragma % must apply to integer first subtype", Arg1);
20133 -- If no Entity, means there was a prior error so ignore
20135 if Present (Entity (Arg1)) then
20136 Ent := Entity (Arg1);
20138 -- Apply error checks
20140 if not Is_First_Subtype (Ent) then
20142 ("cannot apply pragma %",
20143 "\& is not a first subtype",
20146 elsif not Is_Integer_Type (Ent) then
20148 ("cannot apply pragma %",
20149 "\& is not an integer type",
20152 elsif Has_Shift_Operator (Ent) then
20154 ("cannot apply pragma %",
20155 "\& already has declared shift operators",
20158 elsif Is_Frozen (Ent) then
20160 ("pragma % appears too late",
20161 "\& is already frozen",
20165 -- Now declare the operators. We do this during analysis rather
20166 -- than expansion, since we want the operators available if we
20167 -- are operating in -gnatc or ASIS mode.
20169 Declare_Shift_Operator (Name_Rotate_Left);
20170 Declare_Shift_Operator (Name_Rotate_Right);
20171 Declare_Shift_Operator (Name_Shift_Left);
20172 Declare_Shift_Operator (Name_Shift_Right);
20173 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
20175 end Provide_Shift_Operators;
20181 -- pragma Psect_Object (
20182 -- [Internal =>] LOCAL_NAME,
20183 -- [, [External =>] EXTERNAL_SYMBOL]
20184 -- [, [Size =>] EXTERNAL_SYMBOL]);
20186 when Pragma_Common_Object
20187 | Pragma_Psect_Object
20189 Psect_Object : declare
20190 Args : Args_List (1 .. 3);
20191 Names : constant Name_List (1 .. 3) := (
20196 Internal : Node_Id renames Args (1);
20197 External : Node_Id renames Args (2);
20198 Size : Node_Id renames Args (3);
20200 Def_Id : Entity_Id;
20202 procedure Check_Arg (Arg : Node_Id);
20203 -- Checks that argument is either a string literal or an
20204 -- identifier, and posts error message if not.
20210 procedure Check_Arg (Arg : Node_Id) is
20212 if not Nkind_In (Original_Node (Arg),
20217 ("inappropriate argument for pragma %", Arg);
20221 -- Start of processing for Common_Object/Psect_Object
20225 Gather_Associations (Names, Args);
20226 Process_Extended_Import_Export_Internal_Arg (Internal);
20228 Def_Id := Entity (Internal);
20230 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
20232 ("pragma% must designate an object", Internal);
20235 Check_Arg (Internal);
20237 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
20239 ("cannot use pragma% for imported/exported object",
20243 if Is_Concurrent_Type (Etype (Internal)) then
20245 ("cannot specify pragma % for task/protected object",
20249 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
20251 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
20253 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
20256 if Ekind (Def_Id) = E_Constant then
20258 ("cannot specify pragma % for a constant", Internal);
20261 if Is_Record_Type (Etype (Internal)) then
20267 Ent := First_Entity (Etype (Internal));
20268 while Present (Ent) loop
20269 Decl := Declaration_Node (Ent);
20271 if Ekind (Ent) = E_Component
20272 and then Nkind (Decl) = N_Component_Declaration
20273 and then Present (Expression (Decl))
20274 and then Warn_On_Export_Import
20277 ("?x?object for pragma % has defaults", Internal);
20287 if Present (Size) then
20291 if Present (External) then
20292 Check_Arg_Is_External_Name (External);
20295 -- If all error tests pass, link pragma on to the rep item chain
20297 Record_Rep_Item (Def_Id, N);
20304 -- pragma Pure [(library_unit_NAME)];
20306 when Pragma_Pure => Pure : declare
20310 Check_Ada_83_Warning;
20312 -- If the pragma comes from a subprogram instantiation, nothing to
20313 -- check, this can happen at any level of nesting.
20315 if Is_Wrapper_Package (Current_Scope) then
20318 Check_Valid_Library_Unit_Pragma;
20321 if Nkind (N) = N_Null_Statement then
20325 Ent := Find_Lib_Unit_Name;
20327 -- A pragma that applies to a Ghost entity becomes Ghost for the
20328 -- purposes of legality checks and removal of ignored Ghost code.
20330 Mark_Ghost_Pragma (N, Ent);
20332 if not Debug_Flag_U then
20334 Set_Has_Pragma_Pure (Ent);
20335 Set_Suppress_Elaboration_Warnings (Ent);
20339 -------------------
20340 -- Pure_Function --
20341 -------------------
20343 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20345 when Pragma_Pure_Function => Pure_Function : declare
20346 Def_Id : Entity_Id;
20349 Effective : Boolean := False;
20353 Check_Arg_Count (1);
20354 Check_Optional_Identifier (Arg1, Name_Entity);
20355 Check_Arg_Is_Local_Name (Arg1);
20356 E_Id := Get_Pragma_Arg (Arg1);
20358 if Error_Posted (E_Id) then
20362 -- Loop through homonyms (overloadings) of referenced entity
20364 E := Entity (E_Id);
20366 -- A pragma that applies to a Ghost entity becomes Ghost for the
20367 -- purposes of legality checks and removal of ignored Ghost code.
20369 Mark_Ghost_Pragma (N, E);
20371 if Present (E) then
20373 Def_Id := Get_Base_Subprogram (E);
20375 if not Ekind_In (Def_Id, E_Function,
20376 E_Generic_Function,
20380 ("pragma% requires a function name", Arg1);
20383 Set_Is_Pure (Def_Id);
20385 if not Has_Pragma_Pure_Function (Def_Id) then
20386 Set_Has_Pragma_Pure_Function (Def_Id);
20390 exit when From_Aspect_Specification (N);
20392 exit when No (E) or else Scope (E) /= Current_Scope;
20396 and then Warn_On_Redundant_Constructs
20399 ("pragma Pure_Function on& is redundant?r?",
20405 --------------------
20406 -- Queuing_Policy --
20407 --------------------
20409 -- pragma Queuing_Policy (policy_IDENTIFIER);
20411 when Pragma_Queuing_Policy => declare
20415 Check_Ada_83_Warning;
20416 Check_Arg_Count (1);
20417 Check_No_Identifiers;
20418 Check_Arg_Is_Queuing_Policy (Arg1);
20419 Check_Valid_Configuration_Pragma;
20420 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20421 QP := Fold_Upper (Name_Buffer (1));
20423 if Queuing_Policy /= ' '
20424 and then Queuing_Policy /= QP
20426 Error_Msg_Sloc := Queuing_Policy_Sloc;
20427 Error_Pragma ("queuing policy incompatible with policy#");
20429 -- Set new policy, but always preserve System_Location since we
20430 -- like the error message with the run time name.
20433 Queuing_Policy := QP;
20435 if Queuing_Policy_Sloc /= System_Location then
20436 Queuing_Policy_Sloc := Loc;
20445 -- pragma Rational, for compatibility with foreign compiler
20447 when Pragma_Rational =>
20448 Set_Rational_Profile;
20450 ---------------------
20451 -- Refined_Depends --
20452 ---------------------
20454 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20456 -- DEPENDENCY_RELATION ::=
20458 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20460 -- DEPENDENCY_CLAUSE ::=
20461 -- OUTPUT_LIST =>[+] INPUT_LIST
20462 -- | NULL_DEPENDENCY_CLAUSE
20464 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20466 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20468 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20470 -- OUTPUT ::= NAME | FUNCTION_RESULT
20473 -- where FUNCTION_RESULT is a function Result attribute_reference
20475 -- Characteristics:
20477 -- * Analysis - The annotation undergoes initial checks to verify
20478 -- the legal placement and context. Secondary checks fully analyze
20479 -- the dependency clauses/global list in:
20481 -- Analyze_Refined_Depends_In_Decl_Part
20483 -- * Expansion - None.
20485 -- * Template - The annotation utilizes the generic template of the
20486 -- related subprogram body.
20488 -- * Globals - Capture of global references must occur after full
20491 -- * Instance - The annotation is instantiated automatically when
20492 -- the related generic subprogram body is instantiated.
20494 when Pragma_Refined_Depends => Refined_Depends : declare
20495 Body_Id : Entity_Id;
20497 Spec_Id : Entity_Id;
20500 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20504 -- Chain the pragma on the contract for further processing by
20505 -- Analyze_Refined_Depends_In_Decl_Part.
20507 Add_Contract_Item (N, Body_Id);
20509 -- The legality checks of pragmas Refined_Depends and
20510 -- Refined_Global are affected by the SPARK mode in effect and
20511 -- the volatility of the context. In addition these two pragmas
20512 -- are subject to an inherent order:
20514 -- 1) Refined_Global
20515 -- 2) Refined_Depends
20517 -- Analyze all these pragmas in the order outlined above
20519 Analyze_If_Present (Pragma_SPARK_Mode);
20520 Analyze_If_Present (Pragma_Volatile_Function);
20521 Analyze_If_Present (Pragma_Refined_Global);
20522 Analyze_Refined_Depends_In_Decl_Part (N);
20524 end Refined_Depends;
20526 --------------------
20527 -- Refined_Global --
20528 --------------------
20530 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20532 -- GLOBAL_SPECIFICATION ::=
20535 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20537 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20539 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20540 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20541 -- GLOBAL_ITEM ::= NAME
20543 -- Characteristics:
20545 -- * Analysis - The annotation undergoes initial checks to verify
20546 -- the legal placement and context. Secondary checks fully analyze
20547 -- the dependency clauses/global list in:
20549 -- Analyze_Refined_Global_In_Decl_Part
20551 -- * Expansion - None.
20553 -- * Template - The annotation utilizes the generic template of the
20554 -- related subprogram body.
20556 -- * Globals - Capture of global references must occur after full
20559 -- * Instance - The annotation is instantiated automatically when
20560 -- the related generic subprogram body is instantiated.
20562 when Pragma_Refined_Global => Refined_Global : declare
20563 Body_Id : Entity_Id;
20565 Spec_Id : Entity_Id;
20568 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20572 -- Chain the pragma on the contract for further processing by
20573 -- Analyze_Refined_Global_In_Decl_Part.
20575 Add_Contract_Item (N, Body_Id);
20577 -- The legality checks of pragmas Refined_Depends and
20578 -- Refined_Global are affected by the SPARK mode in effect and
20579 -- the volatility of the context. In addition these two pragmas
20580 -- are subject to an inherent order:
20582 -- 1) Refined_Global
20583 -- 2) Refined_Depends
20585 -- Analyze all these pragmas in the order outlined above
20587 Analyze_If_Present (Pragma_SPARK_Mode);
20588 Analyze_If_Present (Pragma_Volatile_Function);
20589 Analyze_Refined_Global_In_Decl_Part (N);
20590 Analyze_If_Present (Pragma_Refined_Depends);
20592 end Refined_Global;
20598 -- pragma Refined_Post (boolean_EXPRESSION);
20600 -- Characteristics:
20602 -- * Analysis - The annotation is fully analyzed immediately upon
20603 -- elaboration as it cannot forward reference entities.
20605 -- * Expansion - The annotation is expanded during the expansion of
20606 -- the related subprogram body contract as performed in:
20608 -- Expand_Subprogram_Contract
20610 -- * Template - The annotation utilizes the generic template of the
20611 -- related subprogram body.
20613 -- * Globals - Capture of global references must occur after full
20616 -- * Instance - The annotation is instantiated automatically when
20617 -- the related generic subprogram body is instantiated.
20619 when Pragma_Refined_Post => Refined_Post : declare
20620 Body_Id : Entity_Id;
20622 Spec_Id : Entity_Id;
20625 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20627 -- Fully analyze the pragma when it appears inside a subprogram
20628 -- body because it cannot benefit from forward references.
20632 -- Chain the pragma on the contract for completeness
20634 Add_Contract_Item (N, Body_Id);
20636 -- The legality checks of pragma Refined_Post are affected by
20637 -- the SPARK mode in effect and the volatility of the context.
20638 -- Analyze all pragmas in a specific order.
20640 Analyze_If_Present (Pragma_SPARK_Mode);
20641 Analyze_If_Present (Pragma_Volatile_Function);
20642 Analyze_Pre_Post_Condition_In_Decl_Part (N);
20644 -- Currently it is not possible to inline pre/postconditions on
20645 -- a subprogram subject to pragma Inline_Always.
20647 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20651 -------------------
20652 -- Refined_State --
20653 -------------------
20655 -- pragma Refined_State (REFINEMENT_LIST);
20657 -- REFINEMENT_LIST ::=
20658 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20660 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20662 -- CONSTITUENT_LIST ::=
20665 -- | (CONSTITUENT {, CONSTITUENT})
20667 -- CONSTITUENT ::= object_NAME | state_NAME
20669 -- Characteristics:
20671 -- * Analysis - The annotation undergoes initial checks to verify
20672 -- the legal placement and context. Secondary checks preanalyze the
20673 -- refinement clauses in:
20675 -- Analyze_Refined_State_In_Decl_Part
20677 -- * Expansion - None.
20679 -- * Template - The annotation utilizes the template of the related
20682 -- * Globals - Capture of global references must occur after full
20685 -- * Instance - The annotation is instantiated automatically when
20686 -- the related generic package body is instantiated.
20688 when Pragma_Refined_State => Refined_State : declare
20689 Pack_Decl : Node_Id;
20690 Spec_Id : Entity_Id;
20694 Check_No_Identifiers;
20695 Check_Arg_Count (1);
20697 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20699 -- Ensure the proper placement of the pragma. Refined states must
20700 -- be associated with a package body.
20702 if Nkind (Pack_Decl) = N_Package_Body then
20705 -- Otherwise the pragma is associated with an illegal construct
20712 Spec_Id := Corresponding_Spec (Pack_Decl);
20714 -- A pragma that applies to a Ghost entity becomes Ghost for the
20715 -- purposes of legality checks and removal of ignored Ghost code.
20717 Mark_Ghost_Pragma (N, Spec_Id);
20719 -- Chain the pragma on the contract for further processing by
20720 -- Analyze_Refined_State_In_Decl_Part.
20722 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20724 -- The legality checks of pragma Refined_State are affected by the
20725 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20727 Analyze_If_Present (Pragma_SPARK_Mode);
20729 -- State refinement is allowed only when the corresponding package
20730 -- declaration has non-null pragma Abstract_State. Refinement not
20731 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20733 if SPARK_Mode /= Off
20735 (No (Abstract_States (Spec_Id))
20736 or else Has_Null_Abstract_State (Spec_Id))
20739 ("useless refinement, package & does not define abstract "
20740 & "states", N, Spec_Id);
20745 -----------------------
20746 -- Relative_Deadline --
20747 -----------------------
20749 -- pragma Relative_Deadline (time_span_EXPRESSION);
20751 when Pragma_Relative_Deadline => Relative_Deadline : declare
20752 P : constant Node_Id := Parent (N);
20757 Check_No_Identifiers;
20758 Check_Arg_Count (1);
20760 Arg := Get_Pragma_Arg (Arg1);
20762 -- The expression must be analyzed in the special manner described
20763 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20765 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20769 if Nkind (P) = N_Subprogram_Body then
20770 Check_In_Main_Program;
20772 -- Only Task and subprogram cases allowed
20774 elsif Nkind (P) /= N_Task_Definition then
20778 -- Check duplicate pragma before we set the corresponding flag
20780 if Has_Relative_Deadline_Pragma (P) then
20781 Error_Pragma ("duplicate pragma% not allowed");
20784 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20785 -- Relative_Deadline pragma node cannot be inserted in the Rep
20786 -- Item chain of Ent since it is rewritten by the expander as a
20787 -- procedure call statement that will break the chain.
20789 Set_Has_Relative_Deadline_Pragma (P);
20790 end Relative_Deadline;
20792 ------------------------
20793 -- Remote_Access_Type --
20794 ------------------------
20796 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20798 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20803 Check_Arg_Count (1);
20804 Check_Optional_Identifier (Arg1, Name_Entity);
20805 Check_Arg_Is_Local_Name (Arg1);
20807 E := Entity (Get_Pragma_Arg (Arg1));
20809 -- A pragma that applies to a Ghost entity becomes Ghost for the
20810 -- purposes of legality checks and removal of ignored Ghost code.
20812 Mark_Ghost_Pragma (N, E);
20814 if Nkind (Parent (E)) = N_Formal_Type_Declaration
20815 and then Ekind (E) = E_General_Access_Type
20816 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20817 and then Scope (Root_Type (Directly_Designated_Type (E)))
20819 and then Is_Valid_Remote_Object_Type
20820 (Root_Type (Directly_Designated_Type (E)))
20822 Set_Is_Remote_Types (E);
20826 ("pragma% applies only to formal access-to-class-wide types",
20829 end Remote_Access_Type;
20831 ---------------------------
20832 -- Remote_Call_Interface --
20833 ---------------------------
20835 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20837 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20838 Cunit_Node : Node_Id;
20839 Cunit_Ent : Entity_Id;
20843 Check_Ada_83_Warning;
20844 Check_Valid_Library_Unit_Pragma;
20846 if Nkind (N) = N_Null_Statement then
20850 Cunit_Node := Cunit (Current_Sem_Unit);
20851 K := Nkind (Unit (Cunit_Node));
20852 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20854 -- A pragma that applies to a Ghost entity becomes Ghost for the
20855 -- purposes of legality checks and removal of ignored Ghost code.
20857 Mark_Ghost_Pragma (N, Cunit_Ent);
20859 if K = N_Package_Declaration
20860 or else K = N_Generic_Package_Declaration
20861 or else K = N_Subprogram_Declaration
20862 or else K = N_Generic_Subprogram_Declaration
20863 or else (K = N_Subprogram_Body
20864 and then Acts_As_Spec (Unit (Cunit_Node)))
20869 "pragma% must apply to package or subprogram declaration");
20872 Set_Is_Remote_Call_Interface (Cunit_Ent);
20873 end Remote_Call_Interface;
20879 -- pragma Remote_Types [(library_unit_NAME)];
20881 when Pragma_Remote_Types => Remote_Types : declare
20882 Cunit_Node : Node_Id;
20883 Cunit_Ent : Entity_Id;
20886 Check_Ada_83_Warning;
20887 Check_Valid_Library_Unit_Pragma;
20889 if Nkind (N) = N_Null_Statement then
20893 Cunit_Node := Cunit (Current_Sem_Unit);
20894 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20896 -- A pragma that applies to a Ghost entity becomes Ghost for the
20897 -- purposes of legality checks and removal of ignored Ghost code.
20899 Mark_Ghost_Pragma (N, Cunit_Ent);
20901 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20902 N_Generic_Package_Declaration)
20905 ("pragma% can only apply to a package declaration");
20908 Set_Is_Remote_Types (Cunit_Ent);
20915 -- pragma Ravenscar;
20917 when Pragma_Ravenscar =>
20919 Check_Arg_Count (0);
20920 Check_Valid_Configuration_Pragma;
20921 Set_Ravenscar_Profile (Ravenscar, N);
20923 if Warn_On_Obsolescent_Feature then
20925 ("pragma Ravenscar is an obsolescent feature?j?", N);
20927 ("|use pragma Profile (Ravenscar) instead?j?", N);
20930 -------------------------
20931 -- Restricted_Run_Time --
20932 -------------------------
20934 -- pragma Restricted_Run_Time;
20936 when Pragma_Restricted_Run_Time =>
20938 Check_Arg_Count (0);
20939 Check_Valid_Configuration_Pragma;
20940 Set_Profile_Restrictions
20941 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20943 if Warn_On_Obsolescent_Feature then
20945 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20948 ("|use pragma Profile (Restricted) instead?j?", N);
20955 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20958 -- restriction_IDENTIFIER
20959 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20961 when Pragma_Restrictions =>
20962 Process_Restrictions_Or_Restriction_Warnings
20963 (Warn => Treat_Restrictions_As_Warnings);
20965 --------------------------
20966 -- Restriction_Warnings --
20967 --------------------------
20969 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20972 -- restriction_IDENTIFIER
20973 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20975 when Pragma_Restriction_Warnings =>
20977 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20983 -- pragma Reviewable;
20985 when Pragma_Reviewable =>
20986 Check_Ada_83_Warning;
20987 Check_Arg_Count (0);
20989 -- Call dummy debugging function rv. This is done to assist front
20990 -- end debugging. By placing a Reviewable pragma in the source
20991 -- program, a breakpoint on rv catches this place in the source,
20992 -- allowing convenient stepping to the point of interest.
20996 --------------------------
20997 -- Secondary_Stack_Size --
20998 --------------------------
21000 -- pragma Secondary_Stack_Size (EXPRESSION);
21002 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
21003 P : constant Node_Id := Parent (N);
21009 Check_No_Identifiers;
21010 Check_Arg_Count (1);
21012 if Nkind (P) = N_Task_Definition then
21013 Arg := Get_Pragma_Arg (Arg1);
21014 Ent := Defining_Identifier (Parent (P));
21016 -- The expression must be analyzed in the special manner
21017 -- described in "Handling of Default Expressions" in sem.ads.
21019 Preanalyze_Spec_Expression (Arg, Any_Integer);
21021 -- The pragma cannot appear if the No_Secondary_Stack
21022 -- restriction is in effect.
21024 Check_Restriction (No_Secondary_Stack, Arg);
21026 -- Anything else is incorrect
21032 -- Check duplicate pragma before we chain the pragma in the Rep
21033 -- Item chain of Ent.
21035 Check_Duplicate_Pragma (Ent);
21036 Record_Rep_Item (Ent, N);
21037 end Secondary_Stack_Size;
21039 --------------------------
21040 -- Short_Circuit_And_Or --
21041 --------------------------
21043 -- pragma Short_Circuit_And_Or;
21045 when Pragma_Short_Circuit_And_Or =>
21047 Check_Arg_Count (0);
21048 Check_Valid_Configuration_Pragma;
21049 Short_Circuit_And_Or := True;
21051 -------------------
21052 -- Share_Generic --
21053 -------------------
21055 -- pragma Share_Generic (GNAME {, GNAME});
21057 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21059 when Pragma_Share_Generic =>
21061 Process_Generic_List;
21067 -- pragma Shared (LOCAL_NAME);
21069 when Pragma_Shared =>
21071 Process_Atomic_Independent_Shared_Volatile;
21073 --------------------
21074 -- Shared_Passive --
21075 --------------------
21077 -- pragma Shared_Passive [(library_unit_NAME)];
21079 -- Set the flag Is_Shared_Passive of program unit name entity
21081 when Pragma_Shared_Passive => Shared_Passive : declare
21082 Cunit_Node : Node_Id;
21083 Cunit_Ent : Entity_Id;
21086 Check_Ada_83_Warning;
21087 Check_Valid_Library_Unit_Pragma;
21089 if Nkind (N) = N_Null_Statement then
21093 Cunit_Node := Cunit (Current_Sem_Unit);
21094 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
21096 -- A pragma that applies to a Ghost entity becomes Ghost for the
21097 -- purposes of legality checks and removal of ignored Ghost code.
21099 Mark_Ghost_Pragma (N, Cunit_Ent);
21101 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
21102 N_Generic_Package_Declaration)
21105 ("pragma% can only apply to a package declaration");
21108 Set_Is_Shared_Passive (Cunit_Ent);
21109 end Shared_Passive;
21111 -----------------------
21112 -- Short_Descriptors --
21113 -----------------------
21115 -- pragma Short_Descriptors;
21117 -- Recognize and validate, but otherwise ignore
21119 when Pragma_Short_Descriptors =>
21121 Check_Arg_Count (0);
21122 Check_Valid_Configuration_Pragma;
21124 ------------------------------
21125 -- Simple_Storage_Pool_Type --
21126 ------------------------------
21128 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21130 when Pragma_Simple_Storage_Pool_Type =>
21131 Simple_Storage_Pool_Type : declare
21137 Check_Arg_Count (1);
21138 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21140 Type_Id := Get_Pragma_Arg (Arg1);
21141 Find_Type (Type_Id);
21142 Typ := Entity (Type_Id);
21144 if Typ = Any_Type then
21148 -- A pragma that applies to a Ghost entity becomes Ghost for the
21149 -- purposes of legality checks and removal of ignored Ghost code.
21151 Mark_Ghost_Pragma (N, Typ);
21153 -- We require the pragma to apply to a type declared in a package
21154 -- declaration, but not (immediately) within a package body.
21156 if Ekind (Current_Scope) /= E_Package
21157 or else In_Package_Body (Current_Scope)
21160 ("pragma% can only apply to type declared immediately "
21161 & "within a package declaration");
21164 -- A simple storage pool type must be an immutably limited record
21165 -- or private type. If the pragma is given for a private type,
21166 -- the full type is similarly restricted (which is checked later
21167 -- in Freeze_Entity).
21169 if Is_Record_Type (Typ)
21170 and then not Is_Limited_View (Typ)
21173 ("pragma% can only apply to explicitly limited record type");
21175 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
21177 ("pragma% can only apply to a private type that is limited");
21179 elsif not Is_Record_Type (Typ)
21180 and then not Is_Private_Type (Typ)
21183 ("pragma% can only apply to limited record or private type");
21186 Record_Rep_Item (Typ, N);
21187 end Simple_Storage_Pool_Type;
21189 ----------------------
21190 -- Source_File_Name --
21191 ----------------------
21193 -- There are five forms for this pragma:
21195 -- pragma Source_File_Name (
21196 -- [UNIT_NAME =>] unit_NAME,
21197 -- BODY_FILE_NAME => STRING_LITERAL
21198 -- [, [INDEX =>] INTEGER_LITERAL]);
21200 -- pragma Source_File_Name (
21201 -- [UNIT_NAME =>] unit_NAME,
21202 -- SPEC_FILE_NAME => STRING_LITERAL
21203 -- [, [INDEX =>] INTEGER_LITERAL]);
21205 -- pragma Source_File_Name (
21206 -- BODY_FILE_NAME => STRING_LITERAL
21207 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21208 -- [, CASING => CASING_SPEC]);
21210 -- pragma Source_File_Name (
21211 -- SPEC_FILE_NAME => STRING_LITERAL
21212 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21213 -- [, CASING => CASING_SPEC]);
21215 -- pragma Source_File_Name (
21216 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21217 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21218 -- [, CASING => CASING_SPEC]);
21220 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21222 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21223 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21224 -- only be used when no project file is used, while SFNP can only be
21225 -- used when a project file is used.
21227 -- No processing here. Processing was completed during parsing, since
21228 -- we need to have file names set as early as possible. Units are
21229 -- loaded well before semantic processing starts.
21231 -- The only processing we defer to this point is the check for
21232 -- correct placement.
21234 when Pragma_Source_File_Name =>
21236 Check_Valid_Configuration_Pragma;
21238 ------------------------------
21239 -- Source_File_Name_Project --
21240 ------------------------------
21242 -- See Source_File_Name for syntax
21244 -- No processing here. Processing was completed during parsing, since
21245 -- we need to have file names set as early as possible. Units are
21246 -- loaded well before semantic processing starts.
21248 -- The only processing we defer to this point is the check for
21249 -- correct placement.
21251 when Pragma_Source_File_Name_Project =>
21253 Check_Valid_Configuration_Pragma;
21255 -- Check that a pragma Source_File_Name_Project is used only in a
21256 -- configuration pragmas file.
21258 -- Pragmas Source_File_Name_Project should only be generated by
21259 -- the Project Manager in configuration pragmas files.
21261 -- This is really an ugly test. It seems to depend on some
21262 -- accidental and undocumented property. At the very least it
21263 -- needs to be documented, but it would be better to have a
21264 -- clean way of testing if we are in a configuration file???
21266 if Present (Parent (N)) then
21268 ("pragma% can only appear in a configuration pragmas file");
21271 ----------------------
21272 -- Source_Reference --
21273 ----------------------
21275 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21277 -- Nothing to do, all processing completed in Par.Prag, since we need
21278 -- the information for possible parser messages that are output.
21280 when Pragma_Source_Reference =>
21287 -- pragma SPARK_Mode [(On | Off)];
21289 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
21290 Mode_Id : SPARK_Mode_Type;
21292 procedure Check_Pragma_Conformance
21293 (Context_Pragma : Node_Id;
21294 Entity : Entity_Id;
21295 Entity_Pragma : Node_Id);
21296 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21297 -- conformance of pragma N depending the following scenarios:
21299 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21300 -- compatible with the pragma Context_Pragma that was inherited
21301 -- from the context:
21302 -- * If the mode of Context_Pragma is ON, then the new mode can
21304 -- * If the mode of Context_Pragma is OFF, then the only allowed
21305 -- new mode is also OFF. Emit error if this is not the case.
21307 -- If Entity is not Empty, verify that pragma N is compatible with
21308 -- pragma Entity_Pragma that belongs to Entity.
21309 -- * If Entity_Pragma is Empty, always issue an error as this
21310 -- corresponds to the case where a previous section of Entity
21311 -- has no SPARK_Mode set.
21312 -- * If the mode of Entity_Pragma is ON, then the new mode can
21314 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21315 -- new mode is also OFF. Emit error if this is not the case.
21317 procedure Check_Library_Level_Entity (E : Entity_Id);
21318 -- Subsidiary to routines Process_xxx. Verify that the related
21319 -- entity E subject to pragma SPARK_Mode is library-level.
21321 procedure Process_Body (Decl : Node_Id);
21322 -- Verify the legality of pragma SPARK_Mode when it appears as the
21323 -- top of the body declarations of entry, package, protected unit,
21324 -- subprogram or task unit body denoted by Decl.
21326 procedure Process_Overloadable (Decl : Node_Id);
21327 -- Verify the legality of pragma SPARK_Mode when it applies to an
21328 -- entry or [generic] subprogram declaration denoted by Decl.
21330 procedure Process_Private_Part (Decl : Node_Id);
21331 -- Verify the legality of pragma SPARK_Mode when it appears at the
21332 -- top of the private declarations of a package spec, protected or
21333 -- task unit declaration denoted by Decl.
21335 procedure Process_Statement_Part (Decl : Node_Id);
21336 -- Verify the legality of pragma SPARK_Mode when it appears at the
21337 -- top of the statement sequence of a package body denoted by node
21340 procedure Process_Visible_Part (Decl : Node_Id);
21341 -- Verify the legality of pragma SPARK_Mode when it appears at the
21342 -- top of the visible declarations of a package spec, protected or
21343 -- task unit declaration denoted by Decl. The routine is also used
21344 -- on protected or task units declared without a definition.
21346 procedure Set_SPARK_Context;
21347 -- Subsidiary to routines Process_xxx. Set the global variables
21348 -- which represent the mode of the context from pragma N. Ensure
21349 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21351 ------------------------------
21352 -- Check_Pragma_Conformance --
21353 ------------------------------
21355 procedure Check_Pragma_Conformance
21356 (Context_Pragma : Node_Id;
21357 Entity : Entity_Id;
21358 Entity_Pragma : Node_Id)
21360 Err_Id : Entity_Id;
21364 -- The current pragma may appear without an argument. If this
21365 -- is the case, associate all error messages with the pragma
21368 if Present (Arg1) then
21374 -- The mode of the current pragma is compared against that of
21375 -- an enclosing context.
21377 if Present (Context_Pragma) then
21378 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
21380 -- Issue an error if the new mode is less restrictive than
21381 -- that of the context.
21383 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
21384 and then Get_SPARK_Mode_From_Annotation (N) = On
21387 ("cannot change SPARK_Mode from Off to On", Err_N);
21388 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21389 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
21394 -- The mode of the current pragma is compared against that of
21395 -- an initial package, protected type, subprogram or task type
21398 if Present (Entity) then
21400 -- A simple protected or task type is transformed into an
21401 -- anonymous type whose name cannot be used to issue error
21402 -- messages. Recover the original entity of the type.
21404 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
21407 (Original_Node (Unit_Declaration_Node (Entity)));
21412 -- Both the initial declaration and the completion carry
21413 -- SPARK_Mode pragmas.
21415 if Present (Entity_Pragma) then
21416 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
21418 -- Issue an error if the new mode is less restrictive
21419 -- than that of the initial declaration.
21421 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
21422 and then Get_SPARK_Mode_From_Annotation (N) = On
21424 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21425 Error_Msg_Sloc := Sloc (Entity_Pragma);
21427 ("\value Off was set for SPARK_Mode on&#",
21432 -- Otherwise the initial declaration lacks a SPARK_Mode
21433 -- pragma in which case the current pragma is illegal as
21434 -- it cannot "complete".
21437 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
21438 Error_Msg_Sloc := Sloc (Err_Id);
21440 ("\no value was set for SPARK_Mode on&#",
21445 end Check_Pragma_Conformance;
21447 --------------------------------
21448 -- Check_Library_Level_Entity --
21449 --------------------------------
21451 procedure Check_Library_Level_Entity (E : Entity_Id) is
21452 procedure Add_Entity_To_Name_Buffer;
21453 -- Add the E_Kind of entity E to the name buffer
21455 -------------------------------
21456 -- Add_Entity_To_Name_Buffer --
21457 -------------------------------
21459 procedure Add_Entity_To_Name_Buffer is
21461 if Ekind_In (E, E_Entry, E_Entry_Family) then
21462 Add_Str_To_Name_Buffer ("entry");
21464 elsif Ekind_In (E, E_Generic_Package,
21468 Add_Str_To_Name_Buffer ("package");
21470 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
21471 Add_Str_To_Name_Buffer ("protected type");
21473 elsif Ekind_In (E, E_Function,
21474 E_Generic_Function,
21475 E_Generic_Procedure,
21479 Add_Str_To_Name_Buffer ("subprogram");
21482 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
21483 Add_Str_To_Name_Buffer ("task type");
21485 end Add_Entity_To_Name_Buffer;
21489 Msg_1 : constant String := "incorrect placement of pragma%";
21492 -- Start of processing for Check_Library_Level_Entity
21495 if not Is_Library_Level_Entity (E) then
21496 Error_Msg_Name_1 := Pname;
21497 Error_Msg_N (Fix_Error (Msg_1), N);
21500 Add_Str_To_Name_Buffer ("\& is not a library-level ");
21501 Add_Entity_To_Name_Buffer;
21503 Msg_2 := Name_Find;
21504 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
21508 end Check_Library_Level_Entity;
21514 procedure Process_Body (Decl : Node_Id) is
21515 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21516 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
21519 -- Ignore pragma when applied to the special body created for
21520 -- inlining, recognized by its internal name _Parent.
21522 if Chars (Body_Id) = Name_uParent then
21526 Check_Library_Level_Entity (Body_Id);
21528 -- For entry bodies, verify the legality against:
21529 -- * The mode of the context
21530 -- * The mode of the spec (if any)
21532 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
21534 -- A stand alone subprogram body
21536 if Body_Id = Spec_Id then
21537 Check_Pragma_Conformance
21538 (Context_Pragma => SPARK_Pragma (Body_Id),
21540 Entity_Pragma => Empty);
21542 -- An entry or subprogram body that completes a previous
21546 Check_Pragma_Conformance
21547 (Context_Pragma => SPARK_Pragma (Body_Id),
21549 Entity_Pragma => SPARK_Pragma (Spec_Id));
21553 Set_SPARK_Pragma (Body_Id, N);
21554 Set_SPARK_Pragma_Inherited (Body_Id, False);
21556 -- For package bodies, verify the legality against:
21557 -- * The mode of the context
21558 -- * The mode of the private part
21560 -- This case is separated from protected and task bodies
21561 -- because the statement part of the package body inherits
21562 -- the mode of the body declarations.
21564 elsif Nkind (Decl) = N_Package_Body then
21565 Check_Pragma_Conformance
21566 (Context_Pragma => SPARK_Pragma (Body_Id),
21568 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21571 Set_SPARK_Pragma (Body_Id, N);
21572 Set_SPARK_Pragma_Inherited (Body_Id, False);
21573 Set_SPARK_Aux_Pragma (Body_Id, N);
21574 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21576 -- For protected and task bodies, verify the legality against:
21577 -- * The mode of the context
21578 -- * The mode of the private part
21582 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21584 Check_Pragma_Conformance
21585 (Context_Pragma => SPARK_Pragma (Body_Id),
21587 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21590 Set_SPARK_Pragma (Body_Id, N);
21591 Set_SPARK_Pragma_Inherited (Body_Id, False);
21595 --------------------------
21596 -- Process_Overloadable --
21597 --------------------------
21599 procedure Process_Overloadable (Decl : Node_Id) is
21600 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21601 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21604 Check_Library_Level_Entity (Spec_Id);
21606 -- Verify the legality against:
21607 -- * The mode of the context
21609 Check_Pragma_Conformance
21610 (Context_Pragma => SPARK_Pragma (Spec_Id),
21612 Entity_Pragma => Empty);
21614 Set_SPARK_Pragma (Spec_Id, N);
21615 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21617 -- When the pragma applies to the anonymous object created for
21618 -- a single task type, decorate the type as well. This scenario
21619 -- arises when the single task type lacks a task definition,
21620 -- therefore there is no issue with respect to a potential
21621 -- pragma SPARK_Mode in the private part.
21623 -- task type Anon_Task_Typ;
21624 -- Obj : Anon_Task_Typ;
21625 -- pragma SPARK_Mode ...;
21627 if Is_Single_Task_Object (Spec_Id) then
21628 Set_SPARK_Pragma (Spec_Typ, N);
21629 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
21630 Set_SPARK_Aux_Pragma (Spec_Typ, N);
21631 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21633 end Process_Overloadable;
21635 --------------------------
21636 -- Process_Private_Part --
21637 --------------------------
21639 procedure Process_Private_Part (Decl : Node_Id) is
21640 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21643 Check_Library_Level_Entity (Spec_Id);
21645 -- Verify the legality against:
21646 -- * The mode of the visible declarations
21648 Check_Pragma_Conformance
21649 (Context_Pragma => Empty,
21651 Entity_Pragma => SPARK_Pragma (Spec_Id));
21654 Set_SPARK_Aux_Pragma (Spec_Id, N);
21655 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21656 end Process_Private_Part;
21658 ----------------------------
21659 -- Process_Statement_Part --
21660 ----------------------------
21662 procedure Process_Statement_Part (Decl : Node_Id) is
21663 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21666 Check_Library_Level_Entity (Body_Id);
21668 -- Verify the legality against:
21669 -- * The mode of the body declarations
21671 Check_Pragma_Conformance
21672 (Context_Pragma => Empty,
21674 Entity_Pragma => SPARK_Pragma (Body_Id));
21677 Set_SPARK_Aux_Pragma (Body_Id, N);
21678 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21679 end Process_Statement_Part;
21681 --------------------------
21682 -- Process_Visible_Part --
21683 --------------------------
21685 procedure Process_Visible_Part (Decl : Node_Id) is
21686 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21687 Obj_Id : Entity_Id;
21690 Check_Library_Level_Entity (Spec_Id);
21692 -- Verify the legality against:
21693 -- * The mode of the context
21695 Check_Pragma_Conformance
21696 (Context_Pragma => SPARK_Pragma (Spec_Id),
21698 Entity_Pragma => Empty);
21700 -- A task unit declared without a definition does not set the
21701 -- SPARK_Mode of the context because the task does not have any
21702 -- entries that could inherit the mode.
21704 if not Nkind_In (Decl, N_Single_Task_Declaration,
21705 N_Task_Type_Declaration)
21710 Set_SPARK_Pragma (Spec_Id, N);
21711 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21712 Set_SPARK_Aux_Pragma (Spec_Id, N);
21713 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21715 -- When the pragma applies to a single protected or task type,
21716 -- decorate the corresponding anonymous object as well.
21718 -- protected Anon_Prot_Typ is
21719 -- pragma SPARK_Mode ...;
21721 -- end Anon_Prot_Typ;
21723 -- Obj : Anon_Prot_Typ;
21725 if Is_Single_Concurrent_Type (Spec_Id) then
21726 Obj_Id := Anonymous_Object (Spec_Id);
21728 Set_SPARK_Pragma (Obj_Id, N);
21729 Set_SPARK_Pragma_Inherited (Obj_Id, False);
21731 end Process_Visible_Part;
21733 -----------------------
21734 -- Set_SPARK_Context --
21735 -----------------------
21737 procedure Set_SPARK_Context is
21739 SPARK_Mode := Mode_Id;
21740 SPARK_Mode_Pragma := N;
21741 end Set_SPARK_Context;
21749 -- Start of processing for Do_SPARK_Mode
21752 -- When a SPARK_Mode pragma appears inside an instantiation whose
21753 -- enclosing context has SPARK_Mode set to "off", the pragma has
21754 -- no semantic effect.
21756 if Ignore_SPARK_Mode_Pragmas_In_Instance then
21757 Rewrite (N, Make_Null_Statement (Loc));
21763 Check_No_Identifiers;
21764 Check_At_Most_N_Arguments (1);
21766 -- Check the legality of the mode (no argument = ON)
21768 if Arg_Count = 1 then
21769 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21770 Mode := Chars (Get_Pragma_Arg (Arg1));
21775 Mode_Id := Get_SPARK_Mode_Type (Mode);
21776 Context := Parent (N);
21778 -- The pragma appears in a configuration file
21780 if No (Context) then
21781 Check_Valid_Configuration_Pragma;
21783 if Present (SPARK_Mode_Pragma) then
21786 Prev => SPARK_Mode_Pragma);
21792 -- The pragma acts as a configuration pragma in a compilation unit
21794 -- pragma SPARK_Mode ...;
21795 -- package Pack is ...;
21797 elsif Nkind (Context) = N_Compilation_Unit
21798 and then List_Containing (N) = Context_Items (Context)
21800 Check_Valid_Configuration_Pragma;
21803 -- Otherwise the placement of the pragma within the tree dictates
21804 -- its associated construct. Inspect the declarative list where
21805 -- the pragma resides to find a potential construct.
21809 while Present (Stmt) loop
21811 -- Skip prior pragmas, but check for duplicates. Note that
21812 -- this also takes care of pragmas generated for aspects.
21814 if Nkind (Stmt) = N_Pragma then
21815 if Pragma_Name (Stmt) = Pname then
21822 -- The pragma applies to an expression function that has
21823 -- already been rewritten into a subprogram declaration.
21825 -- function Expr_Func return ... is (...);
21826 -- pragma SPARK_Mode ...;
21828 elsif Nkind (Stmt) = N_Subprogram_Declaration
21829 and then Nkind (Original_Node (Stmt)) =
21830 N_Expression_Function
21832 Process_Overloadable (Stmt);
21835 -- The pragma applies to the anonymous object created for a
21836 -- single concurrent type.
21838 -- protected type Anon_Prot_Typ ...;
21839 -- Obj : Anon_Prot_Typ;
21840 -- pragma SPARK_Mode ...;
21842 elsif Nkind (Stmt) = N_Object_Declaration
21843 and then Is_Single_Concurrent_Object
21844 (Defining_Entity (Stmt))
21846 Process_Overloadable (Stmt);
21849 -- Skip internally generated code
21851 elsif not Comes_From_Source (Stmt) then
21854 -- The pragma applies to an entry or [generic] subprogram
21858 -- pragma SPARK_Mode ...;
21861 -- procedure Proc ...;
21862 -- pragma SPARK_Mode ...;
21864 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21865 N_Subprogram_Declaration)
21866 or else (Nkind (Stmt) = N_Entry_Declaration
21867 and then Is_Protected_Type
21868 (Scope (Defining_Entity (Stmt))))
21870 Process_Overloadable (Stmt);
21873 -- Otherwise the pragma does not apply to a legal construct
21874 -- or it does not appear at the top of a declarative or a
21875 -- statement list. Issue an error and stop the analysis.
21885 -- The pragma applies to a package or a subprogram that acts as
21886 -- a compilation unit.
21888 -- procedure Proc ...;
21889 -- pragma SPARK_Mode ...;
21891 if Nkind (Context) = N_Compilation_Unit_Aux then
21892 Context := Unit (Parent (Context));
21895 -- The pragma appears at the top of entry, package, protected
21896 -- unit, subprogram or task unit body declarations.
21898 -- entry Ent when ... is
21899 -- pragma SPARK_Mode ...;
21901 -- package body Pack is
21902 -- pragma SPARK_Mode ...;
21904 -- procedure Proc ... is
21905 -- pragma SPARK_Mode;
21907 -- protected body Prot is
21908 -- pragma SPARK_Mode ...;
21910 if Nkind_In (Context, N_Entry_Body,
21916 Process_Body (Context);
21918 -- The pragma appears at the top of the visible or private
21919 -- declaration of a package spec, protected or task unit.
21922 -- pragma SPARK_Mode ...;
21924 -- pragma SPARK_Mode ...;
21926 -- protected [type] Prot is
21927 -- pragma SPARK_Mode ...;
21929 -- pragma SPARK_Mode ...;
21931 elsif Nkind_In (Context, N_Package_Specification,
21932 N_Protected_Definition,
21935 if List_Containing (N) = Visible_Declarations (Context) then
21936 Process_Visible_Part (Parent (Context));
21938 Process_Private_Part (Parent (Context));
21941 -- The pragma appears at the top of package body statements
21943 -- package body Pack is
21945 -- pragma SPARK_Mode;
21947 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21948 and then Nkind (Parent (Context)) = N_Package_Body
21950 Process_Statement_Part (Parent (Context));
21952 -- The pragma appeared as an aspect of a [generic] subprogram
21953 -- declaration that acts as a compilation unit.
21956 -- procedure Proc ...;
21957 -- pragma SPARK_Mode ...;
21959 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21960 N_Subprogram_Declaration)
21962 Process_Overloadable (Context);
21964 -- The pragma does not apply to a legal construct, issue error
21972 --------------------------------
21973 -- Static_Elaboration_Desired --
21974 --------------------------------
21976 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21978 when Pragma_Static_Elaboration_Desired =>
21980 Check_At_Most_N_Arguments (1);
21982 if Is_Compilation_Unit (Current_Scope)
21983 and then Ekind (Current_Scope) = E_Package
21985 Set_Static_Elaboration_Desired (Current_Scope, True);
21987 Error_Pragma ("pragma% must apply to a library-level package");
21994 -- pragma Storage_Size (EXPRESSION);
21996 when Pragma_Storage_Size => Storage_Size : declare
21997 P : constant Node_Id := Parent (N);
22001 Check_No_Identifiers;
22002 Check_Arg_Count (1);
22004 -- The expression must be analyzed in the special manner described
22005 -- in "Handling of Default Expressions" in sem.ads.
22007 Arg := Get_Pragma_Arg (Arg1);
22008 Preanalyze_Spec_Expression (Arg, Any_Integer);
22010 if not Is_OK_Static_Expression (Arg) then
22011 Check_Restriction (Static_Storage_Size, Arg);
22014 if Nkind (P) /= N_Task_Definition then
22019 if Has_Storage_Size_Pragma (P) then
22020 Error_Pragma ("duplicate pragma% not allowed");
22022 Set_Has_Storage_Size_Pragma (P, True);
22025 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
22033 -- pragma Storage_Unit (NUMERIC_LITERAL);
22035 -- Only permitted argument is System'Storage_Unit value
22037 when Pragma_Storage_Unit =>
22038 Check_No_Identifiers;
22039 Check_Arg_Count (1);
22040 Check_Arg_Is_Integer_Literal (Arg1);
22042 if Intval (Get_Pragma_Arg (Arg1)) /=
22043 UI_From_Int (Ttypes.System_Storage_Unit)
22045 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
22047 ("the only allowed argument for pragma% is ^", Arg1);
22050 --------------------
22051 -- Stream_Convert --
22052 --------------------
22054 -- pragma Stream_Convert (
22055 -- [Entity =>] type_LOCAL_NAME,
22056 -- [Read =>] function_NAME,
22057 -- [Write =>] function NAME);
22059 when Pragma_Stream_Convert => Stream_Convert : declare
22060 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
22061 -- Check that the given argument is the name of a local function
22062 -- of one argument that is not overloaded earlier in the current
22063 -- local scope. A check is also made that the argument is a
22064 -- function with one parameter.
22066 --------------------------------------
22067 -- Check_OK_Stream_Convert_Function --
22068 --------------------------------------
22070 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
22074 Check_Arg_Is_Local_Name (Arg);
22075 Ent := Entity (Get_Pragma_Arg (Arg));
22077 if Has_Homonym (Ent) then
22079 ("argument for pragma% may not be overloaded", Arg);
22082 if Ekind (Ent) /= E_Function
22083 or else No (First_Formal (Ent))
22084 or else Present (Next_Formal (First_Formal (Ent)))
22087 ("argument for pragma% must be function of one argument",
22090 end Check_OK_Stream_Convert_Function;
22092 -- Start of processing for Stream_Convert
22096 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
22097 Check_Arg_Count (3);
22098 Check_Optional_Identifier (Arg1, Name_Entity);
22099 Check_Optional_Identifier (Arg2, Name_Read);
22100 Check_Optional_Identifier (Arg3, Name_Write);
22101 Check_Arg_Is_Local_Name (Arg1);
22102 Check_OK_Stream_Convert_Function (Arg2);
22103 Check_OK_Stream_Convert_Function (Arg3);
22106 Typ : constant Entity_Id :=
22107 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
22108 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
22109 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
22112 Check_First_Subtype (Arg1);
22114 -- Check for too early or too late. Note that we don't enforce
22115 -- the rule about primitive operations in this case, since, as
22116 -- is the case for explicit stream attributes themselves, these
22117 -- restrictions are not appropriate. Note that the chaining of
22118 -- the pragma by Rep_Item_Too_Late is actually the critical
22119 -- processing done for this pragma.
22121 if Rep_Item_Too_Early (Typ, N)
22123 Rep_Item_Too_Late (Typ, N, FOnly => True)
22128 -- Return if previous error
22130 if Etype (Typ) = Any_Type
22132 Etype (Read) = Any_Type
22134 Etype (Write) = Any_Type
22141 if Underlying_Type (Etype (Read)) /= Typ then
22143 ("incorrect return type for function&", Arg2);
22146 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
22148 ("incorrect parameter type for function&", Arg3);
22151 if Underlying_Type (Etype (First_Formal (Read))) /=
22152 Underlying_Type (Etype (Write))
22155 ("result type of & does not match Read parameter type",
22159 end Stream_Convert;
22165 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22167 -- This is processed by the parser since some of the style checks
22168 -- take place during source scanning and parsing. This means that
22169 -- we don't need to issue error messages here.
22171 when Pragma_Style_Checks => Style_Checks : declare
22172 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22178 Check_No_Identifiers;
22180 -- Two argument form
22182 if Arg_Count = 2 then
22183 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22190 E_Id := Get_Pragma_Arg (Arg2);
22193 if not Is_Entity_Name (E_Id) then
22195 ("second argument of pragma% must be entity name",
22199 E := Entity (E_Id);
22201 if not Ignore_Style_Checks_Pragmas then
22206 Set_Suppress_Style_Checks
22207 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
22208 exit when No (Homonym (E));
22215 -- One argument form
22218 Check_Arg_Count (1);
22220 if Nkind (A) = N_String_Literal then
22224 Slen : constant Natural := Natural (String_Length (S));
22225 Options : String (1 .. Slen);
22231 C := Get_String_Char (S, Pos (J));
22232 exit when not In_Character_Range (C);
22233 Options (J) := Get_Character (C);
22235 -- If at end of string, set options. As per discussion
22236 -- above, no need to check for errors, since we issued
22237 -- them in the parser.
22240 if not Ignore_Style_Checks_Pragmas then
22241 Set_Style_Check_Options (Options);
22251 elsif Nkind (A) = N_Identifier then
22252 if Chars (A) = Name_All_Checks then
22253 if not Ignore_Style_Checks_Pragmas then
22255 Set_GNAT_Style_Check_Options;
22257 Set_Default_Style_Check_Options;
22261 elsif Chars (A) = Name_On then
22262 if not Ignore_Style_Checks_Pragmas then
22263 Style_Check := True;
22266 elsif Chars (A) = Name_Off then
22267 if not Ignore_Style_Checks_Pragmas then
22268 Style_Check := False;
22279 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22281 when Pragma_Subtitle =>
22283 Check_Arg_Count (1);
22284 Check_Optional_Identifier (Arg1, Name_Subtitle);
22285 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22292 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22294 when Pragma_Suppress =>
22295 Process_Suppress_Unsuppress (Suppress_Case => True);
22301 -- pragma Suppress_All;
22303 -- The only check made here is that the pragma has no arguments.
22304 -- There are no placement rules, and the processing required (setting
22305 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22306 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22307 -- then creates and inserts a pragma Suppress (All_Checks).
22309 when Pragma_Suppress_All =>
22311 Check_Arg_Count (0);
22313 -------------------------
22314 -- Suppress_Debug_Info --
22315 -------------------------
22317 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22319 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
22320 Nam_Id : Entity_Id;
22324 Check_Arg_Count (1);
22325 Check_Optional_Identifier (Arg1, Name_Entity);
22326 Check_Arg_Is_Local_Name (Arg1);
22328 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
22330 -- A pragma that applies to a Ghost entity becomes Ghost for the
22331 -- purposes of legality checks and removal of ignored Ghost code.
22333 Mark_Ghost_Pragma (N, Nam_Id);
22334 Set_Debug_Info_Off (Nam_Id);
22335 end Suppress_Debug_Info;
22337 ----------------------------------
22338 -- Suppress_Exception_Locations --
22339 ----------------------------------
22341 -- pragma Suppress_Exception_Locations;
22343 when Pragma_Suppress_Exception_Locations =>
22345 Check_Arg_Count (0);
22346 Check_Valid_Configuration_Pragma;
22347 Exception_Locations_Suppressed := True;
22349 -----------------------------
22350 -- Suppress_Initialization --
22351 -----------------------------
22353 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22355 when Pragma_Suppress_Initialization => Suppress_Init : declare
22361 Check_Arg_Count (1);
22362 Check_Optional_Identifier (Arg1, Name_Entity);
22363 Check_Arg_Is_Local_Name (Arg1);
22365 E_Id := Get_Pragma_Arg (Arg1);
22367 if Etype (E_Id) = Any_Type then
22371 E := Entity (E_Id);
22373 -- A pragma that applies to a Ghost entity becomes Ghost for the
22374 -- purposes of legality checks and removal of ignored Ghost code.
22376 Mark_Ghost_Pragma (N, E);
22378 if not Is_Type (E) and then Ekind (E) /= E_Variable then
22380 ("pragma% requires variable, type or subtype", Arg1);
22383 if Rep_Item_Too_Early (E, N)
22385 Rep_Item_Too_Late (E, N, FOnly => True)
22390 -- For incomplete/private type, set flag on full view
22392 if Is_Incomplete_Or_Private_Type (E) then
22393 if No (Full_View (Base_Type (E))) then
22395 ("argument of pragma% cannot be an incomplete type", Arg1);
22397 Set_Suppress_Initialization (Full_View (Base_Type (E)));
22400 -- For first subtype, set flag on base type
22402 elsif Is_First_Subtype (E) then
22403 Set_Suppress_Initialization (Base_Type (E));
22405 -- For other than first subtype, set flag on subtype or variable
22408 Set_Suppress_Initialization (E);
22416 -- pragma System_Name (DIRECT_NAME);
22418 -- Syntax check: one argument, which must be the identifier GNAT or
22419 -- the identifier GCC, no other identifiers are acceptable.
22421 when Pragma_System_Name =>
22423 Check_No_Identifiers;
22424 Check_Arg_Count (1);
22425 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
22427 -----------------------------
22428 -- Task_Dispatching_Policy --
22429 -----------------------------
22431 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22433 when Pragma_Task_Dispatching_Policy => declare
22437 Check_Ada_83_Warning;
22438 Check_Arg_Count (1);
22439 Check_No_Identifiers;
22440 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
22441 Check_Valid_Configuration_Pragma;
22442 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22443 DP := Fold_Upper (Name_Buffer (1));
22445 if Task_Dispatching_Policy /= ' '
22446 and then Task_Dispatching_Policy /= DP
22448 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
22450 ("task dispatching policy incompatible with policy#");
22452 -- Set new policy, but always preserve System_Location since we
22453 -- like the error message with the run time name.
22456 Task_Dispatching_Policy := DP;
22458 if Task_Dispatching_Policy_Sloc /= System_Location then
22459 Task_Dispatching_Policy_Sloc := Loc;
22468 -- pragma Task_Info (EXPRESSION);
22470 when Pragma_Task_Info => Task_Info : declare
22471 P : constant Node_Id := Parent (N);
22477 if Warn_On_Obsolescent_Feature then
22479 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22480 & "instead?j?", N);
22483 if Nkind (P) /= N_Task_Definition then
22484 Error_Pragma ("pragma% must appear in task definition");
22487 Check_No_Identifiers;
22488 Check_Arg_Count (1);
22490 Analyze_And_Resolve
22491 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
22493 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
22497 Ent := Defining_Identifier (Parent (P));
22499 -- Check duplicate pragma before we chain the pragma in the Rep
22500 -- Item chain of Ent.
22503 (Ent, Name_Task_Info, Check_Parents => False)
22505 Error_Pragma ("duplicate pragma% not allowed");
22508 Record_Rep_Item (Ent, N);
22515 -- pragma Task_Name (string_EXPRESSION);
22517 when Pragma_Task_Name => Task_Name : declare
22518 P : constant Node_Id := Parent (N);
22523 Check_No_Identifiers;
22524 Check_Arg_Count (1);
22526 Arg := Get_Pragma_Arg (Arg1);
22528 -- The expression is used in the call to Create_Task, and must be
22529 -- expanded there, not in the context of the current spec. It must
22530 -- however be analyzed to capture global references, in case it
22531 -- appears in a generic context.
22533 Preanalyze_And_Resolve (Arg, Standard_String);
22535 if Nkind (P) /= N_Task_Definition then
22539 Ent := Defining_Identifier (Parent (P));
22541 -- Check duplicate pragma before we chain the pragma in the Rep
22542 -- Item chain of Ent.
22545 (Ent, Name_Task_Name, Check_Parents => False)
22547 Error_Pragma ("duplicate pragma% not allowed");
22550 Record_Rep_Item (Ent, N);
22557 -- pragma Task_Storage (
22558 -- [Task_Type =>] LOCAL_NAME,
22559 -- [Top_Guard =>] static_integer_EXPRESSION);
22561 when Pragma_Task_Storage => Task_Storage : declare
22562 Args : Args_List (1 .. 2);
22563 Names : constant Name_List (1 .. 2) := (
22567 Task_Type : Node_Id renames Args (1);
22568 Top_Guard : Node_Id renames Args (2);
22574 Gather_Associations (Names, Args);
22576 if No (Task_Type) then
22578 ("missing task_type argument for pragma%");
22581 Check_Arg_Is_Local_Name (Task_Type);
22583 Ent := Entity (Task_Type);
22585 if not Is_Task_Type (Ent) then
22587 ("argument for pragma% must be task type", Task_Type);
22590 if No (Top_Guard) then
22592 ("pragma% takes two arguments", Task_Type);
22594 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22597 Check_First_Subtype (Task_Type);
22599 if Rep_Item_Too_Late (Ent, N) then
22608 -- pragma Test_Case
22609 -- ([Name =>] Static_String_EXPRESSION
22610 -- ,[Mode =>] MODE_TYPE
22611 -- [, Requires => Boolean_EXPRESSION]
22612 -- [, Ensures => Boolean_EXPRESSION]);
22614 -- MODE_TYPE ::= Nominal | Robustness
22616 -- Characteristics:
22618 -- * Analysis - The annotation undergoes initial checks to verify
22619 -- the legal placement and context. Secondary checks preanalyze the
22622 -- Analyze_Test_Case_In_Decl_Part
22624 -- * Expansion - None.
22626 -- * Template - The annotation utilizes the generic template of the
22627 -- related subprogram when it is:
22629 -- aspect on subprogram declaration
22631 -- The annotation must prepare its own template when it is:
22633 -- pragma on subprogram declaration
22635 -- * Globals - Capture of global references must occur after full
22638 -- * Instance - The annotation is instantiated automatically when
22639 -- the related generic subprogram is instantiated except for the
22640 -- "pragma on subprogram declaration" case. In that scenario the
22641 -- annotation must instantiate itself.
22643 when Pragma_Test_Case => Test_Case : declare
22644 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22645 -- Ensure that the contract of subprogram Subp_Id does not contain
22646 -- another Test_Case pragma with the same Name as the current one.
22648 -------------------------
22649 -- Check_Distinct_Name --
22650 -------------------------
22652 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22653 Items : constant Node_Id := Contract (Subp_Id);
22654 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
22658 -- Inspect all Test_Case pragma of the related subprogram
22659 -- looking for one with a duplicate "Name" argument.
22661 if Present (Items) then
22662 Prag := Contract_Test_Cases (Items);
22663 while Present (Prag) loop
22664 if Pragma_Name (Prag) = Name_Test_Case
22666 and then String_Equal
22667 (Name, Get_Name_From_CTC_Pragma (Prag))
22669 Error_Msg_Sloc := Sloc (Prag);
22670 Error_Pragma ("name for pragma % is already used #");
22673 Prag := Next_Pragma (Prag);
22676 end Check_Distinct_Name;
22680 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22683 Subp_Decl : Node_Id;
22684 Subp_Id : Entity_Id;
22686 -- Start of processing for Test_Case
22690 Check_At_Least_N_Arguments (2);
22691 Check_At_Most_N_Arguments (4);
22693 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22697 Check_Optional_Identifier (Arg1, Name_Name);
22698 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22702 Check_Optional_Identifier (Arg2, Name_Mode);
22703 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22705 -- Arguments "Requires" and "Ensures"
22707 if Present (Arg3) then
22708 if Present (Arg4) then
22709 Check_Identifier (Arg3, Name_Requires);
22710 Check_Identifier (Arg4, Name_Ensures);
22712 Check_Identifier_Is_One_Of
22713 (Arg3, Name_Requires, Name_Ensures);
22717 -- Pragma Test_Case must be associated with a subprogram declared
22718 -- in a library-level package. First determine whether the current
22719 -- compilation unit is a legal context.
22721 if Nkind_In (Pack_Decl, N_Package_Declaration,
22722 N_Generic_Package_Declaration)
22726 -- Otherwise the placement is illegal
22730 ("pragma % must be specified within a package declaration");
22734 Subp_Decl := Find_Related_Declaration_Or_Body (N);
22736 -- Find the enclosing context
22738 Context := Parent (Subp_Decl);
22740 if Present (Context) then
22741 Context := Parent (Context);
22744 -- Verify the placement of the pragma
22746 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22748 ("pragma % cannot be applied to abstract subprogram");
22751 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22752 Error_Pragma ("pragma % cannot be applied to entry");
22755 -- The context is a [generic] subprogram declared at the top level
22756 -- of the [generic] package unit.
22758 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22759 N_Subprogram_Declaration)
22760 and then Present (Context)
22761 and then Nkind_In (Context, N_Generic_Package_Declaration,
22762 N_Package_Declaration)
22766 -- Otherwise the placement is illegal
22770 ("pragma % must be applied to a library-level subprogram "
22775 Subp_Id := Defining_Entity (Subp_Decl);
22777 -- A pragma that applies to a Ghost entity becomes Ghost for the
22778 -- purposes of legality checks and removal of ignored Ghost code.
22780 Mark_Ghost_Pragma (N, Subp_Id);
22782 -- Chain the pragma on the contract for further processing by
22783 -- Analyze_Test_Case_In_Decl_Part.
22785 Add_Contract_Item (N, Subp_Id);
22787 -- Preanalyze the original aspect argument "Name" for ASIS or for
22788 -- a generic subprogram to properly capture global references.
22790 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22791 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22793 if Present (Asp_Arg) then
22795 -- The argument appears with an identifier in association
22798 if Nkind (Asp_Arg) = N_Component_Association then
22799 Asp_Arg := Expression (Asp_Arg);
22802 Check_Expr_Is_OK_Static_Expression
22803 (Asp_Arg, Standard_String);
22807 -- Ensure that the all Test_Case pragmas of the related subprogram
22808 -- have distinct names.
22810 Check_Distinct_Name (Subp_Id);
22812 -- Fully analyze the pragma when it appears inside an entry
22813 -- or subprogram body because it cannot benefit from forward
22816 if Nkind_In (Subp_Decl, N_Entry_Body,
22818 N_Subprogram_Body_Stub)
22820 -- The legality checks of pragma Test_Case are affected by the
22821 -- SPARK mode in effect and the volatility of the context.
22822 -- Analyze all pragmas in a specific order.
22824 Analyze_If_Present (Pragma_SPARK_Mode);
22825 Analyze_If_Present (Pragma_Volatile_Function);
22826 Analyze_Test_Case_In_Decl_Part (N);
22830 --------------------------
22831 -- Thread_Local_Storage --
22832 --------------------------
22834 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22836 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22842 Check_Arg_Count (1);
22843 Check_Optional_Identifier (Arg1, Name_Entity);
22844 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22846 Id := Get_Pragma_Arg (Arg1);
22849 if not Is_Entity_Name (Id)
22850 or else Ekind (Entity (Id)) /= E_Variable
22852 Error_Pragma_Arg ("local variable name required", Arg1);
22857 -- A pragma that applies to a Ghost entity becomes Ghost for the
22858 -- purposes of legality checks and removal of ignored Ghost code.
22860 Mark_Ghost_Pragma (N, E);
22862 if Rep_Item_Too_Early (E, N)
22864 Rep_Item_Too_Late (E, N)
22869 Set_Has_Pragma_Thread_Local_Storage (E);
22870 Set_Has_Gigi_Rep_Item (E);
22871 end Thread_Local_Storage;
22877 -- pragma Time_Slice (static_duration_EXPRESSION);
22879 when Pragma_Time_Slice => Time_Slice : declare
22885 Check_Arg_Count (1);
22886 Check_No_Identifiers;
22887 Check_In_Main_Program;
22888 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22890 if not Error_Posted (Arg1) then
22892 while Present (Nod) loop
22893 if Nkind (Nod) = N_Pragma
22894 and then Pragma_Name (Nod) = Name_Time_Slice
22896 Error_Msg_Name_1 := Pname;
22897 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22904 -- Process only if in main unit
22906 if Get_Source_Unit (Loc) = Main_Unit then
22907 Opt.Time_Slice_Set := True;
22908 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22910 if Val <= Ureal_0 then
22911 Opt.Time_Slice_Value := 0;
22913 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22914 Opt.Time_Slice_Value := 1_000_000_000;
22917 Opt.Time_Slice_Value :=
22918 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22927 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22929 -- TITLING_OPTION ::=
22930 -- [Title =>] STRING_LITERAL
22931 -- | [Subtitle =>] STRING_LITERAL
22933 when Pragma_Title => Title : declare
22934 Args : Args_List (1 .. 2);
22935 Names : constant Name_List (1 .. 2) := (
22941 Gather_Associations (Names, Args);
22944 for J in 1 .. 2 loop
22945 if Present (Args (J)) then
22946 Check_Arg_Is_OK_Static_Expression
22947 (Args (J), Standard_String);
22952 ----------------------------
22953 -- Type_Invariant[_Class] --
22954 ----------------------------
22956 -- pragma Type_Invariant[_Class]
22957 -- ([Entity =>] type_LOCAL_NAME,
22958 -- [Check =>] EXPRESSION);
22960 when Pragma_Type_Invariant
22961 | Pragma_Type_Invariant_Class
22963 Type_Invariant : declare
22964 I_Pragma : Node_Id;
22967 Check_Arg_Count (2);
22969 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22970 -- setting Class_Present for the Type_Invariant_Class case.
22972 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22973 I_Pragma := New_Copy (N);
22974 Set_Pragma_Identifier
22975 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22976 Rewrite (N, I_Pragma);
22977 Set_Analyzed (N, False);
22979 end Type_Invariant;
22981 ---------------------
22982 -- Unchecked_Union --
22983 ---------------------
22985 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22987 when Pragma_Unchecked_Union => Unchecked_Union : declare
22988 Assoc : constant Node_Id := Arg1;
22989 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22999 Check_No_Identifiers;
23000 Check_Arg_Count (1);
23001 Check_Arg_Is_Local_Name (Arg1);
23003 Find_Type (Type_Id);
23005 Typ := Entity (Type_Id);
23007 -- A pragma that applies to a Ghost entity becomes Ghost for the
23008 -- purposes of legality checks and removal of ignored Ghost code.
23010 Mark_Ghost_Pragma (N, Typ);
23013 or else Rep_Item_Too_Early (Typ, N)
23017 Typ := Underlying_Type (Typ);
23020 if Rep_Item_Too_Late (Typ, N) then
23024 Check_First_Subtype (Arg1);
23026 -- Note remaining cases are references to a type in the current
23027 -- declarative part. If we find an error, we post the error on
23028 -- the relevant type declaration at an appropriate point.
23030 if not Is_Record_Type (Typ) then
23031 Error_Msg_N ("unchecked union must be record type", Typ);
23034 elsif Is_Tagged_Type (Typ) then
23035 Error_Msg_N ("unchecked union must not be tagged", Typ);
23038 elsif not Has_Discriminants (Typ) then
23040 ("unchecked union must have one discriminant", Typ);
23043 -- Note: in previous versions of GNAT we used to check for limited
23044 -- types and give an error, but in fact the standard does allow
23045 -- Unchecked_Union on limited types, so this check was removed.
23047 -- Similarly, GNAT used to require that all discriminants have
23048 -- default values, but this is not mandated by the RM.
23050 -- Proceed with basic error checks completed
23053 Tdef := Type_Definition (Declaration_Node (Typ));
23054 Clist := Component_List (Tdef);
23056 -- Check presence of component list and variant part
23058 if No (Clist) or else No (Variant_Part (Clist)) then
23060 ("unchecked union must have variant part", Tdef);
23064 -- Check components
23066 Comp := First (Component_Items (Clist));
23067 while Present (Comp) loop
23068 Check_Component (Comp, Typ);
23072 -- Check variant part
23074 Vpart := Variant_Part (Clist);
23076 Variant := First (Variants (Vpart));
23077 while Present (Variant) loop
23078 Check_Variant (Variant, Typ);
23083 Set_Is_Unchecked_Union (Typ);
23084 Set_Convention (Typ, Convention_C);
23085 Set_Has_Unchecked_Union (Base_Type (Typ));
23086 Set_Is_Unchecked_Union (Base_Type (Typ));
23087 end Unchecked_Union;
23089 ----------------------------
23090 -- Unevaluated_Use_Of_Old --
23091 ----------------------------
23093 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23095 when Pragma_Unevaluated_Use_Of_Old =>
23097 Check_Arg_Count (1);
23098 Check_No_Identifiers;
23099 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
23101 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23102 -- a declarative part or a package spec.
23104 if not Is_Configuration_Pragma then
23105 Check_Is_In_Decl_Part_Or_Package_Spec;
23108 -- Store proper setting of Uneval_Old
23110 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23111 Uneval_Old := Fold_Upper (Name_Buffer (1));
23113 ------------------------
23114 -- Unimplemented_Unit --
23115 ------------------------
23117 -- pragma Unimplemented_Unit;
23119 -- Note: this only gives an error if we are generating code, or if
23120 -- we are in a generic library unit (where the pragma appears in the
23121 -- body, not in the spec).
23123 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
23124 Cunitent : constant Entity_Id :=
23125 Cunit_Entity (Get_Source_Unit (Loc));
23126 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
23130 Check_Arg_Count (0);
23132 if Operating_Mode = Generate_Code
23133 or else Ent_Kind = E_Generic_Function
23134 or else Ent_Kind = E_Generic_Procedure
23135 or else Ent_Kind = E_Generic_Package
23137 Get_Name_String (Chars (Cunitent));
23138 Set_Casing (Mixed_Case);
23139 Write_Str (Name_Buffer (1 .. Name_Len));
23140 Write_Str (" is not supported in this configuration");
23142 raise Unrecoverable_Error;
23144 end Unimplemented_Unit;
23146 ------------------------
23147 -- Universal_Aliasing --
23148 ------------------------
23150 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23152 when Pragma_Universal_Aliasing => Universal_Alias : declare
23157 Check_Arg_Count (1);
23158 Check_Optional_Identifier (Arg2, Name_Entity);
23159 Check_Arg_Is_Local_Name (Arg1);
23160 E_Id := Entity (Get_Pragma_Arg (Arg1));
23162 if E_Id = Any_Type then
23164 elsif No (E_Id) or else not Is_Type (E_Id) then
23165 Error_Pragma_Arg ("pragma% requires type", Arg1);
23168 -- A pragma that applies to a Ghost entity becomes Ghost for the
23169 -- purposes of legality checks and removal of ignored Ghost code.
23171 Mark_Ghost_Pragma (N, E_Id);
23172 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
23173 Record_Rep_Item (E_Id, N);
23174 end Universal_Alias;
23176 --------------------
23177 -- Universal_Data --
23178 --------------------
23180 -- pragma Universal_Data [(library_unit_NAME)];
23182 when Pragma_Universal_Data =>
23184 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
23190 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23192 when Pragma_Unmodified =>
23193 Analyze_Unmodified_Or_Unused;
23199 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23201 -- or when used in a context clause:
23203 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23205 when Pragma_Unreferenced =>
23206 Analyze_Unreferenced_Or_Unused;
23208 --------------------------
23209 -- Unreferenced_Objects --
23210 --------------------------
23212 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23214 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
23216 Arg_Expr : Node_Id;
23217 Arg_Id : Entity_Id;
23219 Ghost_Error_Posted : Boolean := False;
23220 -- Flag set when an error concerning the illegal mix of Ghost and
23221 -- non-Ghost types is emitted.
23223 Ghost_Id : Entity_Id := Empty;
23224 -- The entity of the first Ghost type encountered while processing
23225 -- the arguments of the pragma.
23229 Check_At_Least_N_Arguments (1);
23232 while Present (Arg) loop
23233 Check_No_Identifier (Arg);
23234 Check_Arg_Is_Local_Name (Arg);
23235 Arg_Expr := Get_Pragma_Arg (Arg);
23237 if Is_Entity_Name (Arg_Expr) then
23238 Arg_Id := Entity (Arg_Expr);
23240 if Is_Type (Arg_Id) then
23241 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
23243 -- A pragma that applies to a Ghost entity becomes Ghost
23244 -- for the purposes of legality checks and removal of
23245 -- ignored Ghost code.
23247 Mark_Ghost_Pragma (N, Arg_Id);
23249 -- Capture the entity of the first Ghost type being
23250 -- processed for error detection purposes.
23252 if Is_Ghost_Entity (Arg_Id) then
23253 if No (Ghost_Id) then
23254 Ghost_Id := Arg_Id;
23257 -- Otherwise the type is non-Ghost. It is illegal to mix
23258 -- references to Ghost and non-Ghost entities
23261 elsif Present (Ghost_Id)
23262 and then not Ghost_Error_Posted
23264 Ghost_Error_Posted := True;
23266 Error_Msg_Name_1 := Pname;
23268 ("pragma % cannot mention ghost and non-ghost types",
23271 Error_Msg_Sloc := Sloc (Ghost_Id);
23272 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
23274 Error_Msg_Sloc := Sloc (Arg_Id);
23275 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
23279 ("argument for pragma% must be type or subtype", Arg);
23283 ("argument for pragma% must be type or subtype", Arg);
23288 end Unreferenced_Objects;
23290 ------------------------------
23291 -- Unreserve_All_Interrupts --
23292 ------------------------------
23294 -- pragma Unreserve_All_Interrupts;
23296 when Pragma_Unreserve_All_Interrupts =>
23298 Check_Arg_Count (0);
23300 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
23301 Unreserve_All_Interrupts := True;
23308 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23310 when Pragma_Unsuppress =>
23312 Process_Suppress_Unsuppress (Suppress_Case => False);
23318 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23320 when Pragma_Unused =>
23321 Analyze_Unmodified_Or_Unused (Is_Unused => True);
23322 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
23324 -------------------
23325 -- Use_VADS_Size --
23326 -------------------
23328 -- pragma Use_VADS_Size;
23330 when Pragma_Use_VADS_Size =>
23332 Check_Arg_Count (0);
23333 Check_Valid_Configuration_Pragma;
23334 Use_VADS_Size := True;
23336 ---------------------
23337 -- Validity_Checks --
23338 ---------------------
23340 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23342 when Pragma_Validity_Checks => Validity_Checks : declare
23343 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23349 Check_Arg_Count (1);
23350 Check_No_Identifiers;
23352 -- Pragma always active unless in CodePeer or GNATprove modes,
23353 -- which use a fixed configuration of validity checks.
23355 if not (CodePeer_Mode or GNATprove_Mode) then
23356 if Nkind (A) = N_String_Literal then
23360 Slen : constant Natural := Natural (String_Length (S));
23361 Options : String (1 .. Slen);
23365 -- Couldn't we use a for loop here over Options'Range???
23369 C := Get_String_Char (S, Pos (J));
23371 -- This is a weird test, it skips setting validity
23372 -- checks entirely if any element of S is out of
23373 -- range of Character, what is that about ???
23375 exit when not In_Character_Range (C);
23376 Options (J) := Get_Character (C);
23379 Set_Validity_Check_Options (Options);
23387 elsif Nkind (A) = N_Identifier then
23388 if Chars (A) = Name_All_Checks then
23389 Set_Validity_Check_Options ("a");
23390 elsif Chars (A) = Name_On then
23391 Validity_Checks_On := True;
23392 elsif Chars (A) = Name_Off then
23393 Validity_Checks_On := False;
23397 end Validity_Checks;
23403 -- pragma Volatile (LOCAL_NAME);
23405 when Pragma_Volatile =>
23406 Process_Atomic_Independent_Shared_Volatile;
23408 -------------------------
23409 -- Volatile_Components --
23410 -------------------------
23412 -- pragma Volatile_Components (array_LOCAL_NAME);
23414 -- Volatile is handled by the same circuit as Atomic_Components
23416 --------------------------
23417 -- Volatile_Full_Access --
23418 --------------------------
23420 -- pragma Volatile_Full_Access (LOCAL_NAME);
23422 when Pragma_Volatile_Full_Access =>
23424 Process_Atomic_Independent_Shared_Volatile;
23426 -----------------------
23427 -- Volatile_Function --
23428 -----------------------
23430 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23432 when Pragma_Volatile_Function => Volatile_Function : declare
23433 Over_Id : Entity_Id;
23434 Spec_Id : Entity_Id;
23435 Subp_Decl : Node_Id;
23439 Check_No_Identifiers;
23440 Check_At_Most_N_Arguments (1);
23443 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23445 -- Generic subprogram
23447 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23450 -- Body acts as spec
23452 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23453 and then No (Corresponding_Spec (Subp_Decl))
23457 -- Body stub acts as spec
23459 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23460 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23466 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23474 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23476 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
23481 -- A pragma that applies to a Ghost entity becomes Ghost for the
23482 -- purposes of legality checks and removal of ignored Ghost code.
23484 Mark_Ghost_Pragma (N, Spec_Id);
23486 -- Chain the pragma on the contract for completeness
23488 Add_Contract_Item (N, Spec_Id);
23490 -- The legality checks of pragma Volatile_Function are affected by
23491 -- the SPARK mode in effect. Analyze all pragmas in a specific
23494 Analyze_If_Present (Pragma_SPARK_Mode);
23496 -- A volatile function cannot override a non-volatile function
23497 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23498 -- in New_Overloaded_Entity, however at that point the pragma has
23499 -- not been processed yet.
23501 Over_Id := Overridden_Operation (Spec_Id);
23503 if Present (Over_Id)
23504 and then not Is_Volatile_Function (Over_Id)
23507 ("incompatible volatile function values in effect", Spec_Id);
23509 Error_Msg_Sloc := Sloc (Over_Id);
23511 ("\& declared # with Volatile_Function value False",
23514 Error_Msg_Sloc := Sloc (Spec_Id);
23516 ("\overridden # with Volatile_Function value True",
23520 -- Analyze the Boolean expression (if any)
23522 if Present (Arg1) then
23523 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
23525 end Volatile_Function;
23527 ----------------------
23528 -- Warning_As_Error --
23529 ----------------------
23531 -- pragma Warning_As_Error (static_string_EXPRESSION);
23533 when Pragma_Warning_As_Error =>
23535 Check_Arg_Count (1);
23536 Check_No_Identifiers;
23537 Check_Valid_Configuration_Pragma;
23539 if not Is_Static_String_Expression (Arg1) then
23541 ("argument of pragma% must be static string expression",
23544 -- OK static string expression
23547 Acquire_Warning_Match_String (Arg1);
23548 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23549 Warnings_As_Errors (Warnings_As_Errors_Count) :=
23550 new String'(Name_Buffer (1 .. Name_Len));
23557 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23559 -- DETAILS ::= On | Off
23560 -- DETAILS ::= On | Off, local_NAME
23561 -- DETAILS ::= static_string_EXPRESSION
23562 -- DETAILS ::= On | Off, static_string_EXPRESSION
23564 -- TOOL_NAME ::= GNAT | GNATProve
23566 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23568 -- Note: If the first argument matches an allowed tool name, it is
23569 -- always considered to be a tool name, even if there is a string
23570 -- variable of that name.
23572 -- Note if the second argument of DETAILS is a local_NAME then the
23573 -- second form is always understood. If the intention is to use
23574 -- the fourth form, then you can write NAME & "" to force the
23575 -- intepretation as a static_string_EXPRESSION.
23577 when Pragma_Warnings => Warnings : declare
23578 Reason : String_Id;
23582 Check_At_Least_N_Arguments (1);
23584 -- See if last argument is labeled Reason. If so, make sure we
23585 -- have a string literal or a concatenation of string literals,
23586 -- and acquire the REASON string. Then remove the REASON argument
23587 -- by decreasing Num_Args by one; Remaining processing looks only
23588 -- at first Num_Args arguments).
23591 Last_Arg : constant Node_Id :=
23592 Last (Pragma_Argument_Associations (N));
23595 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23596 and then Chars (Last_Arg) = Name_Reason
23599 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23600 Reason := End_String;
23601 Arg_Count := Arg_Count - 1;
23603 -- Not allowed in compiler units (bootstrap issues)
23605 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23607 -- No REASON string, set null string as reason
23610 Reason := Null_String_Id;
23614 -- Now proceed with REASON taken care of and eliminated
23616 Check_No_Identifiers;
23618 -- If debug flag -gnatd.i is set, pragma is ignored
23620 if Debug_Flag_Dot_I then
23624 -- Process various forms of the pragma
23627 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23628 Shifted_Args : List_Id;
23631 -- See if first argument is a tool name, currently either
23632 -- GNAT or GNATprove. If so, either ignore the pragma if the
23633 -- tool used does not match, or continue as if no tool name
23634 -- was given otherwise, by shifting the arguments.
23636 if Nkind (Argx) = N_Identifier
23637 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23639 if Chars (Argx) = Name_Gnat then
23640 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23641 Rewrite (N, Make_Null_Statement (Loc));
23646 elsif Chars (Argx) = Name_Gnatprove then
23647 if not GNATprove_Mode then
23648 Rewrite (N, Make_Null_Statement (Loc));
23654 raise Program_Error;
23657 -- At this point, the pragma Warnings applies to the tool,
23658 -- so continue with shifted arguments.
23660 Arg_Count := Arg_Count - 1;
23662 if Arg_Count = 1 then
23663 Shifted_Args := New_List (New_Copy (Arg2));
23664 elsif Arg_Count = 2 then
23665 Shifted_Args := New_List (New_Copy (Arg2),
23667 elsif Arg_Count = 3 then
23668 Shifted_Args := New_List (New_Copy (Arg2),
23672 raise Program_Error;
23677 Chars => Name_Warnings,
23678 Pragma_Argument_Associations => Shifted_Args));
23683 -- One argument case
23685 if Arg_Count = 1 then
23687 -- On/Off one argument case was processed by parser
23689 if Nkind (Argx) = N_Identifier
23690 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23694 -- One argument case must be ON/OFF or static string expr
23696 elsif not Is_Static_String_Expression (Arg1) then
23698 ("argument of pragma% must be On/Off or static string "
23699 & "expression", Arg1);
23701 -- One argument string expression case
23705 Lit : constant Node_Id := Expr_Value_S (Argx);
23706 Str : constant String_Id := Strval (Lit);
23707 Len : constant Nat := String_Length (Str);
23715 while J <= Len loop
23716 C := Get_String_Char (Str, J);
23717 OK := In_Character_Range (C);
23720 Chr := Get_Character (C);
23722 -- Dash case: only -Wxxx is accepted
23729 C := Get_String_Char (Str, J);
23730 Chr := Get_Character (C);
23731 exit when Chr = 'W';
23736 elsif J < Len and then Chr = '.' then
23738 C := Get_String_Char (Str, J);
23739 Chr := Get_Character (C);
23741 if not Set_Dot_Warning_Switch (Chr) then
23743 ("invalid warning switch character "
23744 & '.' & Chr, Arg1);
23750 OK := Set_Warning_Switch (Chr);
23756 ("invalid warning switch character " & Chr,
23765 -- Two or more arguments (must be two)
23768 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23769 Check_Arg_Count (2);
23777 E_Id := Get_Pragma_Arg (Arg2);
23780 -- In the expansion of an inlined body, a reference to
23781 -- the formal may be wrapped in a conversion if the
23782 -- actual is a conversion. Retrieve the real entity name.
23784 if (In_Instance_Body or In_Inlined_Body)
23785 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23787 E_Id := Expression (E_Id);
23790 -- Entity name case
23792 if Is_Entity_Name (E_Id) then
23793 E := Entity (E_Id);
23800 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23803 -- For OFF case, make entry in warnings off
23804 -- pragma table for later processing. But we do
23805 -- not do that within an instance, since these
23806 -- warnings are about what is needed in the
23807 -- template, not an instance of it.
23809 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23810 and then Warn_On_Warnings_Off
23811 and then not In_Instance
23813 Warnings_Off_Pragmas.Append ((N, E, Reason));
23816 if Is_Enumeration_Type (E) then
23820 Lit := First_Literal (E);
23821 while Present (Lit) loop
23822 Set_Warnings_Off (Lit);
23823 Next_Literal (Lit);
23828 exit when No (Homonym (E));
23833 -- Error if not entity or static string expression case
23835 elsif not Is_Static_String_Expression (Arg2) then
23837 ("second argument of pragma% must be entity name "
23838 & "or static string expression", Arg2);
23840 -- Static string expression case
23843 Acquire_Warning_Match_String (Arg2);
23845 -- Note on configuration pragma case: If this is a
23846 -- configuration pragma, then for an OFF pragma, we
23847 -- just set Config True in the call, which is all
23848 -- that needs to be done. For the case of ON, this
23849 -- is normally an error, unless it is canceling the
23850 -- effect of a previous OFF pragma in the same file.
23851 -- In any other case, an error will be signalled (ON
23852 -- with no matching OFF).
23854 -- Note: We set Used if we are inside a generic to
23855 -- disable the test that the non-config case actually
23856 -- cancels a warning. That's because we can't be sure
23857 -- there isn't an instantiation in some other unit
23858 -- where a warning is suppressed.
23860 -- We could do a little better here by checking if the
23861 -- generic unit we are inside is public, but for now
23862 -- we don't bother with that refinement.
23864 if Chars (Argx) = Name_Off then
23865 Set_Specific_Warning_Off
23866 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23867 Config => Is_Configuration_Pragma,
23868 Used => Inside_A_Generic or else In_Instance);
23870 elsif Chars (Argx) = Name_On then
23871 Set_Specific_Warning_On
23872 (Loc, Name_Buffer (1 .. Name_Len), Err);
23876 ("??pragma Warnings On with no matching "
23877 & "Warnings Off", Loc);
23886 -------------------
23887 -- Weak_External --
23888 -------------------
23890 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23892 when Pragma_Weak_External => Weak_External : declare
23897 Check_Arg_Count (1);
23898 Check_Optional_Identifier (Arg1, Name_Entity);
23899 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23900 Ent := Entity (Get_Pragma_Arg (Arg1));
23902 if Rep_Item_Too_Early (Ent, N) then
23905 Ent := Underlying_Type (Ent);
23908 -- The only processing required is to link this item on to the
23909 -- list of rep items for the given entity. This is accomplished
23910 -- by the call to Rep_Item_Too_Late (when no error is detected
23911 -- and False is returned).
23913 if Rep_Item_Too_Late (Ent, N) then
23916 Set_Has_Gigi_Rep_Item (Ent);
23920 -----------------------------
23921 -- Wide_Character_Encoding --
23922 -----------------------------
23924 -- pragma Wide_Character_Encoding (IDENTIFIER);
23926 when Pragma_Wide_Character_Encoding =>
23929 -- Nothing to do, handled in parser. Note that we do not enforce
23930 -- configuration pragma placement, this pragma can appear at any
23931 -- place in the source, allowing mixed encodings within a single
23936 --------------------
23937 -- Unknown_Pragma --
23938 --------------------
23940 -- Should be impossible, since the case of an unknown pragma is
23941 -- separately processed before the case statement is entered.
23943 when Unknown_Pragma =>
23944 raise Program_Error;
23947 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23948 -- until AI is formally approved.
23950 -- Check_Order_Dependence;
23953 when Pragma_Exit => null;
23954 end Analyze_Pragma;
23956 ---------------------------------------------
23957 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23958 ---------------------------------------------
23960 -- WARNING: This routine manages Ghost regions. Return statements must be
23961 -- replaced by gotos which jump to the end of the routine and restore the
23964 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23966 Freeze_Id : Entity_Id := Empty)
23968 Disp_Typ : Entity_Id;
23969 -- The dispatching type of the subprogram subject to the pre- or
23972 function Check_References (Nod : Node_Id) return Traverse_Result;
23973 -- Check that expression Nod does not mention non-primitives of the
23974 -- type, global objects of the type, or other illegalities described
23975 -- and implied by AI12-0113.
23977 ----------------------
23978 -- Check_References --
23979 ----------------------
23981 function Check_References (Nod : Node_Id) return Traverse_Result is
23983 if Nkind (Nod) = N_Function_Call
23984 and then Is_Entity_Name (Name (Nod))
23987 Func : constant Entity_Id := Entity (Name (Nod));
23991 -- An operation of the type must be a primitive
23993 if No (Find_Dispatching_Type (Func)) then
23994 Form := First_Formal (Func);
23995 while Present (Form) loop
23996 if Etype (Form) = Disp_Typ then
23998 ("operation in class-wide condition must be "
23999 & "primitive of &", Nod, Disp_Typ);
24002 Next_Formal (Form);
24005 -- A return object of the type is illegal as well
24007 if Etype (Func) = Disp_Typ
24008 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24011 ("operation in class-wide condition must be primitive "
24012 & "of &", Nod, Disp_Typ);
24017 elsif Is_Entity_Name (Nod)
24019 (Etype (Nod) = Disp_Typ
24020 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24021 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24024 ("object in class-wide condition must be formal of type &",
24027 elsif Nkind (Nod) = N_Explicit_Dereference
24028 and then (Etype (Nod) = Disp_Typ
24029 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24030 and then (not Is_Entity_Name (Prefix (Nod))
24031 or else not Is_Formal (Entity (Prefix (Nod))))
24034 ("operation in class-wide condition must be primitive of &",
24039 end Check_References;
24041 procedure Check_Class_Wide_Condition is
24042 new Traverse_Proc (Check_References);
24046 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24047 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24048 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24050 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24051 -- Save the Ghost mode to restore on exit
24054 Restore_Scope : Boolean := False;
24056 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24059 -- Do not analyze the pragma multiple times
24061 if Is_Analyzed_Pragma (N) then
24065 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24066 -- analysis of the pragma, the Ghost mode at point of declaration and
24067 -- point of analysis may not necessarily be the same. Use the mode in
24068 -- effect at the point of declaration.
24070 Set_Ghost_Mode (N);
24072 -- Ensure that the subprogram and its formals are visible when analyzing
24073 -- the expression of the pragma.
24075 if not In_Open_Scopes (Spec_Id) then
24076 Restore_Scope := True;
24077 Push_Scope (Spec_Id);
24079 if Is_Generic_Subprogram (Spec_Id) then
24080 Install_Generic_Formals (Spec_Id);
24082 Install_Formals (Spec_Id);
24086 Errors := Serious_Errors_Detected;
24087 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24089 -- Emit a clarification message when the expression contains at least
24090 -- one undefined reference, possibly due to contract "freezing".
24092 if Errors /= Serious_Errors_Detected
24093 and then Present (Freeze_Id)
24094 and then Has_Undefined_Reference (Expr)
24096 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24099 if Class_Present (N) then
24101 -- Verify that a class-wide condition is legal, i.e. the operation is
24102 -- a primitive of a tagged type. Note that a generic subprogram is
24103 -- not a primitive operation.
24105 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24107 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24108 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24110 if From_Aspect_Specification (N) then
24112 ("aspect % can only be specified for a primitive operation "
24113 & "of a tagged type", Corresponding_Aspect (N));
24115 -- The pragma is a source construct
24119 ("pragma % can only be specified for a primitive operation "
24120 & "of a tagged type", N);
24123 -- Remaining semantic checks require a full tree traversal
24126 Check_Class_Wide_Condition (Expr);
24131 if Restore_Scope then
24135 -- Currently it is not possible to inline pre/postconditions on a
24136 -- subprogram subject to pragma Inline_Always.
24138 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24139 Set_Is_Analyzed_Pragma (N);
24141 Restore_Ghost_Mode (Saved_GM);
24142 end Analyze_Pre_Post_Condition_In_Decl_Part;
24144 ------------------------------------------
24145 -- Analyze_Refined_Depends_In_Decl_Part --
24146 ------------------------------------------
24148 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24149 procedure Check_Dependency_Clause
24150 (Spec_Id : Entity_Id;
24151 Dep_Clause : Node_Id;
24152 Dep_States : Elist_Id;
24153 Refinements : List_Id;
24154 Matched_Items : in out Elist_Id);
24155 -- Try to match a single dependency clause Dep_Clause against one or
24156 -- more refinement clauses found in list Refinements. Each successful
24157 -- match eliminates at least one refinement clause from Refinements.
24158 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24159 -- denotes the entities of all abstract states which appear in pragma
24160 -- Depends. Matched_Items contains the entities of all successfully
24161 -- matched items found in pragma Depends.
24163 procedure Check_Output_States
24164 (Spec_Id : Entity_Id;
24165 Spec_Inputs : Elist_Id;
24166 Spec_Outputs : Elist_Id;
24167 Body_Inputs : Elist_Id;
24168 Body_Outputs : Elist_Id);
24169 -- Determine whether pragma Depends contains an output state with a
24170 -- visible refinement and if so, ensure that pragma Refined_Depends
24171 -- mentions all its constituents as outputs. Spec_Id is the entity of
24172 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24173 -- inputs and outputs of the subprogram spec synthesized from pragma
24174 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24175 -- of the subprogram body synthesized from pragma Refined_Depends.
24177 function Collect_States (Clauses : List_Id) return Elist_Id;
24178 -- Given a normalized list of dependencies obtained from calling
24179 -- Normalize_Clauses, return a list containing the entities of all
24180 -- states appearing in dependencies. It helps in checking refinements
24181 -- involving a state and a corresponding constituent which is not a
24182 -- direct constituent of the state.
24184 procedure Normalize_Clauses (Clauses : List_Id);
24185 -- Given a list of dependence or refinement clauses Clauses, normalize
24186 -- each clause by creating multiple dependencies with exactly one input
24189 procedure Remove_Extra_Clauses
24190 (Clauses : List_Id;
24191 Matched_Items : Elist_Id);
24192 -- Given a list of refinement clauses Clauses, remove all clauses whose
24193 -- inputs and/or outputs have been previously matched. See the body for
24194 -- all special cases. Matched_Items contains the entities of all matched
24195 -- items found in pragma Depends.
24197 procedure Report_Extra_Clauses
24198 (Spec_Id : Entity_Id;
24199 Clauses : List_Id);
24200 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24201 -- denotes the entity of the related subprogram.
24203 -----------------------------
24204 -- Check_Dependency_Clause --
24205 -----------------------------
24207 procedure Check_Dependency_Clause
24208 (Spec_Id : Entity_Id;
24209 Dep_Clause : Node_Id;
24210 Dep_States : Elist_Id;
24211 Refinements : List_Id;
24212 Matched_Items : in out Elist_Id)
24214 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24215 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24217 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24218 -- Determine whether dependency item Dep_Item has been matched in a
24219 -- previous clause.
24221 function Is_In_Out_State_Clause return Boolean;
24222 -- Determine whether dependence clause Dep_Clause denotes an abstract
24223 -- state that depends on itself (State => State).
24225 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24226 -- Determine whether item Item denotes an abstract state with visible
24227 -- null refinement.
24229 procedure Match_Items
24230 (Dep_Item : Node_Id;
24231 Ref_Item : Node_Id;
24232 Matched : out Boolean);
24233 -- Try to match dependence item Dep_Item against refinement item
24234 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24235 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24236 -- the following conformance scenarios is in effect:
24237 -- 1) Both items denote null
24238 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24239 -- 3) Both items denote attribute 'Result
24240 -- 4) Both items denote the same object
24241 -- 5) Both items denote the same formal parameter
24242 -- 6) Both items denote the same current instance of a type
24243 -- 7) Both items denote the same discriminant
24244 -- 8) Dep_Item is an abstract state with visible null refinement
24245 -- and Ref_Item denotes null.
24246 -- 9) Dep_Item is an abstract state with visible null refinement
24247 -- and Ref_Item is Empty (special case).
24248 -- 10) Dep_Item is an abstract state with full or partial visible
24249 -- non-null refinement and Ref_Item denotes one of its
24251 -- 11) Dep_Item is an abstract state without a full visible
24252 -- refinement and Ref_Item denotes the same state.
24253 -- When scenario 10 is in effect, the entity of the abstract state
24254 -- denoted by Dep_Item is added to list Refined_States.
24256 procedure Record_Item (Item_Id : Entity_Id);
24257 -- Store the entity of an item denoted by Item_Id in Matched_Items
24259 ------------------------
24260 -- Is_Already_Matched --
24261 ------------------------
24263 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
24264 Item_Id : Entity_Id := Empty;
24267 -- When the dependency item denotes attribute 'Result, check for
24268 -- the entity of the related subprogram.
24270 if Is_Attribute_Result (Dep_Item) then
24271 Item_Id := Spec_Id;
24273 elsif Is_Entity_Name (Dep_Item) then
24274 Item_Id := Available_View (Entity_Of (Dep_Item));
24278 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
24279 end Is_Already_Matched;
24281 ----------------------------
24282 -- Is_In_Out_State_Clause --
24283 ----------------------------
24285 function Is_In_Out_State_Clause return Boolean is
24286 Dep_Input_Id : Entity_Id;
24287 Dep_Output_Id : Entity_Id;
24290 -- Detect the following clause:
24293 if Is_Entity_Name (Dep_Input)
24294 and then Is_Entity_Name (Dep_Output)
24296 -- Handle abstract views generated for limited with clauses
24298 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
24299 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
24302 Ekind (Dep_Input_Id) = E_Abstract_State
24303 and then Dep_Input_Id = Dep_Output_Id;
24307 end Is_In_Out_State_Clause;
24309 ---------------------------
24310 -- Is_Null_Refined_State --
24311 ---------------------------
24313 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
24314 Item_Id : Entity_Id;
24317 if Is_Entity_Name (Item) then
24319 -- Handle abstract views generated for limited with clauses
24321 Item_Id := Available_View (Entity_Of (Item));
24324 Ekind (Item_Id) = E_Abstract_State
24325 and then Has_Null_Visible_Refinement (Item_Id);
24329 end Is_Null_Refined_State;
24335 procedure Match_Items
24336 (Dep_Item : Node_Id;
24337 Ref_Item : Node_Id;
24338 Matched : out Boolean)
24340 Dep_Item_Id : Entity_Id;
24341 Ref_Item_Id : Entity_Id;
24344 -- Assume that the two items do not match
24348 -- A null matches null or Empty (special case)
24350 if Nkind (Dep_Item) = N_Null
24351 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24355 -- Attribute 'Result matches attribute 'Result
24357 elsif Is_Attribute_Result (Dep_Item)
24358 and then Is_Attribute_Result (Ref_Item)
24360 -- Put the entity of the related function on the list of
24361 -- matched items because attribute 'Result does not carry
24362 -- an entity similar to states and constituents.
24364 Record_Item (Spec_Id);
24367 -- Abstract states, current instances of concurrent types,
24368 -- discriminants, formal parameters and objects.
24370 elsif Is_Entity_Name (Dep_Item) then
24372 -- Handle abstract views generated for limited with clauses
24374 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
24376 if Ekind (Dep_Item_Id) = E_Abstract_State then
24378 -- An abstract state with visible null refinement matches
24379 -- null or Empty (special case).
24381 if Has_Null_Visible_Refinement (Dep_Item_Id)
24382 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
24384 Record_Item (Dep_Item_Id);
24387 -- An abstract state with visible non-null refinement
24388 -- matches one of its constituents, or itself for an
24389 -- abstract state with partial visible refinement.
24391 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
24392 if Is_Entity_Name (Ref_Item) then
24393 Ref_Item_Id := Entity_Of (Ref_Item);
24395 if Ekind_In (Ref_Item_Id, E_Abstract_State,
24398 and then Present (Encapsulating_State (Ref_Item_Id))
24399 and then Find_Encapsulating_State
24400 (Dep_States, Ref_Item_Id) = Dep_Item_Id
24402 Record_Item (Dep_Item_Id);
24405 elsif not Has_Visible_Refinement (Dep_Item_Id)
24406 and then Ref_Item_Id = Dep_Item_Id
24408 Record_Item (Dep_Item_Id);
24413 -- An abstract state without a visible refinement matches
24416 elsif Is_Entity_Name (Ref_Item)
24417 and then Entity_Of (Ref_Item) = Dep_Item_Id
24419 Record_Item (Dep_Item_Id);
24423 -- A current instance of a concurrent type, discriminant,
24424 -- formal parameter or an object matches itself.
24426 elsif Is_Entity_Name (Ref_Item)
24427 and then Entity_Of (Ref_Item) = Dep_Item_Id
24429 Record_Item (Dep_Item_Id);
24439 procedure Record_Item (Item_Id : Entity_Id) is
24441 if No (Matched_Items) then
24442 Matched_Items := New_Elmt_List;
24445 Append_Unique_Elmt (Item_Id, Matched_Items);
24450 Clause_Matched : Boolean := False;
24451 Dummy : Boolean := False;
24452 Inputs_Match : Boolean;
24453 Next_Ref_Clause : Node_Id;
24454 Outputs_Match : Boolean;
24455 Ref_Clause : Node_Id;
24456 Ref_Input : Node_Id;
24457 Ref_Output : Node_Id;
24459 -- Start of processing for Check_Dependency_Clause
24462 -- Do not perform this check in an instance because it was already
24463 -- performed successfully in the generic template.
24465 if Is_Generic_Instance (Spec_Id) then
24469 -- Examine all refinement clauses and compare them against the
24470 -- dependence clause.
24472 Ref_Clause := First (Refinements);
24473 while Present (Ref_Clause) loop
24474 Next_Ref_Clause := Next (Ref_Clause);
24476 -- Obtain the attributes of the current refinement clause
24478 Ref_Input := Expression (Ref_Clause);
24479 Ref_Output := First (Choices (Ref_Clause));
24481 -- The current refinement clause matches the dependence clause
24482 -- when both outputs match and both inputs match. See routine
24483 -- Match_Items for all possible conformance scenarios.
24485 -- Depends Dep_Output => Dep_Input
24489 -- Refined_Depends Ref_Output => Ref_Input
24492 (Dep_Item => Dep_Input,
24493 Ref_Item => Ref_Input,
24494 Matched => Inputs_Match);
24497 (Dep_Item => Dep_Output,
24498 Ref_Item => Ref_Output,
24499 Matched => Outputs_Match);
24501 -- An In_Out state clause may be matched against a refinement with
24502 -- a null input or null output as long as the non-null side of the
24503 -- relation contains a valid constituent of the In_Out_State.
24505 if Is_In_Out_State_Clause then
24507 -- Depends => (State => State)
24508 -- Refined_Depends => (null => Constit) -- OK
24511 and then not Outputs_Match
24512 and then Nkind (Ref_Output) = N_Null
24514 Outputs_Match := True;
24517 -- Depends => (State => State)
24518 -- Refined_Depends => (Constit => null) -- OK
24520 if not Inputs_Match
24521 and then Outputs_Match
24522 and then Nkind (Ref_Input) = N_Null
24524 Inputs_Match := True;
24528 -- The current refinement clause is legally constructed following
24529 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24530 -- the pool of candidates. The seach continues because a single
24531 -- dependence clause may have multiple matching refinements.
24533 if Inputs_Match and Outputs_Match then
24534 Clause_Matched := True;
24535 Remove (Ref_Clause);
24538 Ref_Clause := Next_Ref_Clause;
24541 -- Depending on the order or composition of refinement clauses, an
24542 -- In_Out state clause may not be directly refinable.
24544 -- Refined_State => (State => (Constit_1, Constit_2))
24545 -- Depends => ((Output, State) => (Input, State))
24546 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24548 -- Matching normalized clause (State => State) fails because there is
24549 -- no direct refinement capable of satisfying this relation. Another
24550 -- similar case arises when clauses (Constit_1 => Input) and (Output
24551 -- => Constit_2) are matched first, leaving no candidates for clause
24552 -- (State => State). Both scenarios are legal as long as one of the
24553 -- previous clauses mentioned a valid constituent of State.
24555 if not Clause_Matched
24556 and then Is_In_Out_State_Clause
24557 and then Is_Already_Matched (Dep_Input)
24559 Clause_Matched := True;
24562 -- A clause where the input is an abstract state with visible null
24563 -- refinement or a 'Result attribute is implicitly matched when the
24564 -- output has already been matched in a previous clause.
24566 -- Refined_State => (State => null)
24567 -- Depends => (Output => State) -- implicitly OK
24568 -- Refined_Depends => (Output => ...)
24569 -- Depends => (...'Result => State) -- implicitly OK
24570 -- Refined_Depends => (...'Result => ...)
24572 if not Clause_Matched
24573 and then Is_Null_Refined_State (Dep_Input)
24574 and then Is_Already_Matched (Dep_Output)
24576 Clause_Matched := True;
24579 -- A clause where the output is an abstract state with visible null
24580 -- refinement is implicitly matched when the input has already been
24581 -- matched in a previous clause.
24583 -- Refined_State => (State => null)
24584 -- Depends => (State => Input) -- implicitly OK
24585 -- Refined_Depends => (... => Input)
24587 if not Clause_Matched
24588 and then Is_Null_Refined_State (Dep_Output)
24589 and then Is_Already_Matched (Dep_Input)
24591 Clause_Matched := True;
24594 -- At this point either all refinement clauses have been examined or
24595 -- pragma Refined_Depends contains a solitary null. Only an abstract
24596 -- state with null refinement can possibly match these cases.
24598 -- Refined_State => (State => null)
24599 -- Depends => (State => null)
24600 -- Refined_Depends => null -- OK
24602 if not Clause_Matched then
24604 (Dep_Item => Dep_Input,
24606 Matched => Inputs_Match);
24609 (Dep_Item => Dep_Output,
24611 Matched => Outputs_Match);
24613 Clause_Matched := Inputs_Match and Outputs_Match;
24616 -- If the contents of Refined_Depends are legal, then the current
24617 -- dependence clause should be satisfied either by an explicit match
24618 -- or by one of the special cases.
24620 if not Clause_Matched then
24622 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24623 & "matching refinement in body"), Dep_Clause, Spec_Id);
24625 end Check_Dependency_Clause;
24627 -------------------------
24628 -- Check_Output_States --
24629 -------------------------
24631 procedure Check_Output_States
24632 (Spec_Id : Entity_Id;
24633 Spec_Inputs : Elist_Id;
24634 Spec_Outputs : Elist_Id;
24635 Body_Inputs : Elist_Id;
24636 Body_Outputs : Elist_Id)
24638 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24639 -- Determine whether all constituents of state State_Id with full
24640 -- visible refinement are used as outputs in pragma Refined_Depends.
24641 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24643 -----------------------------
24644 -- Check_Constituent_Usage --
24645 -----------------------------
24647 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24648 Constits : constant Elist_Id :=
24649 Partial_Refinement_Constituents (State_Id);
24650 Constit_Elmt : Elmt_Id;
24651 Constit_Id : Entity_Id;
24652 Only_Partial : constant Boolean :=
24653 not Has_Visible_Refinement (State_Id);
24654 Posted : Boolean := False;
24657 if Present (Constits) then
24658 Constit_Elmt := First_Elmt (Constits);
24659 while Present (Constit_Elmt) loop
24660 Constit_Id := Node (Constit_Elmt);
24662 -- Issue an error when a constituent of State_Id is used,
24663 -- and State_Id has only partial visible refinement
24664 -- (SPARK RM 7.2.4(3d)).
24666 if Only_Partial then
24667 if (Present (Body_Inputs)
24668 and then Appears_In (Body_Inputs, Constit_Id))
24670 (Present (Body_Outputs)
24671 and then Appears_In (Body_Outputs, Constit_Id))
24673 Error_Msg_Name_1 := Chars (State_Id);
24675 ("constituent & of state % cannot be used in "
24676 & "dependence refinement", N, Constit_Id);
24677 Error_Msg_Name_1 := Chars (State_Id);
24678 SPARK_Msg_N ("\use state % instead", N);
24681 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24683 elsif Present (Body_Inputs)
24684 and then Appears_In (Body_Inputs, Constit_Id)
24686 Error_Msg_Name_1 := Chars (State_Id);
24688 ("constituent & of state % must act as output in "
24689 & "dependence refinement", N, Constit_Id);
24691 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24693 elsif No (Body_Outputs)
24694 or else not Appears_In (Body_Outputs, Constit_Id)
24699 ("output state & must be replaced by all its "
24700 & "constituents in dependence refinement",
24705 ("\constituent & is missing in output list",
24709 Next_Elmt (Constit_Elmt);
24712 end Check_Constituent_Usage;
24717 Item_Elmt : Elmt_Id;
24718 Item_Id : Entity_Id;
24720 -- Start of processing for Check_Output_States
24723 -- Do not perform this check in an instance because it was already
24724 -- performed successfully in the generic template.
24726 if Is_Generic_Instance (Spec_Id) then
24729 -- Inspect the outputs of pragma Depends looking for a state with a
24730 -- visible refinement.
24732 elsif Present (Spec_Outputs) then
24733 Item_Elmt := First_Elmt (Spec_Outputs);
24734 while Present (Item_Elmt) loop
24735 Item := Node (Item_Elmt);
24737 -- Deal with the mixed nature of the input and output lists
24739 if Nkind (Item) = N_Defining_Identifier then
24742 Item_Id := Available_View (Entity_Of (Item));
24745 if Ekind (Item_Id) = E_Abstract_State then
24747 -- The state acts as an input-output, skip it
24749 if Present (Spec_Inputs)
24750 and then Appears_In (Spec_Inputs, Item_Id)
24754 -- Ensure that all of the constituents are utilized as
24755 -- outputs in pragma Refined_Depends.
24757 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24758 Check_Constituent_Usage (Item_Id);
24762 Next_Elmt (Item_Elmt);
24765 end Check_Output_States;
24767 --------------------
24768 -- Collect_States --
24769 --------------------
24771 function Collect_States (Clauses : List_Id) return Elist_Id is
24772 procedure Collect_State
24774 States : in out Elist_Id);
24775 -- Add the entity of Item to list States when it denotes to a state
24777 -------------------
24778 -- Collect_State --
24779 -------------------
24781 procedure Collect_State
24783 States : in out Elist_Id)
24788 if Is_Entity_Name (Item) then
24789 Id := Entity_Of (Item);
24791 if Ekind (Id) = E_Abstract_State then
24792 if No (States) then
24793 States := New_Elmt_List;
24796 Append_Unique_Elmt (Id, States);
24806 States : Elist_Id := No_Elist;
24808 -- Start of processing for Collect_States
24811 Clause := First (Clauses);
24812 while Present (Clause) loop
24813 Input := Expression (Clause);
24814 Output := First (Choices (Clause));
24816 Collect_State (Input, States);
24817 Collect_State (Output, States);
24823 end Collect_States;
24825 -----------------------
24826 -- Normalize_Clauses --
24827 -----------------------
24829 procedure Normalize_Clauses (Clauses : List_Id) is
24830 procedure Normalize_Inputs (Clause : Node_Id);
24831 -- Normalize clause Clause by creating multiple clauses for each
24832 -- input item of Clause. It is assumed that Clause has exactly one
24833 -- output. The transformation is as follows:
24835 -- Output => (Input_1, Input_2) -- original
24837 -- Output => Input_1 -- normalizations
24838 -- Output => Input_2
24840 procedure Normalize_Outputs (Clause : Node_Id);
24841 -- Normalize clause Clause by creating multiple clause for each
24842 -- output item of Clause. The transformation is as follows:
24844 -- (Output_1, Output_2) => Input -- original
24846 -- Output_1 => Input -- normalization
24847 -- Output_2 => Input
24849 ----------------------
24850 -- Normalize_Inputs --
24851 ----------------------
24853 procedure Normalize_Inputs (Clause : Node_Id) is
24854 Inputs : constant Node_Id := Expression (Clause);
24855 Loc : constant Source_Ptr := Sloc (Clause);
24856 Output : constant List_Id := Choices (Clause);
24857 Last_Input : Node_Id;
24859 New_Clause : Node_Id;
24860 Next_Input : Node_Id;
24863 -- Normalization is performed only when the original clause has
24864 -- more than one input. Multiple inputs appear as an aggregate.
24866 if Nkind (Inputs) = N_Aggregate then
24867 Last_Input := Last (Expressions (Inputs));
24869 -- Create a new clause for each input
24871 Input := First (Expressions (Inputs));
24872 while Present (Input) loop
24873 Next_Input := Next (Input);
24875 -- Unhook the current input from the original input list
24876 -- because it will be relocated to a new clause.
24880 -- Special processing for the last input. At this point the
24881 -- original aggregate has been stripped down to one element.
24882 -- Replace the aggregate by the element itself.
24884 if Input = Last_Input then
24885 Rewrite (Inputs, Input);
24887 -- Generate a clause of the form:
24892 Make_Component_Association (Loc,
24893 Choices => New_Copy_List_Tree (Output),
24894 Expression => Input);
24896 -- The new clause contains replicated content that has
24897 -- already been analyzed, mark the clause as analyzed.
24899 Set_Analyzed (New_Clause);
24900 Insert_After (Clause, New_Clause);
24903 Input := Next_Input;
24906 end Normalize_Inputs;
24908 -----------------------
24909 -- Normalize_Outputs --
24910 -----------------------
24912 procedure Normalize_Outputs (Clause : Node_Id) is
24913 Inputs : constant Node_Id := Expression (Clause);
24914 Loc : constant Source_Ptr := Sloc (Clause);
24915 Outputs : constant Node_Id := First (Choices (Clause));
24916 Last_Output : Node_Id;
24917 New_Clause : Node_Id;
24918 Next_Output : Node_Id;
24922 -- Multiple outputs appear as an aggregate. Nothing to do when
24923 -- the clause has exactly one output.
24925 if Nkind (Outputs) = N_Aggregate then
24926 Last_Output := Last (Expressions (Outputs));
24928 -- Create a clause for each output. Note that each time a new
24929 -- clause is created, the original output list slowly shrinks
24930 -- until there is one item left.
24932 Output := First (Expressions (Outputs));
24933 while Present (Output) loop
24934 Next_Output := Next (Output);
24936 -- Unhook the output from the original output list as it
24937 -- will be relocated to a new clause.
24941 -- Special processing for the last output. At this point
24942 -- the original aggregate has been stripped down to one
24943 -- element. Replace the aggregate by the element itself.
24945 if Output = Last_Output then
24946 Rewrite (Outputs, Output);
24949 -- Generate a clause of the form:
24950 -- (Output => Inputs)
24953 Make_Component_Association (Loc,
24954 Choices => New_List (Output),
24955 Expression => New_Copy_Tree (Inputs));
24957 -- The new clause contains replicated content that has
24958 -- already been analyzed. There is not need to reanalyze
24961 Set_Analyzed (New_Clause);
24962 Insert_After (Clause, New_Clause);
24965 Output := Next_Output;
24968 end Normalize_Outputs;
24974 -- Start of processing for Normalize_Clauses
24977 Clause := First (Clauses);
24978 while Present (Clause) loop
24979 Normalize_Outputs (Clause);
24983 Clause := First (Clauses);
24984 while Present (Clause) loop
24985 Normalize_Inputs (Clause);
24988 end Normalize_Clauses;
24990 --------------------------
24991 -- Remove_Extra_Clauses --
24992 --------------------------
24994 procedure Remove_Extra_Clauses
24995 (Clauses : List_Id;
24996 Matched_Items : Elist_Id)
25000 Input_Id : Entity_Id;
25001 Next_Clause : Node_Id;
25003 State_Id : Entity_Id;
25006 Clause := First (Clauses);
25007 while Present (Clause) loop
25008 Next_Clause := Next (Clause);
25010 Input := Expression (Clause);
25011 Output := First (Choices (Clause));
25013 -- Recognize a clause of the form
25017 -- where Input is a constituent of a state which was already
25018 -- successfully matched. This clause must be removed because it
25019 -- simply indicates that some of the constituents of the state
25022 -- Refined_State => (State => (Constit_1, Constit_2))
25023 -- Depends => (Output => State)
25024 -- Refined_Depends => ((Output => Constit_1), -- State matched
25025 -- (null => Constit_2)) -- OK
25027 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
25029 -- Handle abstract views generated for limited with clauses
25031 Input_Id := Available_View (Entity_Of (Input));
25033 -- The input must be a constituent of a state
25035 if Ekind_In (Input_Id, E_Abstract_State,
25038 and then Present (Encapsulating_State (Input_Id))
25040 State_Id := Encapsulating_State (Input_Id);
25042 -- The state must have a non-null visible refinement and be
25043 -- matched in a previous clause.
25045 if Has_Non_Null_Visible_Refinement (State_Id)
25046 and then Contains (Matched_Items, State_Id)
25052 -- Recognize a clause of the form
25056 -- where Output is an arbitrary item. This clause must be removed
25057 -- because a null input legitimately matches anything.
25059 elsif Nkind (Input) = N_Null then
25063 Clause := Next_Clause;
25065 end Remove_Extra_Clauses;
25067 --------------------------
25068 -- Report_Extra_Clauses --
25069 --------------------------
25071 procedure Report_Extra_Clauses
25072 (Spec_Id : Entity_Id;
25078 -- Do not perform this check in an instance because it was already
25079 -- performed successfully in the generic template.
25081 if Is_Generic_Instance (Spec_Id) then
25084 elsif Present (Clauses) then
25085 Clause := First (Clauses);
25086 while Present (Clause) loop
25088 ("unmatched or extra clause in dependence refinement",
25094 end Report_Extra_Clauses;
25098 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25099 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25100 Errors : constant Nat := Serious_Errors_Detected;
25107 Body_Inputs : Elist_Id := No_Elist;
25108 Body_Outputs : Elist_Id := No_Elist;
25109 -- The inputs and outputs of the subprogram body synthesized from pragma
25110 -- Refined_Depends.
25112 Dependencies : List_Id := No_List;
25114 -- The corresponding Depends pragma along with its clauses
25116 Matched_Items : Elist_Id := No_Elist;
25117 -- A list containing the entities of all successfully matched items
25118 -- found in pragma Depends.
25120 Refinements : List_Id := No_List;
25121 -- The clauses of pragma Refined_Depends
25123 Spec_Id : Entity_Id;
25124 -- The entity of the subprogram subject to pragma Refined_Depends
25126 Spec_Inputs : Elist_Id := No_Elist;
25127 Spec_Outputs : Elist_Id := No_Elist;
25128 -- The inputs and outputs of the subprogram spec synthesized from pragma
25131 States : Elist_Id := No_Elist;
25132 -- A list containing the entities of all states whose constituents
25133 -- appear in pragma Depends.
25135 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25138 -- Do not analyze the pragma multiple times
25140 if Is_Analyzed_Pragma (N) then
25144 Spec_Id := Unique_Defining_Entity (Body_Decl);
25146 -- Use the anonymous object as the proper spec when Refined_Depends
25147 -- applies to the body of a single task type. The object carries the
25148 -- proper Chars as well as all non-refined versions of pragmas.
25150 if Is_Single_Concurrent_Type (Spec_Id) then
25151 Spec_Id := Anonymous_Object (Spec_Id);
25154 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
25156 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25157 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25159 if No (Depends) then
25161 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25162 & "& lacks aspect or pragma Depends"), N, Spec_Id);
25166 Deps := Expression (Get_Argument (Depends, Spec_Id));
25168 -- A null dependency relation renders the refinement useless because it
25169 -- cannot possibly mention abstract states with visible refinement. Note
25170 -- that the inverse is not true as states may be refined to null
25171 -- (SPARK RM 7.2.5(2)).
25173 if Nkind (Deps) = N_Null then
25175 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25176 & "depend on abstract state with visible refinement"), N, Spec_Id);
25180 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25181 -- This ensures that the categorization of all refined dependency items
25182 -- is consistent with their role.
25184 Analyze_Depends_In_Decl_Part (N);
25186 -- Do not match dependencies against refinements if Refined_Depends is
25187 -- illegal to avoid emitting misleading error.
25189 if Serious_Errors_Detected = Errors then
25191 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25192 -- the inputs and outputs of the subprogram spec and body to verify
25193 -- the use of states with visible refinement and their constituents.
25195 if No (Get_Pragma (Spec_Id, Pragma_Global))
25196 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
25198 Collect_Subprogram_Inputs_Outputs
25199 (Subp_Id => Spec_Id,
25200 Synthesize => True,
25201 Subp_Inputs => Spec_Inputs,
25202 Subp_Outputs => Spec_Outputs,
25203 Global_Seen => Dummy);
25205 Collect_Subprogram_Inputs_Outputs
25206 (Subp_Id => Body_Id,
25207 Synthesize => True,
25208 Subp_Inputs => Body_Inputs,
25209 Subp_Outputs => Body_Outputs,
25210 Global_Seen => Dummy);
25212 -- For an output state with a visible refinement, ensure that all
25213 -- constituents appear as outputs in the dependency refinement.
25215 Check_Output_States
25216 (Spec_Id => Spec_Id,
25217 Spec_Inputs => Spec_Inputs,
25218 Spec_Outputs => Spec_Outputs,
25219 Body_Inputs => Body_Inputs,
25220 Body_Outputs => Body_Outputs);
25223 -- Matching is disabled in ASIS because clauses are not normalized as
25224 -- this is a tree altering activity similar to expansion.
25230 -- Multiple dependency clauses appear as component associations of an
25231 -- aggregate. Note that the clauses are copied because the algorithm
25232 -- modifies them and this should not be visible in Depends.
25234 pragma Assert (Nkind (Deps) = N_Aggregate);
25235 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
25236 Normalize_Clauses (Dependencies);
25238 -- Gather all states which appear in Depends
25240 States := Collect_States (Dependencies);
25242 Refs := Expression (Get_Argument (N, Spec_Id));
25244 if Nkind (Refs) = N_Null then
25245 Refinements := No_List;
25247 -- Multiple dependency clauses appear as component associations of an
25248 -- aggregate. Note that the clauses are copied because the algorithm
25249 -- modifies them and this should not be visible in Refined_Depends.
25251 else pragma Assert (Nkind (Refs) = N_Aggregate);
25252 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
25253 Normalize_Clauses (Refinements);
25256 -- At this point the clauses of pragmas Depends and Refined_Depends
25257 -- have been normalized into simple dependencies between one output
25258 -- and one input. Examine all clauses of pragma Depends looking for
25259 -- matching clauses in pragma Refined_Depends.
25261 Clause := First (Dependencies);
25262 while Present (Clause) loop
25263 Check_Dependency_Clause
25264 (Spec_Id => Spec_Id,
25265 Dep_Clause => Clause,
25266 Dep_States => States,
25267 Refinements => Refinements,
25268 Matched_Items => Matched_Items);
25273 -- Pragma Refined_Depends may contain multiple clarification clauses
25274 -- which indicate that certain constituents do not influence the data
25275 -- flow in any way. Such clauses must be removed as long as the state
25276 -- has been matched, otherwise they will be incorrectly flagged as
25279 -- Refined_State => (State => (Constit_1, Constit_2))
25280 -- Depends => (Output => State)
25281 -- Refined_Depends => ((Output => Constit_1), -- State matched
25282 -- (null => Constit_2)) -- must be removed
25284 Remove_Extra_Clauses (Refinements, Matched_Items);
25286 if Serious_Errors_Detected = Errors then
25287 Report_Extra_Clauses (Spec_Id, Refinements);
25292 Set_Is_Analyzed_Pragma (N);
25293 end Analyze_Refined_Depends_In_Decl_Part;
25295 -----------------------------------------
25296 -- Analyze_Refined_Global_In_Decl_Part --
25297 -----------------------------------------
25299 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
25301 -- The corresponding Global pragma
25303 Has_In_State : Boolean := False;
25304 Has_In_Out_State : Boolean := False;
25305 Has_Out_State : Boolean := False;
25306 Has_Proof_In_State : Boolean := False;
25307 -- These flags are set when the corresponding Global pragma has a state
25308 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25311 Has_Null_State : Boolean := False;
25312 -- This flag is set when the corresponding Global pragma has at least
25313 -- one state with a null refinement.
25315 In_Constits : Elist_Id := No_Elist;
25316 In_Out_Constits : Elist_Id := No_Elist;
25317 Out_Constits : Elist_Id := No_Elist;
25318 Proof_In_Constits : Elist_Id := No_Elist;
25319 -- These lists contain the entities of all Input, In_Out, Output and
25320 -- Proof_In constituents that appear in Refined_Global and participate
25321 -- in state refinement.
25323 In_Items : Elist_Id := No_Elist;
25324 In_Out_Items : Elist_Id := No_Elist;
25325 Out_Items : Elist_Id := No_Elist;
25326 Proof_In_Items : Elist_Id := No_Elist;
25327 -- These lists contain the entities of all Input, In_Out, Output and
25328 -- Proof_In items defined in the corresponding Global pragma.
25330 Repeat_Items : Elist_Id := No_Elist;
25331 -- A list of all global items without full visible refinement found
25332 -- in pragma Global. These states should be repeated in the global
25333 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25334 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25336 Spec_Id : Entity_Id;
25337 -- The entity of the subprogram subject to pragma Refined_Global
25339 States : Elist_Id := No_Elist;
25340 -- A list of all states with full or partial visible refinement found in
25343 procedure Check_In_Out_States;
25344 -- Determine whether the corresponding Global pragma mentions In_Out
25345 -- states with visible refinement and if so, ensure that one of the
25346 -- following completions apply to the constituents of the state:
25347 -- 1) there is at least one constituent of mode In_Out
25348 -- 2) there is at least one Input and one Output constituent
25349 -- 3) not all constituents are present and one of them is of mode
25351 -- This routine may remove elements from In_Constits, In_Out_Constits,
25352 -- Out_Constits and Proof_In_Constits.
25354 procedure Check_Input_States;
25355 -- Determine whether the corresponding Global pragma mentions Input
25356 -- states with visible refinement and if so, ensure that at least one of
25357 -- its constituents appears as an Input item in Refined_Global.
25358 -- This routine may remove elements from In_Constits, In_Out_Constits,
25359 -- Out_Constits and Proof_In_Constits.
25361 procedure Check_Output_States;
25362 -- Determine whether the corresponding Global pragma mentions Output
25363 -- states with visible refinement and if so, ensure that all of its
25364 -- constituents appear as Output items in Refined_Global.
25365 -- This routine may remove elements from In_Constits, In_Out_Constits,
25366 -- Out_Constits and Proof_In_Constits.
25368 procedure Check_Proof_In_States;
25369 -- Determine whether the corresponding Global pragma mentions Proof_In
25370 -- states with visible refinement and if so, ensure that at least one of
25371 -- its constituents appears as a Proof_In item in Refined_Global.
25372 -- This routine may remove elements from In_Constits, In_Out_Constits,
25373 -- Out_Constits and Proof_In_Constits.
25375 procedure Check_Refined_Global_List
25377 Global_Mode : Name_Id := Name_Input);
25378 -- Verify the legality of a single global list declaration. Global_Mode
25379 -- denotes the current mode in effect.
25381 procedure Collect_Global_Items
25383 Mode : Name_Id := Name_Input);
25384 -- Gather all Input, In_Out, Output and Proof_In items from node List
25385 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25386 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25387 -- and Has_Proof_In_State are set when there is at least one abstract
25388 -- state with full or partial visible refinement available in the
25389 -- corresponding mode. Flag Has_Null_State is set when at least state
25390 -- has a null refinement. Mode denotes the current global mode in
25393 function Present_Then_Remove
25395 Item : Entity_Id) return Boolean;
25396 -- Search List for a particular entity Item. If Item has been found,
25397 -- remove it from List. This routine is used to strip lists In_Constits,
25398 -- In_Out_Constits and Out_Constits of valid constituents.
25400 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
25401 -- Same as function Present_Then_Remove, but do not report the presence
25402 -- of Item in List.
25404 procedure Report_Extra_Constituents;
25405 -- Emit an error for each constituent found in lists In_Constits,
25406 -- In_Out_Constits and Out_Constits.
25408 procedure Report_Missing_Items;
25409 -- Emit an error for each global item not repeated found in list
25412 -------------------------
25413 -- Check_In_Out_States --
25414 -------------------------
25416 procedure Check_In_Out_States is
25417 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25418 -- Determine whether one of the following coverage scenarios is in
25420 -- 1) there is at least one constituent of mode In_Out or Output
25421 -- 2) there is at least one pair of constituents with modes Input
25422 -- and Output, or Proof_In and Output.
25423 -- 3) there is at least one constituent of mode Output and not all
25424 -- constituents are present.
25425 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25427 -----------------------------
25428 -- Check_Constituent_Usage --
25429 -----------------------------
25431 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25432 Constits : constant Elist_Id :=
25433 Partial_Refinement_Constituents (State_Id);
25434 Constit_Elmt : Elmt_Id;
25435 Constit_Id : Entity_Id;
25436 Has_Missing : Boolean := False;
25437 In_Out_Seen : Boolean := False;
25438 Input_Seen : Boolean := False;
25439 Output_Seen : Boolean := False;
25440 Proof_In_Seen : Boolean := False;
25443 -- Process all the constituents of the state and note their modes
25444 -- within the global refinement.
25446 if Present (Constits) then
25447 Constit_Elmt := First_Elmt (Constits);
25448 while Present (Constit_Elmt) loop
25449 Constit_Id := Node (Constit_Elmt);
25451 if Present_Then_Remove (In_Constits, Constit_Id) then
25452 Input_Seen := True;
25454 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
25455 In_Out_Seen := True;
25457 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25458 Output_Seen := True;
25460 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25462 Proof_In_Seen := True;
25465 Has_Missing := True;
25468 Next_Elmt (Constit_Elmt);
25472 -- An In_Out constituent is a valid completion
25474 if In_Out_Seen then
25477 -- A pair of one Input/Proof_In and one Output constituent is a
25478 -- valid completion.
25480 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
25483 elsif Output_Seen then
25485 -- A single Output constituent is a valid completion only when
25486 -- some of the other constituents are missing.
25488 if Has_Missing then
25491 -- Otherwise all constituents are of mode Output
25495 ("global refinement of state & must include at least one "
25496 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25500 -- The state lacks a completion. When full refinement is visible,
25501 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25502 -- refinement is visible, emit an error if the abstract state
25503 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25504 -- both are utilized, Check_State_And_Constituent_Use. will issue
25507 elsif not Input_Seen
25508 and then not In_Out_Seen
25509 and then not Output_Seen
25510 and then not Proof_In_Seen
25512 if Has_Visible_Refinement (State_Id)
25513 or else Contains (Repeat_Items, State_Id)
25516 ("missing global refinement of state &", N, State_Id);
25519 -- Otherwise the state has a malformed completion where at least
25520 -- one of the constituents has a different mode.
25524 ("global refinement of state & redefines the mode of its "
25525 & "constituents", N, State_Id);
25527 end Check_Constituent_Usage;
25531 Item_Elmt : Elmt_Id;
25532 Item_Id : Entity_Id;
25534 -- Start of processing for Check_In_Out_States
25537 -- Do not perform this check in an instance because it was already
25538 -- performed successfully in the generic template.
25540 if Is_Generic_Instance (Spec_Id) then
25543 -- Inspect the In_Out items of the corresponding Global pragma
25544 -- looking for a state with a visible refinement.
25546 elsif Has_In_Out_State and then Present (In_Out_Items) then
25547 Item_Elmt := First_Elmt (In_Out_Items);
25548 while Present (Item_Elmt) loop
25549 Item_Id := Node (Item_Elmt);
25551 -- Ensure that one of the three coverage variants is satisfied
25553 if Ekind (Item_Id) = E_Abstract_State
25554 and then Has_Non_Null_Visible_Refinement (Item_Id)
25556 Check_Constituent_Usage (Item_Id);
25559 Next_Elmt (Item_Elmt);
25562 end Check_In_Out_States;
25564 ------------------------
25565 -- Check_Input_States --
25566 ------------------------
25568 procedure Check_Input_States is
25569 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25570 -- Determine whether at least one constituent of state State_Id with
25571 -- full or partial visible refinement is used and has mode Input.
25572 -- Ensure that the remaining constituents do not have In_Out or
25573 -- Output modes. Emit an error if this is not the case
25574 -- (SPARK RM 7.2.4(5)).
25576 -----------------------------
25577 -- Check_Constituent_Usage --
25578 -----------------------------
25580 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25581 Constits : constant Elist_Id :=
25582 Partial_Refinement_Constituents (State_Id);
25583 Constit_Elmt : Elmt_Id;
25584 Constit_Id : Entity_Id;
25585 In_Seen : Boolean := False;
25588 if Present (Constits) then
25589 Constit_Elmt := First_Elmt (Constits);
25590 while Present (Constit_Elmt) loop
25591 Constit_Id := Node (Constit_Elmt);
25593 -- At least one of the constituents appears as an Input
25595 if Present_Then_Remove (In_Constits, Constit_Id) then
25598 -- A Proof_In constituent can refine an Input state as long
25599 -- as there is at least one Input constituent present.
25601 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
25605 -- The constituent appears in the global refinement, but has
25606 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25608 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
25609 or else Present_Then_Remove (Out_Constits, Constit_Id)
25611 Error_Msg_Name_1 := Chars (State_Id);
25613 ("constituent & of state % must have mode `Input` in "
25614 & "global refinement", N, Constit_Id);
25617 Next_Elmt (Constit_Elmt);
25621 -- Not one of the constituents appeared as Input. Always emit an
25622 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25623 -- When only partial refinement is visible, emit an error if the
25624 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25625 -- the case where both are utilized, an error will be issued in
25626 -- Check_State_And_Constituent_Use.
25629 and then (Has_Visible_Refinement (State_Id)
25630 or else Contains (Repeat_Items, State_Id))
25633 ("global refinement of state & must include at least one "
25634 & "constituent of mode `Input`", N, State_Id);
25636 end Check_Constituent_Usage;
25640 Item_Elmt : Elmt_Id;
25641 Item_Id : Entity_Id;
25643 -- Start of processing for Check_Input_States
25646 -- Do not perform this check in an instance because it was already
25647 -- performed successfully in the generic template.
25649 if Is_Generic_Instance (Spec_Id) then
25652 -- Inspect the Input items of the corresponding Global pragma looking
25653 -- for a state with a visible refinement.
25655 elsif Has_In_State and then Present (In_Items) then
25656 Item_Elmt := First_Elmt (In_Items);
25657 while Present (Item_Elmt) loop
25658 Item_Id := Node (Item_Elmt);
25660 -- When full refinement is visible, ensure that at least one of
25661 -- the constituents is utilized and is of mode Input. When only
25662 -- partial refinement is visible, ensure that either one of
25663 -- the constituents is utilized and is of mode Input, or the
25664 -- abstract state is repeated and no constituent is utilized.
25666 if Ekind (Item_Id) = E_Abstract_State
25667 and then Has_Non_Null_Visible_Refinement (Item_Id)
25669 Check_Constituent_Usage (Item_Id);
25672 Next_Elmt (Item_Elmt);
25675 end Check_Input_States;
25677 -------------------------
25678 -- Check_Output_States --
25679 -------------------------
25681 procedure Check_Output_States is
25682 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25683 -- Determine whether all constituents of state State_Id with full
25684 -- visible refinement are used and have mode Output. Emit an error
25685 -- if this is not the case (SPARK RM 7.2.4(5)).
25687 -----------------------------
25688 -- Check_Constituent_Usage --
25689 -----------------------------
25691 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25692 Constits : constant Elist_Id :=
25693 Partial_Refinement_Constituents (State_Id);
25694 Only_Partial : constant Boolean :=
25695 not Has_Visible_Refinement (State_Id);
25696 Constit_Elmt : Elmt_Id;
25697 Constit_Id : Entity_Id;
25698 Posted : Boolean := False;
25701 if Present (Constits) then
25702 Constit_Elmt := First_Elmt (Constits);
25703 while Present (Constit_Elmt) loop
25704 Constit_Id := Node (Constit_Elmt);
25706 -- Issue an error when a constituent of State_Id is utilized
25707 -- and State_Id has only partial visible refinement
25708 -- (SPARK RM 7.2.4(3d)).
25710 if Only_Partial then
25711 if Present_Then_Remove (Out_Constits, Constit_Id)
25712 or else Present_Then_Remove (In_Constits, Constit_Id)
25714 Present_Then_Remove (In_Out_Constits, Constit_Id)
25716 Present_Then_Remove (Proof_In_Constits, Constit_Id)
25718 Error_Msg_Name_1 := Chars (State_Id);
25720 ("constituent & of state % cannot be used in global "
25721 & "refinement", N, Constit_Id);
25722 Error_Msg_Name_1 := Chars (State_Id);
25723 SPARK_Msg_N ("\use state % instead", N);
25726 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
25729 -- The constituent appears in the global refinement, but has
25730 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25732 elsif Present_Then_Remove (In_Constits, Constit_Id)
25733 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25734 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
25736 Error_Msg_Name_1 := Chars (State_Id);
25738 ("constituent & of state % must have mode `Output` in "
25739 & "global refinement", N, Constit_Id);
25741 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25747 ("`Output` state & must be replaced by all its "
25748 & "constituents in global refinement", N, State_Id);
25752 ("\constituent & is missing in output list",
25756 Next_Elmt (Constit_Elmt);
25759 end Check_Constituent_Usage;
25763 Item_Elmt : Elmt_Id;
25764 Item_Id : Entity_Id;
25766 -- Start of processing for Check_Output_States
25769 -- Do not perform this check in an instance because it was already
25770 -- performed successfully in the generic template.
25772 if Is_Generic_Instance (Spec_Id) then
25775 -- Inspect the Output items of the corresponding Global pragma
25776 -- looking for a state with a visible refinement.
25778 elsif Has_Out_State and then Present (Out_Items) then
25779 Item_Elmt := First_Elmt (Out_Items);
25780 while Present (Item_Elmt) loop
25781 Item_Id := Node (Item_Elmt);
25783 -- When full refinement is visible, ensure that all of the
25784 -- constituents are utilized and they have mode Output. When
25785 -- only partial refinement is visible, ensure that no
25786 -- constituent is utilized.
25788 if Ekind (Item_Id) = E_Abstract_State
25789 and then Has_Non_Null_Visible_Refinement (Item_Id)
25791 Check_Constituent_Usage (Item_Id);
25794 Next_Elmt (Item_Elmt);
25797 end Check_Output_States;
25799 ---------------------------
25800 -- Check_Proof_In_States --
25801 ---------------------------
25803 procedure Check_Proof_In_States is
25804 procedure Check_Constituent_Usage (State_Id : Entity_Id);
25805 -- Determine whether at least one constituent of state State_Id with
25806 -- full or partial visible refinement is used and has mode Proof_In.
25807 -- Ensure that the remaining constituents do not have Input, In_Out,
25808 -- or Output modes. Emit an error if this is not the case
25809 -- (SPARK RM 7.2.4(5)).
25811 -----------------------------
25812 -- Check_Constituent_Usage --
25813 -----------------------------
25815 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
25816 Constits : constant Elist_Id :=
25817 Partial_Refinement_Constituents (State_Id);
25818 Constit_Elmt : Elmt_Id;
25819 Constit_Id : Entity_Id;
25820 Proof_In_Seen : Boolean := False;
25823 if Present (Constits) then
25824 Constit_Elmt := First_Elmt (Constits);
25825 while Present (Constit_Elmt) loop
25826 Constit_Id := Node (Constit_Elmt);
25828 -- At least one of the constituents appears as Proof_In
25830 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
25831 Proof_In_Seen := True;
25833 -- The constituent appears in the global refinement, but has
25834 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25836 elsif Present_Then_Remove (In_Constits, Constit_Id)
25837 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
25838 or else Present_Then_Remove (Out_Constits, Constit_Id)
25840 Error_Msg_Name_1 := Chars (State_Id);
25842 ("constituent & of state % must have mode `Proof_In` "
25843 & "in global refinement", N, Constit_Id);
25846 Next_Elmt (Constit_Elmt);
25850 -- Not one of the constituents appeared as Proof_In. Always emit
25851 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25852 -- When only partial refinement is visible, emit an error if the
25853 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25854 -- the case where both are utilized, an error will be issued by
25855 -- Check_State_And_Constituent_Use.
25857 if not Proof_In_Seen
25858 and then (Has_Visible_Refinement (State_Id)
25859 or else Contains (Repeat_Items, State_Id))
25862 ("global refinement of state & must include at least one "
25863 & "constituent of mode `Proof_In`", N, State_Id);
25865 end Check_Constituent_Usage;
25869 Item_Elmt : Elmt_Id;
25870 Item_Id : Entity_Id;
25872 -- Start of processing for Check_Proof_In_States
25875 -- Do not perform this check in an instance because it was already
25876 -- performed successfully in the generic template.
25878 if Is_Generic_Instance (Spec_Id) then
25881 -- Inspect the Proof_In items of the corresponding Global pragma
25882 -- looking for a state with a visible refinement.
25884 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25885 Item_Elmt := First_Elmt (Proof_In_Items);
25886 while Present (Item_Elmt) loop
25887 Item_Id := Node (Item_Elmt);
25889 -- Ensure that at least one of the constituents is utilized
25890 -- and is of mode Proof_In. When only partial refinement is
25891 -- visible, ensure that either one of the constituents is
25892 -- utilized and is of mode Proof_In, or the abstract state
25893 -- is repeated and no constituent is utilized.
25895 if Ekind (Item_Id) = E_Abstract_State
25896 and then Has_Non_Null_Visible_Refinement (Item_Id)
25898 Check_Constituent_Usage (Item_Id);
25901 Next_Elmt (Item_Elmt);
25904 end Check_Proof_In_States;
25906 -------------------------------
25907 -- Check_Refined_Global_List --
25908 -------------------------------
25910 procedure Check_Refined_Global_List
25912 Global_Mode : Name_Id := Name_Input)
25914 procedure Check_Refined_Global_Item
25916 Global_Mode : Name_Id);
25917 -- Verify the legality of a single global item declaration. Parameter
25918 -- Global_Mode denotes the current mode in effect.
25920 -------------------------------
25921 -- Check_Refined_Global_Item --
25922 -------------------------------
25924 procedure Check_Refined_Global_Item
25926 Global_Mode : Name_Id)
25928 Item_Id : constant Entity_Id := Entity_Of (Item);
25930 procedure Inconsistent_Mode_Error (Expect : Name_Id);
25931 -- Issue a common error message for all mode mismatches. Expect
25932 -- denotes the expected mode.
25934 -----------------------------
25935 -- Inconsistent_Mode_Error --
25936 -----------------------------
25938 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
25941 ("global item & has inconsistent modes", Item, Item_Id);
25943 Error_Msg_Name_1 := Global_Mode;
25944 Error_Msg_Name_2 := Expect;
25945 SPARK_Msg_N ("\expected mode %, found mode %", Item);
25946 end Inconsistent_Mode_Error;
25950 Enc_State : Entity_Id := Empty;
25951 -- Encapsulating state for constituent, Empty otherwise
25953 -- Start of processing for Check_Refined_Global_Item
25956 if Ekind_In (Item_Id, E_Abstract_State,
25960 Enc_State := Find_Encapsulating_State (States, Item_Id);
25963 -- When the state or object acts as a constituent of another
25964 -- state with a visible refinement, collect it for the state
25965 -- completeness checks performed later on. Note that the item
25966 -- acts as a constituent only when the encapsulating state is
25967 -- present in pragma Global.
25969 if Present (Enc_State)
25970 and then (Has_Visible_Refinement (Enc_State)
25971 or else Has_Partial_Visible_Refinement (Enc_State))
25972 and then Contains (States, Enc_State)
25974 -- If the state has only partial visible refinement, remove it
25975 -- from the list of items that should be repeated from pragma
25978 if not Has_Visible_Refinement (Enc_State) then
25979 Present_Then_Remove (Repeat_Items, Enc_State);
25982 if Global_Mode = Name_Input then
25983 Append_New_Elmt (Item_Id, In_Constits);
25985 elsif Global_Mode = Name_In_Out then
25986 Append_New_Elmt (Item_Id, In_Out_Constits);
25988 elsif Global_Mode = Name_Output then
25989 Append_New_Elmt (Item_Id, Out_Constits);
25991 elsif Global_Mode = Name_Proof_In then
25992 Append_New_Elmt (Item_Id, Proof_In_Constits);
25995 -- When not a constituent, ensure that both occurrences of the
25996 -- item in pragmas Global and Refined_Global match. Also remove
25997 -- it when present from the list of items that should be repeated
25998 -- from pragma Global.
26001 Present_Then_Remove (Repeat_Items, Item_Id);
26003 if Contains (In_Items, Item_Id) then
26004 if Global_Mode /= Name_Input then
26005 Inconsistent_Mode_Error (Name_Input);
26008 elsif Contains (In_Out_Items, Item_Id) then
26009 if Global_Mode /= Name_In_Out then
26010 Inconsistent_Mode_Error (Name_In_Out);
26013 elsif Contains (Out_Items, Item_Id) then
26014 if Global_Mode /= Name_Output then
26015 Inconsistent_Mode_Error (Name_Output);
26018 elsif Contains (Proof_In_Items, Item_Id) then
26021 -- The item does not appear in the corresponding Global pragma,
26022 -- it must be an extra (SPARK RM 7.2.4(3)).
26025 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
26028 end Check_Refined_Global_Item;
26034 -- Start of processing for Check_Refined_Global_List
26037 -- Do not perform this check in an instance because it was already
26038 -- performed successfully in the generic template.
26040 if Is_Generic_Instance (Spec_Id) then
26043 elsif Nkind (List) = N_Null then
26046 -- Single global item declaration
26048 elsif Nkind_In (List, N_Expanded_Name,
26050 N_Selected_Component)
26052 Check_Refined_Global_Item (List, Global_Mode);
26054 -- Simple global list or moded global list declaration
26056 elsif Nkind (List) = N_Aggregate then
26058 -- The declaration of a simple global list appear as a collection
26061 if Present (Expressions (List)) then
26062 Item := First (Expressions (List));
26063 while Present (Item) loop
26064 Check_Refined_Global_Item (Item, Global_Mode);
26068 -- The declaration of a moded global list appears as a collection
26069 -- of component associations where individual choices denote
26072 elsif Present (Component_Associations (List)) then
26073 Item := First (Component_Associations (List));
26074 while Present (Item) loop
26075 Check_Refined_Global_List
26076 (List => Expression (Item),
26077 Global_Mode => Chars (First (Choices (Item))));
26085 raise Program_Error;
26091 raise Program_Error;
26093 end Check_Refined_Global_List;
26095 --------------------------
26096 -- Collect_Global_Items --
26097 --------------------------
26099 procedure Collect_Global_Items
26101 Mode : Name_Id := Name_Input)
26103 procedure Collect_Global_Item
26105 Item_Mode : Name_Id);
26106 -- Add a single item to the appropriate list. Item_Mode denotes the
26107 -- current mode in effect.
26109 -------------------------
26110 -- Collect_Global_Item --
26111 -------------------------
26113 procedure Collect_Global_Item
26115 Item_Mode : Name_Id)
26117 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
26118 -- The above handles abstract views of variables and states built
26119 -- for limited with clauses.
26122 -- Signal that the global list contains at least one abstract
26123 -- state with a visible refinement. Note that the refinement may
26124 -- be null in which case there are no constituents.
26126 if Ekind (Item_Id) = E_Abstract_State then
26127 if Has_Null_Visible_Refinement (Item_Id) then
26128 Has_Null_State := True;
26130 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26131 Append_New_Elmt (Item_Id, States);
26133 if Item_Mode = Name_Input then
26134 Has_In_State := True;
26135 elsif Item_Mode = Name_In_Out then
26136 Has_In_Out_State := True;
26137 elsif Item_Mode = Name_Output then
26138 Has_Out_State := True;
26139 elsif Item_Mode = Name_Proof_In then
26140 Has_Proof_In_State := True;
26145 -- Record global items without full visible refinement found in
26146 -- pragma Global which should be repeated in the global refinement
26147 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26149 if Ekind (Item_Id) /= E_Abstract_State
26150 or else not Has_Visible_Refinement (Item_Id)
26152 Append_New_Elmt (Item_Id, Repeat_Items);
26155 -- Add the item to the proper list
26157 if Item_Mode = Name_Input then
26158 Append_New_Elmt (Item_Id, In_Items);
26159 elsif Item_Mode = Name_In_Out then
26160 Append_New_Elmt (Item_Id, In_Out_Items);
26161 elsif Item_Mode = Name_Output then
26162 Append_New_Elmt (Item_Id, Out_Items);
26163 elsif Item_Mode = Name_Proof_In then
26164 Append_New_Elmt (Item_Id, Proof_In_Items);
26166 end Collect_Global_Item;
26172 -- Start of processing for Collect_Global_Items
26175 if Nkind (List) = N_Null then
26178 -- Single global item declaration
26180 elsif Nkind_In (List, N_Expanded_Name,
26182 N_Selected_Component)
26184 Collect_Global_Item (List, Mode);
26186 -- Single global list or moded global list declaration
26188 elsif Nkind (List) = N_Aggregate then
26190 -- The declaration of a simple global list appear as a collection
26193 if Present (Expressions (List)) then
26194 Item := First (Expressions (List));
26195 while Present (Item) loop
26196 Collect_Global_Item (Item, Mode);
26200 -- The declaration of a moded global list appears as a collection
26201 -- of component associations where individual choices denote mode.
26203 elsif Present (Component_Associations (List)) then
26204 Item := First (Component_Associations (List));
26205 while Present (Item) loop
26206 Collect_Global_Items
26207 (List => Expression (Item),
26208 Mode => Chars (First (Choices (Item))));
26216 raise Program_Error;
26219 -- To accommodate partial decoration of disabled SPARK features, this
26220 -- routine may be called with illegal input. If this is the case, do
26221 -- not raise Program_Error.
26226 end Collect_Global_Items;
26228 -------------------------
26229 -- Present_Then_Remove --
26230 -------------------------
26232 function Present_Then_Remove
26234 Item : Entity_Id) return Boolean
26239 if Present (List) then
26240 Elmt := First_Elmt (List);
26241 while Present (Elmt) loop
26242 if Node (Elmt) = Item then
26243 Remove_Elmt (List, Elmt);
26252 end Present_Then_Remove;
26254 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
26257 Ignore := Present_Then_Remove (List, Item);
26258 end Present_Then_Remove;
26260 -------------------------------
26261 -- Report_Extra_Constituents --
26262 -------------------------------
26264 procedure Report_Extra_Constituents is
26265 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
26266 -- Emit an error for every element of List
26268 ---------------------------------------
26269 -- Report_Extra_Constituents_In_List --
26270 ---------------------------------------
26272 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
26273 Constit_Elmt : Elmt_Id;
26276 if Present (List) then
26277 Constit_Elmt := First_Elmt (List);
26278 while Present (Constit_Elmt) loop
26279 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
26280 Next_Elmt (Constit_Elmt);
26283 end Report_Extra_Constituents_In_List;
26285 -- Start of processing for Report_Extra_Constituents
26288 -- Do not perform this check in an instance because it was already
26289 -- performed successfully in the generic template.
26291 if Is_Generic_Instance (Spec_Id) then
26295 Report_Extra_Constituents_In_List (In_Constits);
26296 Report_Extra_Constituents_In_List (In_Out_Constits);
26297 Report_Extra_Constituents_In_List (Out_Constits);
26298 Report_Extra_Constituents_In_List (Proof_In_Constits);
26300 end Report_Extra_Constituents;
26302 --------------------------
26303 -- Report_Missing_Items --
26304 --------------------------
26306 procedure Report_Missing_Items is
26307 Item_Elmt : Elmt_Id;
26308 Item_Id : Entity_Id;
26311 -- Do not perform this check in an instance because it was already
26312 -- performed successfully in the generic template.
26314 if Is_Generic_Instance (Spec_Id) then
26318 if Present (Repeat_Items) then
26319 Item_Elmt := First_Elmt (Repeat_Items);
26320 while Present (Item_Elmt) loop
26321 Item_Id := Node (Item_Elmt);
26322 SPARK_Msg_NE ("missing global item &", N, Item_Id);
26323 Next_Elmt (Item_Elmt);
26327 end Report_Missing_Items;
26331 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26332 Errors : constant Nat := Serious_Errors_Detected;
26334 No_Constit : Boolean;
26336 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26339 -- Do not analyze the pragma multiple times
26341 if Is_Analyzed_Pragma (N) then
26345 Spec_Id := Unique_Defining_Entity (Body_Decl);
26347 -- Use the anonymous object as the proper spec when Refined_Global
26348 -- applies to the body of a single task type. The object carries the
26349 -- proper Chars as well as all non-refined versions of pragmas.
26351 if Is_Single_Concurrent_Type (Spec_Id) then
26352 Spec_Id := Anonymous_Object (Spec_Id);
26355 Global := Get_Pragma (Spec_Id, Pragma_Global);
26356 Items := Expression (Get_Argument (N, Spec_Id));
26358 -- The subprogram declaration lacks pragma Global. This renders
26359 -- Refined_Global useless as there is nothing to refine.
26361 if No (Global) then
26363 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26364 & "& lacks aspect or pragma Global"), N, Spec_Id);
26368 -- Extract all relevant items from the corresponding Global pragma
26370 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
26372 -- Package and subprogram bodies are instantiated individually in
26373 -- a separate compiler pass. Due to this mode of instantiation, the
26374 -- refinement of a state may no longer be visible when a subprogram
26375 -- body contract is instantiated. Since the generic template is legal,
26376 -- do not perform this check in the instance to circumvent this oddity.
26378 if Is_Generic_Instance (Spec_Id) then
26381 -- Non-instance case
26384 -- The corresponding Global pragma must mention at least one
26385 -- state with a visible refinement at the point Refined_Global
26386 -- is processed. States with null refinements need Refined_Global
26387 -- pragma (SPARK RM 7.2.4(2)).
26389 if not Has_In_State
26390 and then not Has_In_Out_State
26391 and then not Has_Out_State
26392 and then not Has_Proof_In_State
26393 and then not Has_Null_State
26396 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26397 & "depend on abstract state with visible refinement"),
26401 -- The global refinement of inputs and outputs cannot be null when
26402 -- the corresponding Global pragma contains at least one item except
26403 -- in the case where we have states with null refinements.
26405 elsif Nkind (Items) = N_Null
26407 (Present (In_Items)
26408 or else Present (In_Out_Items)
26409 or else Present (Out_Items)
26410 or else Present (Proof_In_Items))
26411 and then not Has_Null_State
26414 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
26415 & "global items"), N, Spec_Id);
26420 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26421 -- This ensures that the categorization of all refined global items is
26422 -- consistent with their role.
26424 Analyze_Global_In_Decl_Part (N);
26426 -- Perform all refinement checks with respect to completeness and mode
26429 if Serious_Errors_Detected = Errors then
26430 Check_Refined_Global_List (Items);
26433 -- Store the information that no constituent is used in the global
26434 -- refinement, prior to calling checking procedures which remove items
26435 -- from the list of constituents.
26439 and then No (In_Out_Constits)
26440 and then No (Out_Constits)
26441 and then No (Proof_In_Constits);
26443 -- For Input states with visible refinement, at least one constituent
26444 -- must be used as an Input in the global refinement.
26446 if Serious_Errors_Detected = Errors then
26447 Check_Input_States;
26450 -- Verify all possible completion variants for In_Out states with
26451 -- visible refinement.
26453 if Serious_Errors_Detected = Errors then
26454 Check_In_Out_States;
26457 -- For Output states with visible refinement, all constituents must be
26458 -- used as Outputs in the global refinement.
26460 if Serious_Errors_Detected = Errors then
26461 Check_Output_States;
26464 -- For Proof_In states with visible refinement, at least one constituent
26465 -- must be used as Proof_In in the global refinement.
26467 if Serious_Errors_Detected = Errors then
26468 Check_Proof_In_States;
26471 -- Emit errors for all constituents that belong to other states with
26472 -- visible refinement that do not appear in Global.
26474 if Serious_Errors_Detected = Errors then
26475 Report_Extra_Constituents;
26478 -- Emit errors for all items in Global that are not repeated in the
26479 -- global refinement and for which there is no full visible refinement
26480 -- and, in the case of states with partial visible refinement, no
26481 -- constituent is mentioned in the global refinement.
26483 if Serious_Errors_Detected = Errors then
26484 Report_Missing_Items;
26487 -- Emit an error if no constituent is used in the global refinement
26488 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26489 -- one may be issued by the checking procedures. Do not perform this
26490 -- check in an instance because it was already performed successfully
26491 -- in the generic template.
26493 if Serious_Errors_Detected = Errors
26494 and then not Is_Generic_Instance (Spec_Id)
26495 and then not Has_Null_State
26496 and then No_Constit
26498 SPARK_Msg_N ("missing refinement", N);
26502 Set_Is_Analyzed_Pragma (N);
26503 end Analyze_Refined_Global_In_Decl_Part;
26505 ----------------------------------------
26506 -- Analyze_Refined_State_In_Decl_Part --
26507 ----------------------------------------
26509 procedure Analyze_Refined_State_In_Decl_Part
26511 Freeze_Id : Entity_Id := Empty)
26513 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
26514 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26515 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
26517 Available_States : Elist_Id := No_Elist;
26518 -- A list of all abstract states defined in the package declaration that
26519 -- are available for refinement. The list is used to report unrefined
26522 Body_States : Elist_Id := No_Elist;
26523 -- A list of all hidden states that appear in the body of the related
26524 -- package. The list is used to report unused hidden states.
26526 Constituents_Seen : Elist_Id := No_Elist;
26527 -- A list that contains all constituents processed so far. The list is
26528 -- used to detect multiple uses of the same constituent.
26530 Freeze_Posted : Boolean := False;
26531 -- A flag that controls the output of a freezing-related error (see use
26534 Refined_States_Seen : Elist_Id := No_Elist;
26535 -- A list that contains all refined states processed so far. The list is
26536 -- used to detect duplicate refinements.
26538 procedure Analyze_Refinement_Clause (Clause : Node_Id);
26539 -- Perform full analysis of a single refinement clause
26541 procedure Report_Unrefined_States (States : Elist_Id);
26542 -- Emit errors for all unrefined abstract states found in list States
26544 -------------------------------
26545 -- Analyze_Refinement_Clause --
26546 -------------------------------
26548 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
26549 AR_Constit : Entity_Id := Empty;
26550 AW_Constit : Entity_Id := Empty;
26551 ER_Constit : Entity_Id := Empty;
26552 EW_Constit : Entity_Id := Empty;
26553 -- The entities of external constituents that contain one of the
26554 -- following enabled properties: Async_Readers, Async_Writers,
26555 -- Effective_Reads and Effective_Writes.
26557 External_Constit_Seen : Boolean := False;
26558 -- Flag used to mark when at least one external constituent is part
26559 -- of the state refinement.
26561 Non_Null_Seen : Boolean := False;
26562 Null_Seen : Boolean := False;
26563 -- Flags used to detect multiple uses of null in a single clause or a
26564 -- mixture of null and non-null constituents.
26566 Part_Of_Constits : Elist_Id := No_Elist;
26567 -- A list of all candidate constituents subject to indicator Part_Of
26568 -- where the encapsulating state is the current state.
26571 State_Id : Entity_Id;
26572 -- The current state being refined
26574 procedure Analyze_Constituent (Constit : Node_Id);
26575 -- Perform full analysis of a single constituent
26577 procedure Check_External_Property
26578 (Prop_Nam : Name_Id;
26580 Constit : Entity_Id);
26581 -- Determine whether a property denoted by name Prop_Nam is present
26582 -- in the refined state. Emit an error if this is not the case. Flag
26583 -- Enabled should be set when the property applies to the refined
26584 -- state. Constit denotes the constituent (if any) which introduces
26585 -- the property in the refinement.
26587 procedure Match_State;
26588 -- Determine whether the state being refined appears in list
26589 -- Available_States. Emit an error when attempting to re-refine the
26590 -- state or when the state is not defined in the package declaration,
26591 -- otherwise remove the state from Available_States.
26593 procedure Report_Unused_Constituents (Constits : Elist_Id);
26594 -- Emit errors for all unused Part_Of constituents in list Constits
26596 -------------------------
26597 -- Analyze_Constituent --
26598 -------------------------
26600 procedure Analyze_Constituent (Constit : Node_Id) is
26601 procedure Match_Constituent (Constit_Id : Entity_Id);
26602 -- Determine whether constituent Constit denoted by its entity
26603 -- Constit_Id appears in Body_States. Emit an error when the
26604 -- constituent is not a valid hidden state of the related package
26605 -- or when it is used more than once. Otherwise remove the
26606 -- constituent from Body_States.
26608 -----------------------
26609 -- Match_Constituent --
26610 -----------------------
26612 procedure Match_Constituent (Constit_Id : Entity_Id) is
26613 procedure Collect_Constituent;
26614 -- Verify the legality of constituent Constit_Id and add it to
26615 -- the refinements of State_Id.
26617 -------------------------
26618 -- Collect_Constituent --
26619 -------------------------
26621 procedure Collect_Constituent is
26622 Constits : Elist_Id;
26625 -- The Ghost policy in effect at the point of abstract state
26626 -- declaration and constituent must match (SPARK RM 6.9(15))
26628 Check_Ghost_Refinement
26629 (State, State_Id, Constit, Constit_Id);
26631 -- A synchronized state must be refined by a synchronized
26632 -- object or another synchronized state (SPARK RM 9.6).
26634 if Is_Synchronized_State (State_Id)
26635 and then not Is_Synchronized_Object (Constit_Id)
26636 and then not Is_Synchronized_State (Constit_Id)
26639 ("constituent of synchronized state & must be "
26640 & "synchronized", Constit, State_Id);
26643 -- Add the constituent to the list of processed items to aid
26644 -- with the detection of duplicates.
26646 Append_New_Elmt (Constit_Id, Constituents_Seen);
26648 -- Collect the constituent in the list of refinement items
26649 -- and establish a relation between the refined state and
26652 Constits := Refinement_Constituents (State_Id);
26654 if No (Constits) then
26655 Constits := New_Elmt_List;
26656 Set_Refinement_Constituents (State_Id, Constits);
26659 Append_Elmt (Constit_Id, Constits);
26660 Set_Encapsulating_State (Constit_Id, State_Id);
26662 -- The state has at least one legal constituent, mark the
26663 -- start of the refinement region. The region ends when the
26664 -- body declarations end (see routine Analyze_Declarations).
26666 Set_Has_Visible_Refinement (State_Id);
26668 -- When the constituent is external, save its relevant
26669 -- property for further checks.
26671 if Async_Readers_Enabled (Constit_Id) then
26672 AR_Constit := Constit_Id;
26673 External_Constit_Seen := True;
26676 if Async_Writers_Enabled (Constit_Id) then
26677 AW_Constit := Constit_Id;
26678 External_Constit_Seen := True;
26681 if Effective_Reads_Enabled (Constit_Id) then
26682 ER_Constit := Constit_Id;
26683 External_Constit_Seen := True;
26686 if Effective_Writes_Enabled (Constit_Id) then
26687 EW_Constit := Constit_Id;
26688 External_Constit_Seen := True;
26690 end Collect_Constituent;
26694 State_Elmt : Elmt_Id;
26696 -- Start of processing for Match_Constituent
26699 -- Detect a duplicate use of a constituent
26701 if Contains (Constituents_Seen, Constit_Id) then
26703 ("duplicate use of constituent &", Constit, Constit_Id);
26707 -- The constituent is subject to a Part_Of indicator
26709 if Present (Encapsulating_State (Constit_Id)) then
26710 if Encapsulating_State (Constit_Id) = State_Id then
26711 Remove (Part_Of_Constits, Constit_Id);
26712 Collect_Constituent;
26714 -- The constituent is part of another state and is used
26715 -- incorrectly in the refinement of the current state.
26718 Error_Msg_Name_1 := Chars (State_Id);
26720 ("& cannot act as constituent of state %",
26721 Constit, Constit_Id);
26723 ("\Part_Of indicator specifies encapsulator &",
26724 Constit, Encapsulating_State (Constit_Id));
26727 -- The only other source of legal constituents is the body
26728 -- state space of the related package.
26731 if Present (Body_States) then
26732 State_Elmt := First_Elmt (Body_States);
26733 while Present (State_Elmt) loop
26735 -- Consume a valid constituent to signal that it has
26736 -- been encountered.
26738 if Node (State_Elmt) = Constit_Id then
26739 Remove_Elmt (Body_States, State_Elmt);
26740 Collect_Constituent;
26744 Next_Elmt (State_Elmt);
26748 -- Constants are part of the hidden state of a package, but
26749 -- the compiler cannot determine whether they have variable
26750 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26751 -- hidden state. Accept the constant quietly even if it is
26752 -- a visible state or lacks a Part_Of indicator.
26754 if Ekind (Constit_Id) = E_Constant then
26755 Collect_Constituent;
26757 -- If we get here, then the constituent is not a hidden
26758 -- state of the related package and may not be used in a
26759 -- refinement (SPARK RM 7.2.2(9)).
26762 Error_Msg_Name_1 := Chars (Spec_Id);
26764 ("cannot use & in refinement, constituent is not a "
26765 & "hidden state of package %", Constit, Constit_Id);
26768 end Match_Constituent;
26772 Constit_Id : Entity_Id;
26773 Constits : Elist_Id;
26775 -- Start of processing for Analyze_Constituent
26778 -- Detect multiple uses of null in a single refinement clause or a
26779 -- mixture of null and non-null constituents.
26781 if Nkind (Constit) = N_Null then
26784 ("multiple null constituents not allowed", Constit);
26786 elsif Non_Null_Seen then
26788 ("cannot mix null and non-null constituents", Constit);
26793 -- Collect the constituent in the list of refinement items
26795 Constits := Refinement_Constituents (State_Id);
26797 if No (Constits) then
26798 Constits := New_Elmt_List;
26799 Set_Refinement_Constituents (State_Id, Constits);
26802 Append_Elmt (Constit, Constits);
26804 -- The state has at least one legal constituent, mark the
26805 -- start of the refinement region. The region ends when the
26806 -- body declarations end (see Analyze_Declarations).
26808 Set_Has_Visible_Refinement (State_Id);
26811 -- Non-null constituents
26814 Non_Null_Seen := True;
26818 ("cannot mix null and non-null constituents", Constit);
26822 Resolve_State (Constit);
26824 -- Ensure that the constituent denotes a valid state or a
26825 -- whole object (SPARK RM 7.2.2(5)).
26827 if Is_Entity_Name (Constit) then
26828 Constit_Id := Entity_Of (Constit);
26830 -- When a constituent is declared after a subprogram body
26831 -- that caused "freezing" of the related contract where
26832 -- pragma Refined_State resides, the constituent appears
26833 -- undefined and carries Any_Id as its entity.
26835 -- package body Pack
26836 -- with Refined_State => (State => Constit)
26839 -- with Refined_Global => (Input => Constit)
26847 if Constit_Id = Any_Id then
26848 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
26850 -- Emit a specialized info message when the contract of
26851 -- the related package body was "frozen" by another body.
26852 -- Note that it is not possible to precisely identify why
26853 -- the constituent is undefined because it is not visible
26854 -- when pragma Refined_State is analyzed. This message is
26855 -- a reasonable approximation.
26857 if Present (Freeze_Id) and then not Freeze_Posted then
26858 Freeze_Posted := True;
26860 Error_Msg_Name_1 := Chars (Body_Id);
26861 Error_Msg_Sloc := Sloc (Freeze_Id);
26863 ("body & declared # freezes the contract of %",
26866 ("\all constituents must be declared before body #",
26869 -- A misplaced constituent is a critical error because
26870 -- pragma Refined_Depends or Refined_Global depends on
26871 -- the proper link between a state and a constituent.
26872 -- Stop the compilation, as this leads to a multitude
26873 -- of misleading cascaded errors.
26875 raise Program_Error;
26878 -- The constituent is a valid state or object
26880 elsif Ekind_In (Constit_Id, E_Abstract_State,
26884 Match_Constituent (Constit_Id);
26886 -- The variable may eventually become a constituent of a
26887 -- single protected/task type. Record the reference now
26888 -- and verify its legality when analyzing the contract of
26889 -- the variable (SPARK RM 9.3).
26891 if Ekind (Constit_Id) = E_Variable then
26892 Record_Possible_Part_Of_Reference
26893 (Var_Id => Constit_Id,
26897 -- Otherwise the constituent is illegal
26901 ("constituent & must denote object or state",
26902 Constit, Constit_Id);
26905 -- The constituent is illegal
26908 SPARK_Msg_N ("malformed constituent", Constit);
26911 end Analyze_Constituent;
26913 -----------------------------
26914 -- Check_External_Property --
26915 -----------------------------
26917 procedure Check_External_Property
26918 (Prop_Nam : Name_Id;
26920 Constit : Entity_Id)
26923 -- The property is missing in the declaration of the state, but
26924 -- a constituent is introducing it in the state refinement
26925 -- (SPARK RM 7.2.8(2)).
26927 if not Enabled and then Present (Constit) then
26928 Error_Msg_Name_1 := Prop_Nam;
26929 Error_Msg_Name_2 := Chars (State_Id);
26931 ("constituent & introduces external property % in refinement "
26932 & "of state %", State, Constit);
26934 Error_Msg_Sloc := Sloc (State_Id);
26936 ("\property is missing in abstract state declaration #",
26939 end Check_External_Property;
26945 procedure Match_State is
26946 State_Elmt : Elmt_Id;
26949 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26951 if Contains (Refined_States_Seen, State_Id) then
26953 ("duplicate refinement of state &", State, State_Id);
26957 -- Inspect the abstract states defined in the package declaration
26958 -- looking for a match.
26960 State_Elmt := First_Elmt (Available_States);
26961 while Present (State_Elmt) loop
26963 -- A valid abstract state is being refined in the body. Add
26964 -- the state to the list of processed refined states to aid
26965 -- with the detection of duplicate refinements. Remove the
26966 -- state from Available_States to signal that it has already
26969 if Node (State_Elmt) = State_Id then
26970 Append_New_Elmt (State_Id, Refined_States_Seen);
26971 Remove_Elmt (Available_States, State_Elmt);
26975 Next_Elmt (State_Elmt);
26978 -- If we get here, we are refining a state that is not defined in
26979 -- the package declaration.
26981 Error_Msg_Name_1 := Chars (Spec_Id);
26983 ("cannot refine state, & is not defined in package %",
26987 --------------------------------
26988 -- Report_Unused_Constituents --
26989 --------------------------------
26991 procedure Report_Unused_Constituents (Constits : Elist_Id) is
26992 Constit_Elmt : Elmt_Id;
26993 Constit_Id : Entity_Id;
26994 Posted : Boolean := False;
26997 if Present (Constits) then
26998 Constit_Elmt := First_Elmt (Constits);
26999 while Present (Constit_Elmt) loop
27000 Constit_Id := Node (Constit_Elmt);
27002 -- Generate an error message of the form:
27004 -- state ... has unused Part_Of constituents
27005 -- abstract state ... defined at ...
27006 -- constant ... defined at ...
27007 -- variable ... defined at ...
27012 ("state & has unused Part_Of constituents",
27016 Error_Msg_Sloc := Sloc (Constit_Id);
27018 if Ekind (Constit_Id) = E_Abstract_State then
27020 ("\abstract state & defined #", State, Constit_Id);
27022 elsif Ekind (Constit_Id) = E_Constant then
27024 ("\constant & defined #", State, Constit_Id);
27027 pragma Assert (Ekind (Constit_Id) = E_Variable);
27028 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
27031 Next_Elmt (Constit_Elmt);
27034 end Report_Unused_Constituents;
27036 -- Local declarations
27038 Body_Ref : Node_Id;
27039 Body_Ref_Elmt : Elmt_Id;
27041 Extra_State : Node_Id;
27043 -- Start of processing for Analyze_Refinement_Clause
27046 -- A refinement clause appears as a component association where the
27047 -- sole choice is the state and the expressions are the constituents.
27048 -- This is a syntax error, always report.
27050 if Nkind (Clause) /= N_Component_Association then
27051 Error_Msg_N ("malformed state refinement clause", Clause);
27055 -- Analyze the state name of a refinement clause
27057 State := First (Choices (Clause));
27060 Resolve_State (State);
27062 -- Ensure that the state name denotes a valid abstract state that is
27063 -- defined in the spec of the related package.
27065 if Is_Entity_Name (State) then
27066 State_Id := Entity_Of (State);
27068 -- When the abstract state is undefined, it appears as Any_Id. Do
27069 -- not continue with the analysis of the clause.
27071 if State_Id = Any_Id then
27074 -- Catch any attempts to re-refine a state or refine a state that
27075 -- is not defined in the package declaration.
27077 elsif Ekind (State_Id) = E_Abstract_State then
27081 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
27085 -- References to a state with visible refinement are illegal.
27086 -- When nested packages are involved, detecting such references is
27087 -- tricky because pragma Refined_State is analyzed later than the
27088 -- offending pragma Depends or Global. References that occur in
27089 -- such nested context are stored in a list. Emit errors for all
27090 -- references found in Body_References (SPARK RM 6.1.4(8)).
27092 if Present (Body_References (State_Id)) then
27093 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
27094 while Present (Body_Ref_Elmt) loop
27095 Body_Ref := Node (Body_Ref_Elmt);
27097 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
27098 Error_Msg_Sloc := Sloc (State);
27099 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
27101 Next_Elmt (Body_Ref_Elmt);
27105 -- The state name is illegal. This is a syntax error, always report.
27108 Error_Msg_N ("malformed state name in refinement clause", State);
27112 -- A refinement clause may only refine one state at a time
27114 Extra_State := Next (State);
27116 if Present (Extra_State) then
27118 ("refinement clause cannot cover multiple states", Extra_State);
27121 -- Replicate the Part_Of constituents of the refined state because
27122 -- the algorithm will consume items.
27124 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
27126 -- Analyze all constituents of the refinement. Multiple constituents
27127 -- appear as an aggregate.
27129 Constit := Expression (Clause);
27131 if Nkind (Constit) = N_Aggregate then
27132 if Present (Component_Associations (Constit)) then
27134 ("constituents of refinement clause must appear in "
27135 & "positional form", Constit);
27137 else pragma Assert (Present (Expressions (Constit)));
27138 Constit := First (Expressions (Constit));
27139 while Present (Constit) loop
27140 Analyze_Constituent (Constit);
27145 -- Various forms of a single constituent. Note that these may include
27146 -- malformed constituents.
27149 Analyze_Constituent (Constit);
27152 -- Verify that external constituents do not introduce new external
27153 -- property in the state refinement (SPARK RM 7.2.8(2)).
27155 if Is_External_State (State_Id) then
27156 Check_External_Property
27157 (Prop_Nam => Name_Async_Readers,
27158 Enabled => Async_Readers_Enabled (State_Id),
27159 Constit => AR_Constit);
27161 Check_External_Property
27162 (Prop_Nam => Name_Async_Writers,
27163 Enabled => Async_Writers_Enabled (State_Id),
27164 Constit => AW_Constit);
27166 Check_External_Property
27167 (Prop_Nam => Name_Effective_Reads,
27168 Enabled => Effective_Reads_Enabled (State_Id),
27169 Constit => ER_Constit);
27171 Check_External_Property
27172 (Prop_Nam => Name_Effective_Writes,
27173 Enabled => Effective_Writes_Enabled (State_Id),
27174 Constit => EW_Constit);
27176 -- When a refined state is not external, it should not have external
27177 -- constituents (SPARK RM 7.2.8(1)).
27179 elsif External_Constit_Seen then
27181 ("non-external state & cannot contain external constituents in "
27182 & "refinement", State, State_Id);
27185 -- Ensure that all Part_Of candidate constituents have been mentioned
27186 -- in the refinement clause.
27188 Report_Unused_Constituents (Part_Of_Constits);
27189 end Analyze_Refinement_Clause;
27191 -----------------------------
27192 -- Report_Unrefined_States --
27193 -----------------------------
27195 procedure Report_Unrefined_States (States : Elist_Id) is
27196 State_Elmt : Elmt_Id;
27199 if Present (States) then
27200 State_Elmt := First_Elmt (States);
27201 while Present (State_Elmt) loop
27203 ("abstract state & must be refined", Node (State_Elmt));
27205 Next_Elmt (State_Elmt);
27208 end Report_Unrefined_States;
27210 -- Local declarations
27212 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27215 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27218 -- Do not analyze the pragma multiple times
27220 if Is_Analyzed_Pragma (N) then
27224 -- Replicate the abstract states declared by the package because the
27225 -- matching algorithm will consume states.
27227 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
27229 -- Gather all abstract states and objects declared in the visible
27230 -- state space of the package body. These items must be utilized as
27231 -- constituents in a state refinement.
27233 Body_States := Collect_Body_States (Body_Id);
27235 -- Multiple non-null state refinements appear as an aggregate
27237 if Nkind (Clauses) = N_Aggregate then
27238 if Present (Expressions (Clauses)) then
27240 ("state refinements must appear as component associations",
27243 else pragma Assert (Present (Component_Associations (Clauses)));
27244 Clause := First (Component_Associations (Clauses));
27245 while Present (Clause) loop
27246 Analyze_Refinement_Clause (Clause);
27251 -- Various forms of a single state refinement. Note that these may
27252 -- include malformed refinements.
27255 Analyze_Refinement_Clause (Clauses);
27258 -- List all abstract states that were left unrefined
27260 Report_Unrefined_States (Available_States);
27262 Set_Is_Analyzed_Pragma (N);
27263 end Analyze_Refined_State_In_Decl_Part;
27265 ------------------------------------
27266 -- Analyze_Test_Case_In_Decl_Part --
27267 ------------------------------------
27269 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
27270 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27271 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27273 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
27274 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27275 -- denoted by Arg_Nam.
27277 ------------------------------
27278 -- Preanalyze_Test_Case_Arg --
27279 ------------------------------
27281 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
27285 -- Preanalyze the original aspect argument for ASIS or for a generic
27286 -- subprogram to properly capture global references.
27288 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
27292 Arg_Nam => Arg_Nam,
27293 From_Aspect => True);
27295 if Present (Arg) then
27296 Preanalyze_Assert_Expression
27297 (Expression (Arg), Standard_Boolean);
27301 Arg := Test_Case_Arg (N, Arg_Nam);
27303 if Present (Arg) then
27304 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
27306 end Preanalyze_Test_Case_Arg;
27310 Restore_Scope : Boolean := False;
27312 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27315 -- Do not analyze the pragma multiple times
27317 if Is_Analyzed_Pragma (N) then
27321 -- Ensure that the formal parameters are visible when analyzing all
27322 -- clauses. This falls out of the general rule of aspects pertaining
27323 -- to subprogram declarations.
27325 if not In_Open_Scopes (Spec_Id) then
27326 Restore_Scope := True;
27327 Push_Scope (Spec_Id);
27329 if Is_Generic_Subprogram (Spec_Id) then
27330 Install_Generic_Formals (Spec_Id);
27332 Install_Formals (Spec_Id);
27336 Preanalyze_Test_Case_Arg (Name_Requires);
27337 Preanalyze_Test_Case_Arg (Name_Ensures);
27339 if Restore_Scope then
27343 -- Currently it is not possible to inline pre/postconditions on a
27344 -- subprogram subject to pragma Inline_Always.
27346 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27348 Set_Is_Analyzed_Pragma (N);
27349 end Analyze_Test_Case_In_Decl_Part;
27355 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
27360 if Present (List) then
27361 Elmt := First_Elmt (List);
27362 while Present (Elmt) loop
27363 if Nkind (Node (Elmt)) = N_Defining_Identifier then
27366 Id := Entity_Of (Node (Elmt));
27369 if Id = Item_Id then
27380 -----------------------------------
27381 -- Build_Pragma_Check_Equivalent --
27382 -----------------------------------
27384 function Build_Pragma_Check_Equivalent
27386 Subp_Id : Entity_Id := Empty;
27387 Inher_Id : Entity_Id := Empty;
27388 Keep_Pragma_Id : Boolean := False) return Node_Id
27390 function Suppress_Reference (N : Node_Id) return Traverse_Result;
27391 -- Detect whether node N references a formal parameter subject to
27392 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27393 -- to False to suppress the generation of a reference when analyzing
27396 ------------------------
27397 -- Suppress_Reference --
27398 ------------------------
27400 function Suppress_Reference (N : Node_Id) return Traverse_Result is
27401 Formal : Entity_Id;
27404 if Is_Entity_Name (N) and then Present (Entity (N)) then
27405 Formal := Entity (N);
27407 -- The formal parameter is subject to pragma Unreferenced. Prevent
27408 -- the generation of references by resetting the Comes_From_Source
27411 if Is_Formal (Formal)
27412 and then Has_Pragma_Unreferenced (Formal)
27414 Set_Comes_From_Source (N, False);
27419 end Suppress_Reference;
27421 procedure Suppress_References is
27422 new Traverse_Proc (Suppress_Reference);
27426 Loc : constant Source_Ptr := Sloc (Prag);
27427 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27428 Check_Prag : Node_Id;
27432 Needs_Wrapper : Boolean;
27433 pragma Unreferenced (Needs_Wrapper);
27435 -- Start of processing for Build_Pragma_Check_Equivalent
27438 -- When the pre- or postcondition is inherited, map the formals of the
27439 -- inherited subprogram to those of the current subprogram. In addition,
27440 -- map primitive operations of the parent type into the corresponding
27441 -- primitive operations of the descendant.
27443 if Present (Inher_Id) then
27444 pragma Assert (Present (Subp_Id));
27446 Update_Primitives_Mapping (Inher_Id, Subp_Id);
27448 -- Use generic machinery to copy inherited pragma, as if it were an
27449 -- instantiation, resetting source locations appropriately, so that
27450 -- expressions inside the inherited pragma use chained locations.
27451 -- This is used in particular in GNATprove to locate precisely
27452 -- messages on a given inherited pragma.
27454 Set_Copied_Sloc_For_Inherited_Pragma
27455 (Unit_Declaration_Node (Subp_Id), Inher_Id);
27456 Check_Prag := New_Copy_Tree (Source => Prag);
27458 -- Build the inherited class-wide condition
27460 Build_Class_Wide_Expression
27461 (Prag => Check_Prag,
27463 Par_Subp => Inher_Id,
27464 Adjust_Sloc => True,
27465 Needs_Wrapper => Needs_Wrapper);
27467 -- If not an inherited condition simply copy the original pragma
27470 Check_Prag := New_Copy_Tree (Source => Prag);
27473 -- Mark the pragma as being internally generated and reset the Analyzed
27476 Set_Analyzed (Check_Prag, False);
27477 Set_Comes_From_Source (Check_Prag, False);
27479 -- The tree of the original pragma may contain references to the
27480 -- formal parameters of the related subprogram. At the same time
27481 -- the corresponding body may mark the formals as unreferenced:
27483 -- procedure Proc (Formal : ...)
27484 -- with Pre => Formal ...;
27486 -- procedure Proc (Formal : ...) is
27487 -- pragma Unreferenced (Formal);
27490 -- This creates problems because all pragma Check equivalents are
27491 -- analyzed at the end of the body declarations. Since all source
27492 -- references have already been accounted for, reset any references
27493 -- to such formals in the generated pragma Check equivalent.
27495 Suppress_References (Check_Prag);
27497 if Present (Corresponding_Aspect (Prag)) then
27498 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
27503 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27504 -- the copied pragma in the newly created pragma, convert the copy into
27505 -- pragma Check by correcting the name and adding a check_kind argument.
27507 if not Keep_Pragma_Id then
27508 Set_Class_Present (Check_Prag, False);
27510 Set_Pragma_Identifier
27511 (Check_Prag, Make_Identifier (Loc, Name_Check));
27513 Prepend_To (Pragma_Argument_Associations (Check_Prag),
27514 Make_Pragma_Argument_Association (Loc,
27515 Expression => Make_Identifier (Loc, Nam)));
27518 -- Update the error message when the pragma is inherited
27520 if Present (Inher_Id) then
27521 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
27523 if Chars (Msg_Arg) = Name_Message then
27524 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
27526 -- Insert "inherited" to improve the error message
27528 if Name_Buffer (1 .. 8) = "failed p" then
27529 Insert_Str_In_Name_Buffer ("inherited ", 8);
27530 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
27536 end Build_Pragma_Check_Equivalent;
27538 -----------------------------
27539 -- Check_Applicable_Policy --
27540 -----------------------------
27542 procedure Check_Applicable_Policy (N : Node_Id) is
27546 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
27549 -- No effect if not valid assertion kind name
27551 if not Is_Valid_Assertion_Kind (Ename) then
27555 -- Loop through entries in check policy list
27557 PP := Opt.Check_Policy_List;
27558 while Present (PP) loop
27560 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27561 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27565 or else Pnm = Name_Assertion
27566 or else (Pnm = Name_Statement_Assertions
27567 and then Nam_In (Ename, Name_Assert,
27568 Name_Assert_And_Cut,
27570 Name_Loop_Invariant,
27571 Name_Loop_Variant))
27573 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
27579 Set_Is_Ignored (N, True);
27580 Set_Is_Checked (N, False);
27585 Set_Is_Checked (N, True);
27586 Set_Is_Ignored (N, False);
27588 when Name_Disable =>
27589 Set_Is_Ignored (N, True);
27590 Set_Is_Checked (N, False);
27591 Set_Is_Disabled (N, True);
27593 -- That should be exhaustive, the null here is a defence
27594 -- against a malformed tree from previous errors.
27603 PP := Next_Pragma (PP);
27607 -- If there are no specific entries that matched, then we let the
27608 -- setting of assertions govern. Note that this provides the needed
27609 -- compatibility with the RM for the cases of assertion, invariant,
27610 -- precondition, predicate, and postcondition.
27612 if Assertions_Enabled then
27613 Set_Is_Checked (N, True);
27614 Set_Is_Ignored (N, False);
27616 Set_Is_Checked (N, False);
27617 Set_Is_Ignored (N, True);
27619 end Check_Applicable_Policy;
27621 -------------------------------
27622 -- Check_External_Properties --
27623 -------------------------------
27625 procedure Check_External_Properties
27633 -- All properties enabled
27635 if AR and AW and ER and EW then
27638 -- Async_Readers + Effective_Writes
27639 -- Async_Readers + Async_Writers + Effective_Writes
27641 elsif AR and EW and not ER then
27644 -- Async_Writers + Effective_Reads
27645 -- Async_Readers + Async_Writers + Effective_Reads
27647 elsif AW and ER and not EW then
27650 -- Async_Readers + Async_Writers
27652 elsif AR and AW and not ER and not EW then
27657 elsif AR and not AW and not ER and not EW then
27662 elsif AW and not AR and not ER and not EW then
27667 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27670 end Check_External_Properties;
27676 function Check_Kind (Nam : Name_Id) return Name_Id is
27680 -- Loop through entries in check policy list
27682 PP := Opt.Check_Policy_List;
27683 while Present (PP) loop
27685 PPA : constant List_Id := Pragma_Argument_Associations (PP);
27686 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
27690 or else (Pnm = Name_Assertion
27691 and then Is_Valid_Assertion_Kind (Nam))
27692 or else (Pnm = Name_Statement_Assertions
27693 and then Nam_In (Nam, Name_Assert,
27694 Name_Assert_And_Cut,
27696 Name_Loop_Invariant,
27697 Name_Loop_Variant))
27699 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
27708 return Name_Ignore;
27710 when Name_Disable =>
27711 return Name_Disable;
27714 raise Program_Error;
27718 PP := Next_Pragma (PP);
27723 -- If there are no specific entries that matched, then we let the
27724 -- setting of assertions govern. Note that this provides the needed
27725 -- compatibility with the RM for the cases of assertion, invariant,
27726 -- precondition, predicate, and postcondition.
27728 if Assertions_Enabled then
27731 return Name_Ignore;
27735 ---------------------------
27736 -- Check_Missing_Part_Of --
27737 ---------------------------
27739 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
27740 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
27741 -- Determine whether a package denoted by Pack_Id declares at least one
27744 -----------------------
27745 -- Has_Visible_State --
27746 -----------------------
27748 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
27749 Item_Id : Entity_Id;
27752 -- Traverse the entity chain of the package trying to find at least
27753 -- one visible abstract state, variable or a package [instantiation]
27754 -- that declares a visible state.
27756 Item_Id := First_Entity (Pack_Id);
27757 while Present (Item_Id)
27758 and then not In_Private_Part (Item_Id)
27760 -- Do not consider internally generated items
27762 if not Comes_From_Source (Item_Id) then
27765 -- A visible state has been found
27767 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
27770 -- Recursively peek into nested packages and instantiations
27772 elsif Ekind (Item_Id) = E_Package
27773 and then Has_Visible_State (Item_Id)
27778 Next_Entity (Item_Id);
27782 end Has_Visible_State;
27786 Pack_Id : Entity_Id;
27787 Placement : State_Space_Kind;
27789 -- Start of processing for Check_Missing_Part_Of
27792 -- Do not consider abstract states, variables or package instantiations
27793 -- coming from an instance as those always inherit the Part_Of indicator
27794 -- of the instance itself.
27796 if In_Instance then
27799 -- Do not consider internally generated entities as these can never
27800 -- have a Part_Of indicator.
27802 elsif not Comes_From_Source (Item_Id) then
27805 -- Perform these checks only when SPARK_Mode is enabled as they will
27806 -- interfere with standard Ada rules and produce false positives.
27808 elsif SPARK_Mode /= On then
27811 -- Do not consider constants, because the compiler cannot accurately
27812 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27813 -- act as a hidden state of a package.
27815 elsif Ekind (Item_Id) = E_Constant then
27819 -- Find where the abstract state, variable or package instantiation
27820 -- lives with respect to the state space.
27822 Find_Placement_In_State_Space
27823 (Item_Id => Item_Id,
27824 Placement => Placement,
27825 Pack_Id => Pack_Id);
27827 -- Items that appear in a non-package construct (subprogram, block, etc)
27828 -- do not require a Part_Of indicator because they can never act as a
27831 if Placement = Not_In_Package then
27834 -- An item declared in the body state space of a package always act as a
27835 -- constituent and does not need explicit Part_Of indicator.
27837 elsif Placement = Body_State_Space then
27840 -- In general an item declared in the visible state space of a package
27841 -- does not require a Part_Of indicator. The only exception is when the
27842 -- related package is a private child unit in which case Part_Of must
27843 -- denote a state in the parent unit or in one of its descendants.
27845 elsif Placement = Visible_State_Space then
27846 if Is_Child_Unit (Pack_Id)
27847 and then Is_Private_Descendant (Pack_Id)
27849 -- A package instantiation does not need a Part_Of indicator when
27850 -- the related generic template has no visible state.
27852 if Ekind (Item_Id) = E_Package
27853 and then Is_Generic_Instance (Item_Id)
27854 and then not Has_Visible_State (Item_Id)
27858 -- All other cases require Part_Of
27862 ("indicator Part_Of is required in this context "
27863 & "(SPARK RM 7.2.6(3))", Item_Id);
27864 Error_Msg_Name_1 := Chars (Pack_Id);
27866 ("\& is declared in the visible part of private child "
27867 & "unit %", Item_Id);
27871 -- When the item appears in the private state space of a packge, it must
27872 -- be a part of some state declared by the said package.
27874 else pragma Assert (Placement = Private_State_Space);
27876 -- The related package does not declare a state, the item cannot act
27877 -- as a Part_Of constituent.
27879 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
27882 -- A package instantiation does not need a Part_Of indicator when the
27883 -- related generic template has no visible state.
27885 elsif Ekind (Pack_Id) = E_Package
27886 and then Is_Generic_Instance (Pack_Id)
27887 and then not Has_Visible_State (Pack_Id)
27891 -- All other cases require Part_Of
27895 ("indicator Part_Of is required in this context "
27896 & "(SPARK RM 7.2.6(2))", Item_Id);
27897 Error_Msg_Name_1 := Chars (Pack_Id);
27899 ("\& is declared in the private part of package %", Item_Id);
27902 end Check_Missing_Part_Of;
27904 ---------------------------------------------------
27905 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27906 ---------------------------------------------------
27908 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27910 Spec_Id : Entity_Id)
27913 if Warn_On_Redundant_Constructs
27914 and then Has_Pragma_Inline_Always (Spec_Id)
27916 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27918 if From_Aspect_Specification (Prag) then
27920 ("aspect % not enforced on inlined subprogram &?r?",
27921 Corresponding_Aspect (Prag), Spec_Id);
27924 ("pragma % not enforced on inlined subprogram &?r?",
27928 end Check_Postcondition_Use_In_Inlined_Subprogram;
27930 -------------------------------------
27931 -- Check_State_And_Constituent_Use --
27932 -------------------------------------
27934 procedure Check_State_And_Constituent_Use
27935 (States : Elist_Id;
27936 Constits : Elist_Id;
27939 Constit_Elmt : Elmt_Id;
27940 Constit_Id : Entity_Id;
27941 State_Id : Entity_Id;
27944 -- Nothing to do if there are no states or constituents
27946 if No (States) or else No (Constits) then
27950 -- Inspect the list of constituents and try to determine whether its
27951 -- encapsulating state is in list States.
27953 Constit_Elmt := First_Elmt (Constits);
27954 while Present (Constit_Elmt) loop
27955 Constit_Id := Node (Constit_Elmt);
27957 -- Determine whether the constituent is part of an encapsulating
27958 -- state that appears in the same context and if this is the case,
27959 -- emit an error (SPARK RM 7.2.6(7)).
27961 State_Id := Find_Encapsulating_State (States, Constit_Id);
27963 if Present (State_Id) then
27964 Error_Msg_Name_1 := Chars (Constit_Id);
27966 ("cannot mention state & and its constituent % in the same "
27967 & "context", Context, State_Id);
27971 Next_Elmt (Constit_Elmt);
27973 end Check_State_And_Constituent_Use;
27975 ---------------------------------------------
27976 -- Collect_Inherited_Class_Wide_Conditions --
27977 ---------------------------------------------
27979 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27980 Parent_Subp : constant Entity_Id :=
27981 Ultimate_Alias (Overridden_Operation (Subp));
27982 -- The Overridden_Operation may itself be inherited and as such have no
27983 -- explicit contract.
27985 Prags : constant Node_Id := Contract (Parent_Subp);
27986 In_Spec_Expr : Boolean;
27987 Installed : Boolean;
27989 New_Prag : Node_Id;
27992 Installed := False;
27994 -- Iterate over the contract of the overridden subprogram to find all
27995 -- inherited class-wide pre- and postconditions.
27997 if Present (Prags) then
27998 Prag := Pre_Post_Conditions (Prags);
28000 while Present (Prag) loop
28001 if Nam_In (Pragma_Name_Unmapped (Prag),
28002 Name_Precondition, Name_Postcondition)
28003 and then Class_Present (Prag)
28005 -- The generated pragma must be analyzed in the context of
28006 -- the subprogram, to make its formals visible. In addition,
28007 -- we must inhibit freezing and full analysis because the
28008 -- controlling type of the subprogram is not frozen yet, and
28009 -- may have further primitives.
28011 if not Installed then
28014 Install_Formals (Subp);
28015 In_Spec_Expr := In_Spec_Expression;
28016 In_Spec_Expression := True;
28020 Build_Pragma_Check_Equivalent
28021 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
28023 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
28024 Preanalyze (New_Prag);
28026 -- Prevent further analysis in subsequent processing of the
28027 -- current list of declarations
28029 Set_Analyzed (New_Prag);
28032 Prag := Next_Pragma (Prag);
28036 In_Spec_Expression := In_Spec_Expr;
28040 end Collect_Inherited_Class_Wide_Conditions;
28042 ---------------------------------------
28043 -- Collect_Subprogram_Inputs_Outputs --
28044 ---------------------------------------
28046 procedure Collect_Subprogram_Inputs_Outputs
28047 (Subp_Id : Entity_Id;
28048 Synthesize : Boolean := False;
28049 Subp_Inputs : in out Elist_Id;
28050 Subp_Outputs : in out Elist_Id;
28051 Global_Seen : out Boolean)
28053 procedure Collect_Dependency_Clause (Clause : Node_Id);
28054 -- Collect all relevant items from a dependency clause
28056 procedure Collect_Global_List
28058 Mode : Name_Id := Name_Input);
28059 -- Collect all relevant items from a global list
28061 -------------------------------
28062 -- Collect_Dependency_Clause --
28063 -------------------------------
28065 procedure Collect_Dependency_Clause (Clause : Node_Id) is
28066 procedure Collect_Dependency_Item
28068 Is_Input : Boolean);
28069 -- Add an item to the proper subprogram input or output collection
28071 -----------------------------
28072 -- Collect_Dependency_Item --
28073 -----------------------------
28075 procedure Collect_Dependency_Item
28077 Is_Input : Boolean)
28082 -- Nothing to collect when the item is null
28084 if Nkind (Item) = N_Null then
28087 -- Ditto for attribute 'Result
28089 elsif Is_Attribute_Result (Item) then
28092 -- Multiple items appear as an aggregate
28094 elsif Nkind (Item) = N_Aggregate then
28095 Extra := First (Expressions (Item));
28096 while Present (Extra) loop
28097 Collect_Dependency_Item (Extra, Is_Input);
28101 -- Otherwise this is a solitary item
28105 Append_New_Elmt (Item, Subp_Inputs);
28107 Append_New_Elmt (Item, Subp_Outputs);
28110 end Collect_Dependency_Item;
28112 -- Start of processing for Collect_Dependency_Clause
28115 if Nkind (Clause) = N_Null then
28118 -- A dependency cause appears as component association
28120 elsif Nkind (Clause) = N_Component_Association then
28121 Collect_Dependency_Item
28122 (Item => Expression (Clause),
28125 Collect_Dependency_Item
28126 (Item => First (Choices (Clause)),
28127 Is_Input => False);
28129 -- To accommodate partial decoration of disabled SPARK features, this
28130 -- routine may be called with illegal input. If this is the case, do
28131 -- not raise Program_Error.
28136 end Collect_Dependency_Clause;
28138 -------------------------
28139 -- Collect_Global_List --
28140 -------------------------
28142 procedure Collect_Global_List
28144 Mode : Name_Id := Name_Input)
28146 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
28147 -- Add an item to the proper subprogram input or output collection
28149 -------------------------
28150 -- Collect_Global_Item --
28151 -------------------------
28153 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
28155 if Nam_In (Mode, Name_In_Out, Name_Input) then
28156 Append_New_Elmt (Item, Subp_Inputs);
28159 if Nam_In (Mode, Name_In_Out, Name_Output) then
28160 Append_New_Elmt (Item, Subp_Outputs);
28162 end Collect_Global_Item;
28169 -- Start of processing for Collect_Global_List
28172 if Nkind (List) = N_Null then
28175 -- Single global item declaration
28177 elsif Nkind_In (List, N_Expanded_Name,
28179 N_Selected_Component)
28181 Collect_Global_Item (List, Mode);
28183 -- Simple global list or moded global list declaration
28185 elsif Nkind (List) = N_Aggregate then
28186 if Present (Expressions (List)) then
28187 Item := First (Expressions (List));
28188 while Present (Item) loop
28189 Collect_Global_Item (Item, Mode);
28194 Assoc := First (Component_Associations (List));
28195 while Present (Assoc) loop
28196 Collect_Global_List
28197 (List => Expression (Assoc),
28198 Mode => Chars (First (Choices (Assoc))));
28203 -- To accommodate partial decoration of disabled SPARK features, this
28204 -- routine may be called with illegal input. If this is the case, do
28205 -- not raise Program_Error.
28210 end Collect_Global_List;
28217 Formal : Entity_Id;
28219 Spec_Id : Entity_Id;
28220 Subp_Decl : Node_Id;
28223 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28226 Global_Seen := False;
28228 -- Process all formal parameters of entries, [generic] subprograms, and
28231 if Ekind_In (Subp_Id, E_Entry,
28234 E_Generic_Function,
28235 E_Generic_Procedure,
28239 Subp_Decl := Unit_Declaration_Node (Subp_Id);
28240 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28242 -- Process all [generic] formal parameters
28244 Formal := First_Entity (Spec_Id);
28245 while Present (Formal) loop
28246 if Ekind_In (Formal, E_Generic_In_Parameter,
28247 E_In_Out_Parameter,
28250 Append_New_Elmt (Formal, Subp_Inputs);
28253 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
28254 E_In_Out_Parameter,
28257 Append_New_Elmt (Formal, Subp_Outputs);
28259 -- Out parameters can act as inputs when the related type is
28260 -- tagged, unconstrained array, unconstrained record, or record
28261 -- with unconstrained components.
28263 if Ekind (Formal) = E_Out_Parameter
28264 and then Is_Unconstrained_Or_Tagged_Item (Formal)
28266 Append_New_Elmt (Formal, Subp_Inputs);
28270 Next_Entity (Formal);
28273 -- Otherwise the input denotes a task type, a task body, or the
28274 -- anonymous object created for a single task type.
28276 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
28277 or else Is_Single_Task_Object (Subp_Id)
28279 Subp_Decl := Declaration_Node (Subp_Id);
28280 Spec_Id := Unique_Defining_Entity (Subp_Decl);
28283 -- When processing an entry, subprogram or task body, look for pragmas
28284 -- Refined_Depends and Refined_Global as they specify the inputs and
28287 if Is_Entry_Body (Subp_Id)
28288 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
28290 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
28291 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
28293 -- Subprogram declaration or stand alone body case, look for pragmas
28294 -- Depends and Global
28297 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
28298 Global := Get_Pragma (Spec_Id, Pragma_Global);
28301 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28302 -- because it provides finer granularity of inputs and outputs.
28304 if Present (Global) then
28305 Global_Seen := True;
28306 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
28308 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28309 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28310 -- the inputs and outputs from [Refined_]Depends.
28312 elsif Synthesize and then Present (Depends) then
28313 Clauses := Expression (Get_Argument (Depends, Spec_Id));
28315 -- Multiple dependency clauses appear as an aggregate
28317 if Nkind (Clauses) = N_Aggregate then
28318 Clause := First (Component_Associations (Clauses));
28319 while Present (Clause) loop
28320 Collect_Dependency_Clause (Clause);
28324 -- Otherwise this is a single dependency clause
28327 Collect_Dependency_Clause (Clauses);
28331 -- The current instance of a protected type acts as a formal parameter
28332 -- of mode IN for functions and IN OUT for entries and procedures
28333 -- (SPARK RM 6.1.4).
28335 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
28336 Typ := Scope (Spec_Id);
28338 -- Use the anonymous object when the type is single protected
28340 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28341 Typ := Anonymous_Object (Typ);
28344 Append_New_Elmt (Typ, Subp_Inputs);
28346 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
28347 Append_New_Elmt (Typ, Subp_Outputs);
28350 -- The current instance of a task type acts as a formal parameter of
28351 -- mode IN OUT (SPARK RM 6.1.4).
28353 elsif Ekind (Spec_Id) = E_Task_Type then
28356 -- Use the anonymous object when the type is single task
28358 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
28359 Typ := Anonymous_Object (Typ);
28362 Append_New_Elmt (Typ, Subp_Inputs);
28363 Append_New_Elmt (Typ, Subp_Outputs);
28365 elsif Is_Single_Task_Object (Spec_Id) then
28366 Append_New_Elmt (Spec_Id, Subp_Inputs);
28367 Append_New_Elmt (Spec_Id, Subp_Outputs);
28369 end Collect_Subprogram_Inputs_Outputs;
28371 ---------------------------
28372 -- Contract_Freeze_Error --
28373 ---------------------------
28375 procedure Contract_Freeze_Error
28376 (Contract_Id : Entity_Id;
28377 Freeze_Id : Entity_Id)
28380 Error_Msg_Name_1 := Chars (Contract_Id);
28381 Error_Msg_Sloc := Sloc (Freeze_Id);
28384 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
28386 ("\all contractual items must be declared before body #", Contract_Id);
28387 end Contract_Freeze_Error;
28389 ---------------------------------
28390 -- Delay_Config_Pragma_Analyze --
28391 ---------------------------------
28393 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
28395 return Nam_In (Pragma_Name_Unmapped (N),
28396 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
28397 end Delay_Config_Pragma_Analyze;
28399 -----------------------
28400 -- Duplication_Error --
28401 -----------------------
28403 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
28404 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
28405 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
28408 Error_Msg_Sloc := Sloc (Prev);
28409 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
28411 -- Emit a precise message to distinguish between source pragmas and
28412 -- pragmas generated from aspects. The ordering of the two pragmas is
28416 -- Prag -- duplicate
28418 -- No error is emitted when both pragmas come from aspects because this
28419 -- is already detected by the general aspect analysis mechanism.
28421 if Prag_From_Asp and Prev_From_Asp then
28423 elsif Prag_From_Asp then
28424 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
28425 elsif Prev_From_Asp then
28426 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
28428 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
28430 end Duplication_Error;
28432 ------------------------------
28433 -- Find_Encapsulating_State --
28434 ------------------------------
28436 function Find_Encapsulating_State
28437 (States : Elist_Id;
28438 Constit_Id : Entity_Id) return Entity_Id
28440 State_Id : Entity_Id;
28443 -- Since a constituent may be part of a larger constituent set, climb
28444 -- the encapsulating state chain looking for a state that appears in
28447 State_Id := Encapsulating_State (Constit_Id);
28448 while Present (State_Id) loop
28449 if Contains (States, State_Id) then
28453 State_Id := Encapsulating_State (State_Id);
28457 end Find_Encapsulating_State;
28459 --------------------------
28460 -- Find_Related_Context --
28461 --------------------------
28463 function Find_Related_Context
28465 Do_Checks : Boolean := False) return Node_Id
28470 Stmt := Prev (Prag);
28471 while Present (Stmt) loop
28473 -- Skip prior pragmas, but check for duplicates
28475 if Nkind (Stmt) = N_Pragma then
28477 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
28484 -- Skip internally generated code
28486 elsif not Comes_From_Source (Stmt) then
28488 -- The anonymous object created for a single concurrent type is a
28489 -- suitable context.
28491 if Nkind (Stmt) = N_Object_Declaration
28492 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28497 -- Return the current source construct
28507 end Find_Related_Context;
28509 --------------------------------------
28510 -- Find_Related_Declaration_Or_Body --
28511 --------------------------------------
28513 function Find_Related_Declaration_Or_Body
28515 Do_Checks : Boolean := False) return Node_Id
28517 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
28519 procedure Expression_Function_Error;
28520 -- Emit an error concerning pragma Prag that illegaly applies to an
28521 -- expression function.
28523 -------------------------------
28524 -- Expression_Function_Error --
28525 -------------------------------
28527 procedure Expression_Function_Error is
28529 Error_Msg_Name_1 := Prag_Nam;
28531 -- Emit a precise message to distinguish between source pragmas and
28532 -- pragmas generated from aspects.
28534 if From_Aspect_Specification (Prag) then
28536 ("aspect % cannot apply to a stand alone expression function",
28540 ("pragma % cannot apply to a stand alone expression function",
28543 end Expression_Function_Error;
28547 Context : constant Node_Id := Parent (Prag);
28550 Look_For_Body : constant Boolean :=
28551 Nam_In (Prag_Nam, Name_Refined_Depends,
28552 Name_Refined_Global,
28553 Name_Refined_Post);
28554 -- Refinement pragmas must be associated with a subprogram body [stub]
28556 -- Start of processing for Find_Related_Declaration_Or_Body
28559 Stmt := Prev (Prag);
28560 while Present (Stmt) loop
28562 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28563 -- by splitting a complex pre/postcondition are not considered to
28566 if Nkind (Stmt) = N_Pragma then
28568 and then not Split_PPC (Stmt)
28569 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
28576 -- Emit an error when a refinement pragma appears on an expression
28577 -- function without a completion.
28580 and then Look_For_Body
28581 and then Nkind (Stmt) = N_Subprogram_Declaration
28582 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
28583 and then not Has_Completion (Defining_Entity (Stmt))
28585 Expression_Function_Error;
28588 -- The refinement pragma applies to a subprogram body stub
28590 elsif Look_For_Body
28591 and then Nkind (Stmt) = N_Subprogram_Body_Stub
28595 -- Skip internally generated code
28597 elsif not Comes_From_Source (Stmt) then
28599 -- The anonymous object created for a single concurrent type is a
28600 -- suitable context.
28602 if Nkind (Stmt) = N_Object_Declaration
28603 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
28607 elsif Nkind (Stmt) = N_Subprogram_Declaration then
28609 -- The subprogram declaration is an internally generated spec
28610 -- for an expression function.
28612 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28615 -- The subprogram is actually an instance housed within an
28616 -- anonymous wrapper package.
28618 elsif Present (Generic_Parent (Specification (Stmt))) then
28623 -- Return the current construct which is either a subprogram body,
28624 -- a subprogram declaration or is illegal.
28633 -- If we fall through, then the pragma was either the first declaration
28634 -- or it was preceded by other pragmas and no source constructs.
28636 -- The pragma is associated with a library-level subprogram
28638 if Nkind (Context) = N_Compilation_Unit_Aux then
28639 return Unit (Parent (Context));
28641 -- The pragma appears inside the declarations of an entry body
28643 elsif Nkind (Context) = N_Entry_Body then
28646 -- The pragma appears inside the statements of a subprogram body. This
28647 -- placement is the result of subprogram contract expansion.
28649 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
28650 return Parent (Context);
28652 -- The pragma appears inside the declarative part of a subprogram body
28654 elsif Nkind (Context) = N_Subprogram_Body then
28657 -- The pragma appears inside the declarative part of a task body
28659 elsif Nkind (Context) = N_Task_Body then
28662 -- The pragma is a byproduct of aspect expansion, return the related
28663 -- context of the original aspect. This case has a lower priority as
28664 -- the above circuitry pinpoints precisely the related context.
28666 elsif Present (Corresponding_Aspect (Prag)) then
28667 return Parent (Corresponding_Aspect (Prag));
28669 -- No candidate subprogram [body] found
28674 end Find_Related_Declaration_Or_Body;
28676 ----------------------------------
28677 -- Find_Related_Package_Or_Body --
28678 ----------------------------------
28680 function Find_Related_Package_Or_Body
28682 Do_Checks : Boolean := False) return Node_Id
28684 Context : constant Node_Id := Parent (Prag);
28685 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
28689 Stmt := Prev (Prag);
28690 while Present (Stmt) loop
28692 -- Skip prior pragmas, but check for duplicates
28694 if Nkind (Stmt) = N_Pragma then
28695 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
28701 -- Skip internally generated code
28703 elsif not Comes_From_Source (Stmt) then
28704 if Nkind (Stmt) = N_Subprogram_Declaration then
28706 -- The subprogram declaration is an internally generated spec
28707 -- for an expression function.
28709 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
28712 -- The subprogram is actually an instance housed within an
28713 -- anonymous wrapper package.
28715 elsif Present (Generic_Parent (Specification (Stmt))) then
28720 -- Return the current source construct which is illegal
28729 -- If we fall through, then the pragma was either the first declaration
28730 -- or it was preceded by other pragmas and no source constructs.
28732 -- The pragma is associated with a package. The immediate context in
28733 -- this case is the specification of the package.
28735 if Nkind (Context) = N_Package_Specification then
28736 return Parent (Context);
28738 -- The pragma appears in the declarations of a package body
28740 elsif Nkind (Context) = N_Package_Body then
28743 -- The pragma appears in the statements of a package body
28745 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
28746 and then Nkind (Parent (Context)) = N_Package_Body
28748 return Parent (Context);
28750 -- The pragma is a byproduct of aspect expansion, return the related
28751 -- context of the original aspect. This case has a lower priority as
28752 -- the above circuitry pinpoints precisely the related context.
28754 elsif Present (Corresponding_Aspect (Prag)) then
28755 return Parent (Corresponding_Aspect (Prag));
28757 -- No candidate packge [body] found
28762 end Find_Related_Package_Or_Body;
28768 function Get_Argument
28770 Context_Id : Entity_Id := Empty) return Node_Id
28772 Args : constant List_Id := Pragma_Argument_Associations (Prag);
28775 -- Use the expression of the original aspect when compiling for ASIS or
28776 -- when analyzing the template of a generic unit. In both cases the
28777 -- aspect's tree must be decorated to allow for ASIS queries or to save
28778 -- the global references in the generic context.
28780 if From_Aspect_Specification (Prag)
28781 and then (ASIS_Mode or else (Present (Context_Id)
28782 and then Is_Generic_Unit (Context_Id)))
28784 return Corresponding_Aspect (Prag);
28786 -- Otherwise use the expression of the pragma
28788 elsif Present (Args) then
28789 return First (Args);
28796 -------------------------
28797 -- Get_Base_Subprogram --
28798 -------------------------
28800 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
28801 Result : Entity_Id;
28804 -- Follow subprogram renaming chain
28808 if Is_Subprogram (Result)
28810 Nkind (Parent (Declaration_Node (Result))) =
28811 N_Subprogram_Renaming_Declaration
28812 and then Present (Alias (Result))
28814 Result := Alias (Result);
28818 end Get_Base_Subprogram;
28820 -----------------------
28821 -- Get_SPARK_Mode_Type --
28822 -----------------------
28824 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
28826 if N = Name_On then
28828 elsif N = Name_Off then
28831 -- Any other argument is illegal
28834 raise Program_Error;
28836 end Get_SPARK_Mode_Type;
28838 ------------------------------------
28839 -- Get_SPARK_Mode_From_Annotation --
28840 ------------------------------------
28842 function Get_SPARK_Mode_From_Annotation
28843 (N : Node_Id) return SPARK_Mode_Type
28848 if Nkind (N) = N_Aspect_Specification then
28849 Mode := Expression (N);
28851 else pragma Assert (Nkind (N) = N_Pragma);
28852 Mode := First (Pragma_Argument_Associations (N));
28854 if Present (Mode) then
28855 Mode := Get_Pragma_Arg (Mode);
28859 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28861 if Present (Mode) then
28862 if Nkind (Mode) = N_Identifier then
28863 return Get_SPARK_Mode_Type (Chars (Mode));
28865 -- In case of a malformed aspect or pragma, return the default None
28871 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28876 end Get_SPARK_Mode_From_Annotation;
28878 ---------------------------
28879 -- Has_Extra_Parentheses --
28880 ---------------------------
28882 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28886 -- The aggregate should not have an expression list because a clause
28887 -- is always interpreted as a component association. The only way an
28888 -- expression list can sneak in is by adding extra parentheses around
28889 -- the individual clauses:
28891 -- Depends (Output => Input) -- proper form
28892 -- Depends ((Output => Input)) -- extra parentheses
28894 -- Since the extra parentheses are not allowed by the syntax of the
28895 -- pragma, flag them now to avoid emitting misleading errors down the
28898 if Nkind (Clause) = N_Aggregate
28899 and then Present (Expressions (Clause))
28901 Expr := First (Expressions (Clause));
28902 while Present (Expr) loop
28904 -- A dependency clause surrounded by extra parentheses appears
28905 -- as an aggregate of component associations with an optional
28906 -- Paren_Count set.
28908 if Nkind (Expr) = N_Aggregate
28909 and then Present (Component_Associations (Expr))
28912 ("dependency clause contains extra parentheses", Expr);
28914 -- Otherwise the expression is a malformed construct
28917 SPARK_Msg_N ("malformed dependency clause", Expr);
28927 end Has_Extra_Parentheses;
28933 procedure Initialize is
28944 Dummy := Dummy + 1;
28947 -----------------------------
28948 -- Is_Config_Static_String --
28949 -----------------------------
28951 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28953 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28954 -- This is an internal recursive function that is just like the outer
28955 -- function except that it adds the string to the name buffer rather
28956 -- than placing the string in the name buffer.
28958 ------------------------------
28959 -- Add_Config_Static_String --
28960 ------------------------------
28962 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28969 if Nkind (N) = N_Op_Concat then
28970 if Add_Config_Static_String (Left_Opnd (N)) then
28971 N := Right_Opnd (N);
28977 if Nkind (N) /= N_String_Literal then
28978 Error_Msg_N ("string literal expected for pragma argument", N);
28982 for J in 1 .. String_Length (Strval (N)) loop
28983 C := Get_String_Char (Strval (N), J);
28985 if not In_Character_Range (C) then
28987 ("string literal contains invalid wide character",
28988 Sloc (N) + 1 + Source_Ptr (J));
28992 Add_Char_To_Name_Buffer (Get_Character (C));
28997 end Add_Config_Static_String;
28999 -- Start of processing for Is_Config_Static_String
29004 return Add_Config_Static_String (Arg);
29005 end Is_Config_Static_String;
29007 ---------------------
29008 -- Is_CCT_Instance --
29009 ---------------------
29011 function Is_CCT_Instance
29012 (Ref_Id : Entity_Id;
29013 Context_Id : Entity_Id) return Boolean
29019 -- When the reference denotes a single protected type, the context is
29020 -- either a protected subprogram or its body.
29022 if Is_Single_Protected_Object (Ref_Id) then
29023 Typ := Scope (Context_Id);
29026 Ekind (Typ) = E_Protected_Type
29027 and then Present (Anonymous_Object (Typ))
29028 and then Anonymous_Object (Typ) = Ref_Id;
29030 -- When the reference denotes a single task type, the context is either
29031 -- the same type or if inside the body, the anonymous task type.
29033 elsif Is_Single_Task_Object (Ref_Id) then
29034 if Ekind (Context_Id) = E_Task_Type then
29036 Present (Anonymous_Object (Context_Id))
29037 and then Anonymous_Object (Context_Id) = Ref_Id;
29039 return Ref_Id = Context_Id;
29042 -- Otherwise the reference denotes a protected or a task type. Climb the
29043 -- scope chain looking for an enclosing concurrent type that matches the
29044 -- referenced entity.
29047 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
29049 S := Current_Scope;
29050 while Present (S) and then S /= Standard_Standard loop
29051 if Ekind_In (S, E_Protected_Type, E_Task_Type)
29052 and then S = Ref_Id
29062 end Is_CCT_Instance;
29064 -------------------------------
29065 -- Is_Elaboration_SPARK_Mode --
29066 -------------------------------
29068 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
29071 (Nkind (N) = N_Pragma
29072 and then Pragma_Name (N) = Name_SPARK_Mode
29073 and then Is_List_Member (N));
29075 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29076 -- appears in the statement part of the body.
29079 Present (Parent (N))
29080 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
29081 and then List_Containing (N) = Statements (Parent (N))
29082 and then Present (Parent (Parent (N)))
29083 and then Nkind (Parent (Parent (N))) = N_Package_Body;
29084 end Is_Elaboration_SPARK_Mode;
29086 -----------------------
29087 -- Is_Enabled_Pragma --
29088 -----------------------
29090 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
29094 if Present (Prag) then
29095 Arg := First (Pragma_Argument_Associations (Prag));
29097 if Present (Arg) then
29098 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
29100 -- The lack of a Boolean argument automatically enables the pragma
29106 -- The pragma is missing, therefore it is not enabled
29111 end Is_Enabled_Pragma;
29113 -----------------------------------------
29114 -- Is_Non_Significant_Pragma_Reference --
29115 -----------------------------------------
29117 -- This function makes use of the following static table which indicates
29118 -- whether appearance of some name in a given pragma is to be considered
29119 -- as a reference for the purposes of warnings about unreferenced objects.
29121 -- -1 indicates that appearence in any argument is significant
29122 -- 0 indicates that appearance in any argument is not significant
29123 -- +n indicates that appearance as argument n is significant, but all
29124 -- other arguments are not significant
29125 -- 9n arguments from n on are significant, before n insignificant
29127 Sig_Flags : constant array (Pragma_Id) of Int :=
29128 (Pragma_Abort_Defer => -1,
29129 Pragma_Abstract_State => -1,
29130 Pragma_Ada_83 => -1,
29131 Pragma_Ada_95 => -1,
29132 Pragma_Ada_05 => -1,
29133 Pragma_Ada_2005 => -1,
29134 Pragma_Ada_12 => -1,
29135 Pragma_Ada_2012 => -1,
29136 Pragma_All_Calls_Remote => -1,
29137 Pragma_Allow_Integer_Address => -1,
29138 Pragma_Annotate => 93,
29139 Pragma_Assert => -1,
29140 Pragma_Assert_And_Cut => -1,
29141 Pragma_Assertion_Policy => 0,
29142 Pragma_Assume => -1,
29143 Pragma_Assume_No_Invalid_Values => 0,
29144 Pragma_Async_Readers => 0,
29145 Pragma_Async_Writers => 0,
29146 Pragma_Asynchronous => 0,
29147 Pragma_Atomic => 0,
29148 Pragma_Atomic_Components => 0,
29149 Pragma_Attach_Handler => -1,
29150 Pragma_Attribute_Definition => 92,
29151 Pragma_Check => -1,
29152 Pragma_Check_Float_Overflow => 0,
29153 Pragma_Check_Name => 0,
29154 Pragma_Check_Policy => 0,
29155 Pragma_CPP_Class => 0,
29156 Pragma_CPP_Constructor => 0,
29157 Pragma_CPP_Virtual => 0,
29158 Pragma_CPP_Vtable => 0,
29160 Pragma_C_Pass_By_Copy => 0,
29161 Pragma_Comment => -1,
29162 Pragma_Common_Object => 0,
29163 Pragma_Compile_Time_Error => -1,
29164 Pragma_Compile_Time_Warning => -1,
29165 Pragma_Compiler_Unit => -1,
29166 Pragma_Compiler_Unit_Warning => -1,
29167 Pragma_Complete_Representation => 0,
29168 Pragma_Complex_Representation => 0,
29169 Pragma_Component_Alignment => 0,
29170 Pragma_Constant_After_Elaboration => 0,
29171 Pragma_Contract_Cases => -1,
29172 Pragma_Controlled => 0,
29173 Pragma_Convention => 0,
29174 Pragma_Convention_Identifier => 0,
29175 Pragma_Deadline_Floor => -1,
29176 Pragma_Debug => -1,
29177 Pragma_Debug_Policy => 0,
29178 Pragma_Detect_Blocking => 0,
29179 Pragma_Default_Initial_Condition => -1,
29180 Pragma_Default_Scalar_Storage_Order => 0,
29181 Pragma_Default_Storage_Pool => 0,
29182 Pragma_Depends => -1,
29183 Pragma_Disable_Atomic_Synchronization => 0,
29184 Pragma_Discard_Names => 0,
29185 Pragma_Dispatching_Domain => -1,
29186 Pragma_Effective_Reads => 0,
29187 Pragma_Effective_Writes => 0,
29188 Pragma_Elaborate => 0,
29189 Pragma_Elaborate_All => 0,
29190 Pragma_Elaborate_Body => 0,
29191 Pragma_Elaboration_Checks => 0,
29192 Pragma_Eliminate => 0,
29193 Pragma_Enable_Atomic_Synchronization => 0,
29194 Pragma_Export => -1,
29195 Pragma_Export_Function => -1,
29196 Pragma_Export_Object => -1,
29197 Pragma_Export_Procedure => -1,
29198 Pragma_Export_Value => -1,
29199 Pragma_Export_Valued_Procedure => -1,
29200 Pragma_Extend_System => -1,
29201 Pragma_Extensions_Allowed => 0,
29202 Pragma_Extensions_Visible => 0,
29203 Pragma_External => -1,
29204 Pragma_Favor_Top_Level => 0,
29205 Pragma_External_Name_Casing => 0,
29206 Pragma_Fast_Math => 0,
29207 Pragma_Finalize_Storage_Only => 0,
29209 Pragma_Global => -1,
29210 Pragma_Ident => -1,
29211 Pragma_Ignore_Pragma => 0,
29212 Pragma_Implementation_Defined => -1,
29213 Pragma_Implemented => -1,
29214 Pragma_Implicit_Packing => 0,
29215 Pragma_Import => 93,
29216 Pragma_Import_Function => 0,
29217 Pragma_Import_Object => 0,
29218 Pragma_Import_Procedure => 0,
29219 Pragma_Import_Valued_Procedure => 0,
29220 Pragma_Independent => 0,
29221 Pragma_Independent_Components => 0,
29222 Pragma_Initial_Condition => -1,
29223 Pragma_Initialize_Scalars => 0,
29224 Pragma_Initializes => -1,
29225 Pragma_Inline => 0,
29226 Pragma_Inline_Always => 0,
29227 Pragma_Inline_Generic => 0,
29228 Pragma_Inspection_Point => -1,
29229 Pragma_Interface => 92,
29230 Pragma_Interface_Name => 0,
29231 Pragma_Interrupt_Handler => -1,
29232 Pragma_Interrupt_Priority => -1,
29233 Pragma_Interrupt_State => -1,
29234 Pragma_Invariant => -1,
29235 Pragma_Keep_Names => 0,
29236 Pragma_License => 0,
29237 Pragma_Link_With => -1,
29238 Pragma_Linker_Alias => -1,
29239 Pragma_Linker_Constructor => -1,
29240 Pragma_Linker_Destructor => -1,
29241 Pragma_Linker_Options => -1,
29242 Pragma_Linker_Section => 0,
29244 Pragma_Lock_Free => 0,
29245 Pragma_Locking_Policy => 0,
29246 Pragma_Loop_Invariant => -1,
29247 Pragma_Loop_Optimize => 0,
29248 Pragma_Loop_Variant => -1,
29249 Pragma_Machine_Attribute => -1,
29251 Pragma_Main_Storage => -1,
29252 Pragma_Max_Queue_Length => 0,
29253 Pragma_Memory_Size => 0,
29254 Pragma_No_Return => 0,
29255 Pragma_No_Body => 0,
29256 Pragma_No_Elaboration_Code_All => 0,
29257 Pragma_No_Heap_Finalization => 0,
29258 Pragma_No_Inline => 0,
29259 Pragma_No_Run_Time => -1,
29260 Pragma_No_Strict_Aliasing => -1,
29261 Pragma_No_Tagged_Streams => 0,
29262 Pragma_Normalize_Scalars => 0,
29263 Pragma_Obsolescent => 0,
29264 Pragma_Optimize => 0,
29265 Pragma_Optimize_Alignment => 0,
29266 Pragma_Overflow_Mode => 0,
29267 Pragma_Overriding_Renamings => 0,
29268 Pragma_Ordered => 0,
29271 Pragma_Part_Of => 0,
29272 Pragma_Partition_Elaboration_Policy => 0,
29273 Pragma_Passive => 0,
29274 Pragma_Persistent_BSS => 0,
29275 Pragma_Polling => 0,
29276 Pragma_Prefix_Exception_Messages => 0,
29278 Pragma_Postcondition => -1,
29279 Pragma_Post_Class => -1,
29281 Pragma_Precondition => -1,
29282 Pragma_Predicate => -1,
29283 Pragma_Predicate_Failure => -1,
29284 Pragma_Preelaborable_Initialization => -1,
29285 Pragma_Preelaborate => 0,
29286 Pragma_Pre_Class => -1,
29287 Pragma_Priority => -1,
29288 Pragma_Priority_Specific_Dispatching => 0,
29289 Pragma_Profile => 0,
29290 Pragma_Profile_Warnings => 0,
29291 Pragma_Propagate_Exceptions => 0,
29292 Pragma_Provide_Shift_Operators => 0,
29293 Pragma_Psect_Object => 0,
29295 Pragma_Pure_Function => 0,
29296 Pragma_Queuing_Policy => 0,
29297 Pragma_Rational => 0,
29298 Pragma_Ravenscar => 0,
29299 Pragma_Refined_Depends => -1,
29300 Pragma_Refined_Global => -1,
29301 Pragma_Refined_Post => -1,
29302 Pragma_Refined_State => -1,
29303 Pragma_Relative_Deadline => 0,
29304 Pragma_Rename_Pragma => 0,
29305 Pragma_Remote_Access_Type => -1,
29306 Pragma_Remote_Call_Interface => -1,
29307 Pragma_Remote_Types => -1,
29308 Pragma_Restricted_Run_Time => 0,
29309 Pragma_Restriction_Warnings => 0,
29310 Pragma_Restrictions => 0,
29311 Pragma_Reviewable => -1,
29312 Pragma_Secondary_Stack_Size => -1,
29313 Pragma_Short_Circuit_And_Or => 0,
29314 Pragma_Share_Generic => 0,
29315 Pragma_Shared => 0,
29316 Pragma_Shared_Passive => 0,
29317 Pragma_Short_Descriptors => 0,
29318 Pragma_Simple_Storage_Pool_Type => 0,
29319 Pragma_Source_File_Name => 0,
29320 Pragma_Source_File_Name_Project => 0,
29321 Pragma_Source_Reference => 0,
29322 Pragma_SPARK_Mode => 0,
29323 Pragma_Storage_Size => -1,
29324 Pragma_Storage_Unit => 0,
29325 Pragma_Static_Elaboration_Desired => 0,
29326 Pragma_Stream_Convert => 0,
29327 Pragma_Style_Checks => 0,
29328 Pragma_Subtitle => 0,
29329 Pragma_Suppress => 0,
29330 Pragma_Suppress_Exception_Locations => 0,
29331 Pragma_Suppress_All => 0,
29332 Pragma_Suppress_Debug_Info => 0,
29333 Pragma_Suppress_Initialization => 0,
29334 Pragma_System_Name => 0,
29335 Pragma_Task_Dispatching_Policy => 0,
29336 Pragma_Task_Info => -1,
29337 Pragma_Task_Name => -1,
29338 Pragma_Task_Storage => -1,
29339 Pragma_Test_Case => -1,
29340 Pragma_Thread_Local_Storage => -1,
29341 Pragma_Time_Slice => -1,
29343 Pragma_Type_Invariant => -1,
29344 Pragma_Type_Invariant_Class => -1,
29345 Pragma_Unchecked_Union => 0,
29346 Pragma_Unevaluated_Use_Of_Old => 0,
29347 Pragma_Unimplemented_Unit => 0,
29348 Pragma_Universal_Aliasing => 0,
29349 Pragma_Universal_Data => 0,
29350 Pragma_Unmodified => 0,
29351 Pragma_Unreferenced => 0,
29352 Pragma_Unreferenced_Objects => 0,
29353 Pragma_Unreserve_All_Interrupts => 0,
29354 Pragma_Unsuppress => 0,
29355 Pragma_Unused => 0,
29356 Pragma_Use_VADS_Size => 0,
29357 Pragma_Validity_Checks => 0,
29358 Pragma_Volatile => 0,
29359 Pragma_Volatile_Components => 0,
29360 Pragma_Volatile_Full_Access => 0,
29361 Pragma_Volatile_Function => 0,
29362 Pragma_Warning_As_Error => 0,
29363 Pragma_Warnings => 0,
29364 Pragma_Weak_External => 0,
29365 Pragma_Wide_Character_Encoding => 0,
29366 Unknown_Pragma => 0);
29368 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
29374 function Arg_No return Nat;
29375 -- Returns an integer showing what argument we are in. A value of
29376 -- zero means we are not in any of the arguments.
29382 function Arg_No return Nat is
29387 A := First (Pragma_Argument_Associations (Parent (P)));
29401 -- Start of processing for Non_Significant_Pragma_Reference
29406 if Nkind (P) /= N_Pragma_Argument_Association then
29410 Id := Get_Pragma_Id (Parent (P));
29411 C := Sig_Flags (Id);
29426 return AN < (C - 90);
29432 end Is_Non_Significant_Pragma_Reference;
29434 ------------------------------
29435 -- Is_Pragma_String_Literal --
29436 ------------------------------
29438 -- This function returns true if the corresponding pragma argument is a
29439 -- static string expression. These are the only cases in which string
29440 -- literals can appear as pragma arguments. We also allow a string literal
29441 -- as the first argument to pragma Assert (although it will of course
29442 -- always generate a type error).
29444 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
29445 Pragn : constant Node_Id := Parent (Par);
29446 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
29447 Pname : constant Name_Id := Pragma_Name (Pragn);
29453 N := First (Assoc);
29460 if Pname = Name_Assert then
29463 elsif Pname = Name_Export then
29466 elsif Pname = Name_Ident then
29469 elsif Pname = Name_Import then
29472 elsif Pname = Name_Interface_Name then
29475 elsif Pname = Name_Linker_Alias then
29478 elsif Pname = Name_Linker_Section then
29481 elsif Pname = Name_Machine_Attribute then
29484 elsif Pname = Name_Source_File_Name then
29487 elsif Pname = Name_Source_Reference then
29490 elsif Pname = Name_Title then
29493 elsif Pname = Name_Subtitle then
29499 end Is_Pragma_String_Literal;
29501 ---------------------------
29502 -- Is_Private_SPARK_Mode --
29503 ---------------------------
29505 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
29508 (Nkind (N) = N_Pragma
29509 and then Pragma_Name (N) = Name_SPARK_Mode
29510 and then Is_List_Member (N));
29512 -- For pragma SPARK_Mode to be private, it has to appear in the private
29513 -- declarations of a package.
29516 Present (Parent (N))
29517 and then Nkind (Parent (N)) = N_Package_Specification
29518 and then List_Containing (N) = Private_Declarations (Parent (N));
29519 end Is_Private_SPARK_Mode;
29521 -------------------------------------
29522 -- Is_Unconstrained_Or_Tagged_Item --
29523 -------------------------------------
29525 function Is_Unconstrained_Or_Tagged_Item
29526 (Item : Entity_Id) return Boolean
29528 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
29529 -- Determine whether record type Typ has at least one unconstrained
29532 ---------------------------------
29533 -- Has_Unconstrained_Component --
29534 ---------------------------------
29536 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
29540 Comp := First_Component (Typ);
29541 while Present (Comp) loop
29542 if Is_Unconstrained_Or_Tagged_Item (Comp) then
29546 Next_Component (Comp);
29550 end Has_Unconstrained_Component;
29554 Typ : constant Entity_Id := Etype (Item);
29556 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29559 if Is_Tagged_Type (Typ) then
29562 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
29565 elsif Is_Record_Type (Typ) then
29566 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
29569 return Has_Unconstrained_Component (Typ);
29572 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
29578 end Is_Unconstrained_Or_Tagged_Item;
29580 -----------------------------
29581 -- Is_Valid_Assertion_Kind --
29582 -----------------------------
29584 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
29591 | Name_Assertion_Policy
29592 | Name_Static_Predicate
29593 | Name_Dynamic_Predicate
29598 | Name_Type_Invariant
29599 | Name_uType_Invariant
29603 | Name_Assert_And_Cut
29605 | Name_Contract_Cases
29607 | Name_Default_Initial_Condition
29609 | Name_Initial_Condition
29612 | Name_Loop_Invariant
29613 | Name_Loop_Variant
29614 | Name_Postcondition
29615 | Name_Precondition
29617 | Name_Refined_Post
29618 | Name_Statement_Assertions
29625 end Is_Valid_Assertion_Kind;
29627 --------------------------------------
29628 -- Process_Compilation_Unit_Pragmas --
29629 --------------------------------------
29631 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
29633 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29634 -- strange because it comes at the end of the unit. Rational has the
29635 -- same name for a pragma, but treats it as a program unit pragma, In
29636 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29637 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29638 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29639 -- the context clause to ensure the correct processing.
29641 if Has_Pragma_Suppress_All (N) then
29642 Prepend_To (Context_Items (N),
29643 Make_Pragma (Sloc (N),
29644 Chars => Name_Suppress,
29645 Pragma_Argument_Associations => New_List (
29646 Make_Pragma_Argument_Association (Sloc (N),
29647 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
29650 -- Nothing else to do at the current time
29652 end Process_Compilation_Unit_Pragmas;
29654 -------------------------------------------
29655 -- Process_Compile_Time_Warning_Or_Error --
29656 -------------------------------------------
29658 procedure Process_Compile_Time_Warning_Or_Error
29662 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
29663 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
29664 Arg2 : constant Node_Id := Next (Arg1);
29667 Analyze_And_Resolve (Arg1x, Standard_Boolean);
29669 if Compile_Time_Known_Value (Arg1x) then
29670 if Is_True (Expr_Value (Arg1x)) then
29672 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
29673 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
29674 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
29675 Str : constant String_Id := Strval (Get_Pragma_Arg (Arg2));
29676 Str_Len : constant Nat := String_Length (Str);
29678 Force : constant Boolean :=
29679 Prag_Id = Pragma_Compile_Time_Warning
29680 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
29681 and then (Ekind (Cent) /= E_Package
29682 or else not In_Private_Part (Cent));
29683 -- Set True if this is the warning case, and we are in the
29684 -- visible part of a package spec, or in a subprogram spec,
29685 -- in which case we want to force the client to see the
29686 -- warning, even though it is not in the main unit.
29694 -- Loop through segments of message separated by line feeds.
29695 -- We output these segments as separate messages with
29696 -- continuation marks for all but the first.
29701 Error_Msg_Strlen := 0;
29703 -- Loop to copy characters from argument to error message
29707 exit when Ptr > Str_Len;
29708 CC := Get_String_Char (Str, Ptr);
29711 -- Ignore wide chars ??? else store character
29713 if In_Character_Range (CC) then
29714 C := Get_Character (CC);
29715 exit when C = ASCII.LF;
29716 Error_Msg_Strlen := Error_Msg_Strlen + 1;
29717 Error_Msg_String (Error_Msg_Strlen) := C;
29721 -- Here with one line ready to go
29723 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
29725 -- If this is a warning in a spec, then we want clients
29726 -- to see the warning, so mark the message with the
29727 -- special sequence !! to force the warning. In the case
29728 -- of a package spec, we do not force this if we are in
29729 -- the private part of the spec.
29732 if Cont = False then
29733 Error_Msg ("<<~!!", Eloc);
29736 Error_Msg ("\<<~!!", Eloc);
29739 -- Error, rather than warning, or in a body, so we do not
29740 -- need to force visibility for client (error will be
29741 -- output in any case, and this is the situation in which
29742 -- we do not want a client to get a warning, since the
29743 -- warning is in the body or the spec private part).
29746 if Cont = False then
29747 Error_Msg ("<<~", Eloc);
29750 Error_Msg ("\<<~", Eloc);
29754 exit when Ptr > Str_Len;
29759 end Process_Compile_Time_Warning_Or_Error;
29761 ------------------------------------
29762 -- Record_Possible_Body_Reference --
29763 ------------------------------------
29765 procedure Record_Possible_Body_Reference
29766 (State_Id : Entity_Id;
29770 Spec_Id : Entity_Id;
29773 -- Ensure that we are dealing with a reference to a state
29775 pragma Assert (Ekind (State_Id) = E_Abstract_State);
29777 -- Climb the tree starting from the reference looking for a package body
29778 -- whose spec declares the referenced state. This criteria automatically
29779 -- excludes references in package specs which are legal. Note that it is
29780 -- not wise to emit an error now as the package body may lack pragma
29781 -- Refined_State or the referenced state may not be mentioned in the
29782 -- refinement. This approach avoids the generation of misleading errors.
29785 while Present (Context) loop
29786 if Nkind (Context) = N_Package_Body then
29787 Spec_Id := Corresponding_Spec (Context);
29789 if Present (Abstract_States (Spec_Id))
29790 and then Contains (Abstract_States (Spec_Id), State_Id)
29792 if No (Body_References (State_Id)) then
29793 Set_Body_References (State_Id, New_Elmt_List);
29796 Append_Elmt (Ref, To => Body_References (State_Id));
29801 Context := Parent (Context);
29803 end Record_Possible_Body_Reference;
29805 ------------------------------------------
29806 -- Relocate_Pragmas_To_Anonymous_Object --
29807 ------------------------------------------
29809 procedure Relocate_Pragmas_To_Anonymous_Object
29810 (Typ_Decl : Node_Id;
29811 Obj_Decl : Node_Id)
29815 Next_Decl : Node_Id;
29818 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
29819 Def := Protected_Definition (Typ_Decl);
29821 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
29822 Def := Task_Definition (Typ_Decl);
29825 -- The concurrent definition has a visible declaration list. Inspect it
29826 -- and relocate all canidate pragmas.
29828 if Present (Def) and then Present (Visible_Declarations (Def)) then
29829 Decl := First (Visible_Declarations (Def));
29830 while Present (Decl) loop
29832 -- Preserve the following declaration for iteration purposes due
29833 -- to possible relocation of a pragma.
29835 Next_Decl := Next (Decl);
29837 if Nkind (Decl) = N_Pragma
29838 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
29841 Insert_After (Obj_Decl, Decl);
29843 -- Skip internally generated code
29845 elsif not Comes_From_Source (Decl) then
29848 -- No candidate pragmas are available for relocation
29857 end Relocate_Pragmas_To_Anonymous_Object;
29859 ------------------------------
29860 -- Relocate_Pragmas_To_Body --
29861 ------------------------------
29863 procedure Relocate_Pragmas_To_Body
29864 (Subp_Body : Node_Id;
29865 Target_Body : Node_Id := Empty)
29867 procedure Relocate_Pragma (Prag : Node_Id);
29868 -- Remove a single pragma from its current list and add it to the
29869 -- declarations of the proper body (either Subp_Body or Target_Body).
29871 ---------------------
29872 -- Relocate_Pragma --
29873 ---------------------
29875 procedure Relocate_Pragma (Prag : Node_Id) is
29880 -- When subprogram stubs or expression functions are involves, the
29881 -- destination declaration list belongs to the proper body.
29883 if Present (Target_Body) then
29884 Target := Target_Body;
29886 Target := Subp_Body;
29889 Decls := Declarations (Target);
29893 Set_Declarations (Target, Decls);
29896 -- Unhook the pragma from its current list
29899 Prepend (Prag, Decls);
29900 end Relocate_Pragma;
29904 Body_Id : constant Entity_Id :=
29905 Defining_Unit_Name (Specification (Subp_Body));
29906 Next_Stmt : Node_Id;
29909 -- Start of processing for Relocate_Pragmas_To_Body
29912 -- Do not process a body that comes from a separate unit as no construct
29913 -- can possibly follow it.
29915 if not Is_List_Member (Subp_Body) then
29918 -- Do not relocate pragmas that follow a stub if the stub does not have
29921 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
29922 and then No (Target_Body)
29926 -- Do not process internally generated routine _Postconditions
29928 elsif Ekind (Body_Id) = E_Procedure
29929 and then Chars (Body_Id) = Name_uPostconditions
29934 -- Look at what is following the body. We are interested in certain kind
29935 -- of pragmas (either from source or byproducts of expansion) that can
29936 -- apply to a body [stub].
29938 Stmt := Next (Subp_Body);
29939 while Present (Stmt) loop
29941 -- Preserve the following statement for iteration purposes due to a
29942 -- possible relocation of a pragma.
29944 Next_Stmt := Next (Stmt);
29946 -- Move a candidate pragma following the body to the declarations of
29949 if Nkind (Stmt) = N_Pragma
29950 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
29952 Relocate_Pragma (Stmt);
29954 -- Skip internally generated code
29956 elsif not Comes_From_Source (Stmt) then
29959 -- No candidate pragmas are available for relocation
29967 end Relocate_Pragmas_To_Body;
29969 -------------------
29970 -- Resolve_State --
29971 -------------------
29973 procedure Resolve_State (N : Node_Id) is
29978 if Is_Entity_Name (N) and then Present (Entity (N)) then
29979 Func := Entity (N);
29981 -- Handle overloading of state names by functions. Traverse the
29982 -- homonym chain looking for an abstract state.
29984 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
29985 State := Homonym (Func);
29986 while Present (State) loop
29988 -- Resolve the overloading by setting the proper entity of the
29989 -- reference to that of the state.
29991 if Ekind (State) = E_Abstract_State then
29992 Set_Etype (N, Standard_Void_Type);
29993 Set_Entity (N, State);
29994 Set_Associated_Node (N, State);
29998 State := Homonym (State);
30001 -- A function can never act as a state. If the homonym chain does
30002 -- not contain a corresponding state, then something went wrong in
30003 -- the overloading mechanism.
30005 raise Program_Error;
30010 ----------------------------
30011 -- Rewrite_Assertion_Kind --
30012 ----------------------------
30014 procedure Rewrite_Assertion_Kind
30016 From_Policy : Boolean := False)
30022 if Nkind (N) = N_Attribute_Reference
30023 and then Attribute_Name (N) = Name_Class
30024 and then Nkind (Prefix (N)) = N_Identifier
30026 case Chars (Prefix (N)) is
30033 when Name_Type_Invariant =>
30034 Nam := Name_uType_Invariant;
30036 when Name_Invariant =>
30037 Nam := Name_uInvariant;
30043 -- Recommend standard use of aspect names Pre/Post
30045 elsif Nkind (N) = N_Identifier
30046 and then From_Policy
30047 and then Serious_Errors_Detected = 0
30048 and then not ASIS_Mode
30050 if Chars (N) = Name_Precondition
30051 or else Chars (N) = Name_Postcondition
30053 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
30055 ("\use Assertion_Policy and aspect names Pre/Post for "
30056 & "Ada2012 conformance?", N);
30062 if Nam /= No_Name then
30063 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
30065 end Rewrite_Assertion_Kind;
30073 Dummy := Dummy + 1;
30076 --------------------------------
30077 -- Set_Encoded_Interface_Name --
30078 --------------------------------
30080 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
30081 Str : constant String_Id := Strval (S);
30082 Len : constant Nat := String_Length (Str);
30087 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
30090 -- Stores encoded value of character code CC. The encoding we use an
30091 -- underscore followed by four lower case hex digits.
30097 procedure Encode is
30099 Store_String_Char (Get_Char_Code ('_'));
30101 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
30103 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
30105 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
30107 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
30110 -- Start of processing for Set_Encoded_Interface_Name
30113 -- If first character is asterisk, this is a link name, and we leave it
30114 -- completely unmodified. We also ignore null strings (the latter case
30115 -- happens only in error cases).
30118 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
30120 Set_Interface_Name (E, S);
30125 CC := Get_String_Char (Str, J);
30127 exit when not In_Character_Range (CC);
30129 C := Get_Character (CC);
30131 exit when C /= '_' and then C /= '$'
30132 and then C not in '0' .. '9'
30133 and then C not in 'a' .. 'z'
30134 and then C not in 'A' .. 'Z';
30137 Set_Interface_Name (E, S);
30145 -- Here we need to encode. The encoding we use as follows:
30146 -- three underscores + four hex digits (lower case)
30150 for J in 1 .. String_Length (Str) loop
30151 CC := Get_String_Char (Str, J);
30153 if not In_Character_Range (CC) then
30156 C := Get_Character (CC);
30158 if C = '_' or else C = '$'
30159 or else C in '0' .. '9'
30160 or else C in 'a' .. 'z'
30161 or else C in 'A' .. 'Z'
30163 Store_String_Char (CC);
30170 Set_Interface_Name (E,
30171 Make_String_Literal (Sloc (S),
30172 Strval => End_String));
30174 end Set_Encoded_Interface_Name;
30176 ------------------------
30177 -- Set_Elab_Unit_Name --
30178 ------------------------
30180 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
30185 if Nkind (N) = N_Identifier
30186 and then Nkind (With_Item) = N_Identifier
30188 Set_Entity (N, Entity (With_Item));
30190 elsif Nkind (N) = N_Selected_Component then
30191 Change_Selected_Component_To_Expanded_Name (N);
30192 Set_Entity (N, Entity (With_Item));
30193 Set_Entity (Selector_Name (N), Entity (N));
30195 Pref := Prefix (N);
30196 Scop := Scope (Entity (N));
30197 while Nkind (Pref) = N_Selected_Component loop
30198 Change_Selected_Component_To_Expanded_Name (Pref);
30199 Set_Entity (Selector_Name (Pref), Scop);
30200 Set_Entity (Pref, Scop);
30201 Pref := Prefix (Pref);
30202 Scop := Scope (Scop);
30205 Set_Entity (Pref, Scop);
30208 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
30209 end Set_Elab_Unit_Name;
30211 -------------------
30212 -- Test_Case_Arg --
30213 -------------------
30215 function Test_Case_Arg
30218 From_Aspect : Boolean := False) return Node_Id
30220 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
30225 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
30230 -- The caller requests the aspect argument
30232 if From_Aspect then
30233 if Present (Aspect)
30234 and then Nkind (Expression (Aspect)) = N_Aggregate
30236 Args := Expression (Aspect);
30238 -- "Name" and "Mode" may appear without an identifier as a
30239 -- positional association.
30241 if Present (Expressions (Args)) then
30242 Arg := First (Expressions (Args));
30244 if Present (Arg) and then Arg_Nam = Name_Name then
30252 if Present (Arg) and then Arg_Nam = Name_Mode then
30257 -- Some or all arguments may appear as component associatons
30259 if Present (Component_Associations (Args)) then
30260 Arg := First (Component_Associations (Args));
30261 while Present (Arg) loop
30262 if Chars (First (Choices (Arg))) = Arg_Nam then
30271 -- Otherwise retrieve the argument directly from the pragma
30274 Arg := First (Pragma_Argument_Associations (Prag));
30276 if Present (Arg) and then Arg_Nam = Name_Name then
30280 -- Skip argument "Name"
30284 if Present (Arg) and then Arg_Nam = Name_Mode then
30288 -- Skip argument "Mode"
30292 -- Arguments "Requires" and "Ensures" are optional and may not be
30295 while Present (Arg) loop
30296 if Chars (Arg) = Arg_Nam then