1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Ghost; use Ghost;
47 with Lib.Writ; use Lib.Writ;
48 with Lib.Xref; use Lib.Xref;
49 with Namet.Sp; use Namet.Sp;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
52 with Output; use Output;
53 with Par_SCO; use Par_SCO;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch12; use Sem_Ch12;
63 with Sem_Ch13; use Sem_Ch13;
64 with Sem_Disp; use Sem_Disp;
65 with Sem_Dist; use Sem_Dist;
66 with Sem_Elim; use Sem_Elim;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Intr; use Sem_Intr;
69 with Sem_Mech; use Sem_Mech;
70 with Sem_Res; use Sem_Res;
71 with Sem_Type; use Sem_Type;
72 with Sem_Util; use Sem_Util;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all lower case letters.
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 procedure Analyze_Part_Of
181 Encap_Id : out Entity_Id;
182 Legal : out Boolean);
183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
186 -- package instantiation. Encap denotes the encapsulating state or single
187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
188 -- the indicator is legal.
190 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
192 -- Query whether a particular item appears in a mixed list of nodes and
193 -- entities. It is assumed that all nodes in the list have entities.
195 procedure Check_Postcondition_Use_In_Inlined_Subprogram
197 Spec_Id : Entity_Id);
198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
202 procedure Check_State_And_Constituent_Use
206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
207 -- Global and Initializes. Determine whether a state from list States and a
208 -- corresponding constituent from list Constits (if any) appear in the same
209 -- context denoted by Context. If this is the case, emit an error.
211 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
212 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
213 -- Prag that duplicates previous pragma Prev.
215 function Find_Related_Context
217 Do_Checks : Boolean := False) return Node_Id;
218 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
219 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
220 -- Part_Of. Find the first source declaration or statement found while
221 -- traversing the previous node chain starting from pragma Prag. If flag
222 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
223 -- returns Empty when reaching the start of the node chain.
225 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
226 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
227 -- original one, following the renaming chain) is returned. Otherwise the
228 -- entity is returned unchanged. Should be in Einfo???
230 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
231 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
232 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
235 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
236 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
237 -- Determine whether dependency clause Clause is surrounded by extra
238 -- parentheses. If this is the case, issue an error message.
240 function Is_CCT_Instance (Ref : Node_Id) return Boolean;
241 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
242 -- Global. Determine whether reference Ref denotes the current instance of
243 -- a concurrent type.
245 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
246 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
247 -- pragma Depends. Determine whether the type of dependency item Item is
248 -- tagged, unconstrained array, unconstrained record or a record with at
249 -- least one unconstrained component.
251 procedure Record_Possible_Body_Reference
252 (State_Id : Entity_Id;
254 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
255 -- Global. Given an abstract state denoted by State_Id and a reference Ref
256 -- to it, determine whether the reference appears in a package body that
257 -- will eventually refine the state. If this is the case, record the
258 -- reference for future checks (see Analyze_Refined_State_In_Decls).
260 procedure Resolve_State (N : Node_Id);
261 -- Handle the overloading of state names by functions. When N denotes a
262 -- function, this routine finds the corresponding state and sets the entity
263 -- of N to that of the state.
265 procedure Rewrite_Assertion_Kind (N : Node_Id);
266 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
267 -- then it is rewritten as an identifier with the corresponding special
268 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
271 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
272 -- Place semantic information on the argument of an Elaborate/Elaborate_All
273 -- pragma. Entity name for unit and its parents is taken from item in
274 -- previous with_clause that mentions the unit.
276 Dummy : Integer := 0;
277 pragma Volatile (Dummy);
278 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
281 pragma No_Inline (ip);
282 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
283 -- is just to help debugging the front end. If a pragma Inspection_Point
284 -- is added to a source program, then breaking on ip will get you to that
285 -- point in the program.
288 pragma No_Inline (rv);
289 -- This is a dummy function called by the processing for pragma Reviewable.
290 -- It is there for assisting front end debugging. By placing a Reviewable
291 -- pragma in the source program, a breakpoint on rv catches this place in
292 -- the source, allowing convenient stepping to the point of interest.
294 -------------------------------
295 -- Adjust_External_Name_Case --
296 -------------------------------
298 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
302 -- Adjust case of literal if required
304 if Opt.External_Name_Exp_Casing = As_Is then
308 -- Copy existing string
314 for J in 1 .. String_Length (Strval (N)) loop
315 CC := Get_String_Char (Strval (N), J);
317 if Opt.External_Name_Exp_Casing = Uppercase
318 and then CC >= Get_Char_Code ('a')
319 and then CC <= Get_Char_Code ('z')
321 Store_String_Char (CC - 32);
323 elsif Opt.External_Name_Exp_Casing = Lowercase
324 and then CC >= Get_Char_Code ('A')
325 and then CC <= Get_Char_Code ('Z')
327 Store_String_Char (CC + 32);
330 Store_String_Char (CC);
335 Make_String_Literal (Sloc (N),
336 Strval => End_String);
338 end Adjust_External_Name_Case;
340 -----------------------------------------
341 -- Analyze_Contract_Cases_In_Decl_Part --
342 -----------------------------------------
344 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
345 Others_Seen : Boolean := False;
347 procedure Analyze_Contract_Case (CCase : Node_Id);
348 -- Verify the legality of a single contract case
350 ---------------------------
351 -- Analyze_Contract_Case --
352 ---------------------------
354 procedure Analyze_Contract_Case (CCase : Node_Id) is
355 Case_Guard : Node_Id;
357 Extra_Guard : Node_Id;
360 if Nkind (CCase) = N_Component_Association then
361 Case_Guard := First (Choices (CCase));
362 Conseq := Expression (CCase);
364 -- Each contract case must have exactly one case guard
366 Extra_Guard := Next (Case_Guard);
368 if Present (Extra_Guard) then
370 ("contract case must have exactly one case guard",
374 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
376 if Nkind (Case_Guard) = N_Others_Choice then
379 ("only one others choice allowed in contract cases",
385 elsif Others_Seen then
387 ("others must be the last choice in contract cases", N);
390 -- Preanalyze the case guard and consequence
392 if Nkind (Case_Guard) /= N_Others_Choice then
393 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
396 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
398 -- The contract case is malformed
401 Error_Msg_N ("wrong syntax in contract case", CCase);
403 end Analyze_Contract_Case;
407 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
408 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
409 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
411 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
414 Restore_Scope : Boolean := False;
416 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
419 -- Do not analyze the pragma multiple times
421 if Is_Analyzed_Pragma (N) then
425 -- Set the Ghost mode in effect from the pragma. Due to the delayed
426 -- analysis of the pragma, the Ghost mode at point of declaration and
427 -- point of analysis may not necessarely be the same. Use the mode in
428 -- effect at the point of declaration.
432 -- Single and multiple contract cases must appear in aggregate form. If
433 -- this is not the case, then either the parser of the analysis of the
434 -- pragma failed to produce an aggregate.
436 pragma Assert (Nkind (CCases) = N_Aggregate);
438 if Present (Component_Associations (CCases)) then
440 -- Ensure that the formal parameters are visible when analyzing all
441 -- clauses. This falls out of the general rule of aspects pertaining
442 -- to subprogram declarations.
444 if not In_Open_Scopes (Spec_Id) then
445 Restore_Scope := True;
446 Push_Scope (Spec_Id);
448 if Is_Generic_Subprogram (Spec_Id) then
449 Install_Generic_Formals (Spec_Id);
451 Install_Formals (Spec_Id);
455 CCase := First (Component_Associations (CCases));
456 while Present (CCase) loop
457 Analyze_Contract_Case (CCase);
461 if Restore_Scope then
465 -- Currently it is not possible to inline pre/postconditions on a
466 -- subprogram subject to pragma Inline_Always.
468 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
470 -- Otherwise the pragma is illegal
473 Error_Msg_N ("wrong syntax for constract cases", N);
476 Ghost_Mode := Save_Ghost_Mode;
477 Set_Is_Analyzed_Pragma (N);
478 end Analyze_Contract_Cases_In_Decl_Part;
480 ----------------------------------
481 -- Analyze_Depends_In_Decl_Part --
482 ----------------------------------
484 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
485 Loc : constant Source_Ptr := Sloc (N);
486 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
487 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
489 All_Inputs_Seen : Elist_Id := No_Elist;
490 -- A list containing the entities of all the inputs processed so far.
491 -- The list is populated with unique entities because the same input
492 -- may appear in multiple input lists.
494 All_Outputs_Seen : Elist_Id := No_Elist;
495 -- A list containing the entities of all the outputs processed so far.
496 -- The list is populated with unique entities because output items are
497 -- unique in a dependence relation.
499 Constits_Seen : Elist_Id := No_Elist;
500 -- A list containing the entities of all constituents processed so far.
501 -- It aids in detecting illegal usage of a state and a corresponding
502 -- constituent in pragma [Refinde_]Depends.
504 Global_Seen : Boolean := False;
505 -- A flag set when pragma Global has been processed
507 Null_Output_Seen : Boolean := False;
508 -- A flag used to track the legality of a null output
510 Result_Seen : Boolean := False;
511 -- A flag set when Spec_Id'Result is processed
513 States_Seen : Elist_Id := No_Elist;
514 -- A list containing the entities of all states processed so far. It
515 -- helps in detecting illegal usage of a state and a corresponding
516 -- constituent in pragma [Refined_]Depends.
518 Subp_Inputs : Elist_Id := No_Elist;
519 Subp_Outputs : Elist_Id := No_Elist;
520 -- Two lists containing the full set of inputs and output of the related
521 -- subprograms. Note that these lists contain both nodes and entities.
523 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
524 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
525 -- to the name buffer. The individual kinds are as follows:
526 -- E_Abstract_State - "state"
527 -- E_Constant - "constant"
528 -- E_Discriminant - "discriminant"
529 -- E_Generic_In_Out_Parameter - "generic parameter"
530 -- E_Generic_Out_Parameter - "generic parameter"
531 -- E_In_Parameter - "parameter"
532 -- E_In_Out_Parameter - "parameter"
533 -- E_Out_Parameter - "parameter"
534 -- E_Protected_Type - "current instance of protected type"
535 -- E_Task_Type - "current instance of task type"
536 -- E_Variable - "global"
538 procedure Analyze_Dependency_Clause
541 -- Verify the legality of a single dependency clause. Flag Is_Last
542 -- denotes whether Clause is the last clause in the relation.
544 procedure Check_Function_Return;
545 -- Verify that Funtion'Result appears as one of the outputs
546 -- (SPARK RM 6.1.5(10)).
553 -- Ensure that an item fulfils its designated input and/or output role
554 -- as specified by pragma Global (if any) or the enclosing context. If
555 -- this is not the case, emit an error. Item and Item_Id denote the
556 -- attributes of an item. Flag Is_Input should be set when item comes
557 -- from an input list. Flag Self_Ref should be set when the item is an
558 -- output and the dependency clause has operator "+".
560 procedure Check_Usage
561 (Subp_Items : Elist_Id;
562 Used_Items : Elist_Id;
564 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
565 -- error if this is not the case.
567 procedure Normalize_Clause (Clause : Node_Id);
568 -- Remove a self-dependency "+" from the input list of a clause
570 -----------------------------
571 -- Add_Item_To_Name_Buffer --
572 -----------------------------
574 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
576 if Ekind (Item_Id) = E_Abstract_State then
577 Add_Str_To_Name_Buffer ("state");
579 elsif Ekind (Item_Id) = E_Constant then
580 Add_Str_To_Name_Buffer ("constant");
582 elsif Ekind (Item_Id) = E_Discriminant then
583 Add_Str_To_Name_Buffer ("discriminant");
585 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
586 E_Generic_In_Parameter)
588 Add_Str_To_Name_Buffer ("generic parameter");
590 elsif Is_Formal (Item_Id) then
591 Add_Str_To_Name_Buffer ("parameter");
593 elsif Ekind (Item_Id) = E_Protected_Type then
594 Add_Str_To_Name_Buffer ("current instance of protected type");
596 elsif Ekind (Item_Id) = E_Task_Type then
597 Add_Str_To_Name_Buffer ("current instance of task type");
599 elsif Ekind (Item_Id) = E_Variable then
600 Add_Str_To_Name_Buffer ("global");
602 -- The routine should not be called with non-SPARK items
607 end Add_Item_To_Name_Buffer;
609 -------------------------------
610 -- Analyze_Dependency_Clause --
611 -------------------------------
613 procedure Analyze_Dependency_Clause
617 procedure Analyze_Input_List (Inputs : Node_Id);
618 -- Verify the legality of a single input list
620 procedure Analyze_Input_Output
625 Seen : in out Elist_Id;
626 Null_Seen : in out Boolean;
627 Non_Null_Seen : in out Boolean);
628 -- Verify the legality of a single input or output item. Flag
629 -- Is_Input should be set whenever Item is an input, False when it
630 -- denotes an output. Flag Self_Ref should be set when the item is an
631 -- output and the dependency clause has a "+". Flag Top_Level should
632 -- be set whenever Item appears immediately within an input or output
633 -- list. Seen is a collection of all abstract states, objects and
634 -- formals processed so far. Flag Null_Seen denotes whether a null
635 -- input or output has been encountered. Flag Non_Null_Seen denotes
636 -- whether a non-null input or output has been encountered.
638 ------------------------
639 -- Analyze_Input_List --
640 ------------------------
642 procedure Analyze_Input_List (Inputs : Node_Id) is
643 Inputs_Seen : Elist_Id := No_Elist;
644 -- A list containing the entities of all inputs that appear in the
645 -- current input list.
647 Non_Null_Input_Seen : Boolean := False;
648 Null_Input_Seen : Boolean := False;
649 -- Flags used to check the legality of an input list
654 -- Multiple inputs appear as an aggregate
656 if Nkind (Inputs) = N_Aggregate then
657 if Present (Component_Associations (Inputs)) then
659 ("nested dependency relations not allowed", Inputs);
661 elsif Present (Expressions (Inputs)) then
662 Input := First (Expressions (Inputs));
663 while Present (Input) loop
670 Null_Seen => Null_Input_Seen,
671 Non_Null_Seen => Non_Null_Input_Seen);
676 -- Syntax error, always report
679 Error_Msg_N ("malformed input dependency list", Inputs);
682 -- Process a solitary input
691 Null_Seen => Null_Input_Seen,
692 Non_Null_Seen => Non_Null_Input_Seen);
695 -- Detect an illegal dependency clause of the form
699 if Null_Output_Seen and then Null_Input_Seen then
701 ("null dependency clause cannot have a null input list",
704 end Analyze_Input_List;
706 --------------------------
707 -- Analyze_Input_Output --
708 --------------------------
710 procedure Analyze_Input_Output
715 Seen : in out Elist_Id;
716 Null_Seen : in out Boolean;
717 Non_Null_Seen : in out Boolean)
719 Is_Output : constant Boolean := not Is_Input;
724 -- Multiple input or output items appear as an aggregate
726 if Nkind (Item) = N_Aggregate then
727 if not Top_Level then
728 SPARK_Msg_N ("nested grouping of items not allowed", Item);
730 elsif Present (Component_Associations (Item)) then
732 ("nested dependency relations not allowed", Item);
734 -- Recursively analyze the grouped items
736 elsif Present (Expressions (Item)) then
737 Grouped := First (Expressions (Item));
738 while Present (Grouped) loop
741 Is_Input => Is_Input,
742 Self_Ref => Self_Ref,
745 Null_Seen => Null_Seen,
746 Non_Null_Seen => Non_Null_Seen);
751 -- Syntax error, always report
754 Error_Msg_N ("malformed dependency list", Item);
757 -- Process attribute 'Result in the context of a dependency clause
759 elsif Is_Attribute_Result (Item) then
760 Non_Null_Seen := True;
764 -- Attribute 'Result is allowed to appear on the output side of
765 -- a dependency clause (SPARK RM 6.1.5(6)).
768 SPARK_Msg_N ("function result cannot act as input", Item);
772 ("cannot mix null and non-null dependency items", Item);
778 -- Detect multiple uses of null in a single dependency list or
779 -- throughout the whole relation. Verify the placement of a null
780 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
782 elsif Nkind (Item) = N_Null then
785 ("multiple null dependency relations not allowed", Item);
787 elsif Non_Null_Seen then
789 ("cannot mix null and non-null dependency items", Item);
797 ("null output list must be the last clause in a "
798 & "dependency relation", Item);
800 -- Catch a useless dependence of the form:
805 ("useless dependence, null depends on itself", Item);
813 Non_Null_Seen := True;
816 SPARK_Msg_N ("cannot mix null and non-null items", Item);
820 Resolve_State (Item);
822 -- Find the entity of the item. If this is a renaming, climb
823 -- the renaming chain to reach the root object. Renamings of
824 -- non-entire objects do not yield an entity (Empty).
826 Item_Id := Entity_Of (Item);
828 if Present (Item_Id) then
829 if Ekind_In (Item_Id, E_Abstract_State,
832 E_Generic_In_Out_Parameter,
833 E_Generic_In_Parameter,
841 -- The item denotes a concurrent type, but it is not the
842 -- current instance of an enclosing concurrent type.
844 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
845 and then not Is_CCT_Instance (Item)
848 ("invalid use of subtype mark in dependency "
852 -- Ensure that the item fulfils its role as input and/or
853 -- output as specified by pragma Global or the enclosing
856 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
858 -- Detect multiple uses of the same state, variable or
859 -- formal parameter. If this is not the case, add the
860 -- item to the list of processed relations.
862 if Contains (Seen, Item_Id) then
864 ("duplicate use of item &", Item, Item_Id);
866 Append_New_Elmt (Item_Id, Seen);
869 -- Detect illegal use of an input related to a null
870 -- output. Such input items cannot appear in other
871 -- input lists (SPARK RM 6.1.5(13)).
874 and then Null_Output_Seen
875 and then Contains (All_Inputs_Seen, Item_Id)
878 ("input of a null output list cannot appear in "
879 & "multiple input lists", Item);
882 -- Add an input or a self-referential output to the list
883 -- of all processed inputs.
885 if Is_Input or else Self_Ref then
886 Append_New_Elmt (Item_Id, All_Inputs_Seen);
889 -- State related checks (SPARK RM 6.1.5(3))
891 if Ekind (Item_Id) = E_Abstract_State then
893 -- Package and subprogram bodies are instantiated
894 -- individually in a separate compiler pass. Due to
895 -- this mode of instantiation, the refinement of a
896 -- state may no longer be visible when a subprogram
897 -- body contract is instantiated. Since the generic
898 -- template is legal, do not perform this check in
899 -- the instance to circumvent this oddity.
901 if Is_Generic_Instance (Spec_Id) then
904 -- An abstract state with visible refinement cannot
905 -- appear in pragma [Refined_]Depends as its place
906 -- must be taken by some of its constituents
907 -- (SPARK RM 6.1.4(7)).
909 elsif Has_Visible_Refinement (Item_Id) then
911 ("cannot mention state & in dependence relation",
913 SPARK_Msg_N ("\use its constituents instead", Item);
916 -- If the reference to the abstract state appears in
917 -- an enclosing package body that will eventually
918 -- refine the state, record the reference for future
922 Record_Possible_Body_Reference
923 (State_Id => Item_Id,
928 -- When the item renames an entire object, replace the
929 -- item with a reference to the object.
931 if Entity (Item) /= Item_Id then
933 New_Occurrence_Of (Item_Id, Sloc (Item)));
937 -- Add the entity of the current item to the list of
940 if Ekind (Item_Id) = E_Abstract_State then
941 Append_New_Elmt (Item_Id, States_Seen);
944 if Ekind_In (Item_Id, E_Abstract_State,
947 and then Present (Encapsulating_State (Item_Id))
949 Append_New_Elmt (Item_Id, Constits_Seen);
952 -- All other input/output items are illegal
953 -- (SPARK RM 6.1.5(1)).
957 ("item must denote parameter, variable, state or "
958 & "current instance of concurren type", Item);
961 -- All other input/output items are illegal
962 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
966 ("item must denote parameter, variable, state or current "
967 & "instance of concurrent type", Item);
970 end Analyze_Input_Output;
978 Non_Null_Output_Seen : Boolean := False;
979 -- Flag used to check the legality of an output list
981 -- Start of processing for Analyze_Dependency_Clause
984 Inputs := Expression (Clause);
987 -- An input list with a self-dependency appears as operator "+" where
988 -- the actuals inputs are the right operand.
990 if Nkind (Inputs) = N_Op_Plus then
991 Inputs := Right_Opnd (Inputs);
995 -- Process the output_list of a dependency_clause
997 Output := First (Choices (Clause));
998 while Present (Output) loop
1002 Self_Ref => Self_Ref,
1004 Seen => All_Outputs_Seen,
1005 Null_Seen => Null_Output_Seen,
1006 Non_Null_Seen => Non_Null_Output_Seen);
1011 -- Process the input_list of a dependency_clause
1013 Analyze_Input_List (Inputs);
1014 end Analyze_Dependency_Clause;
1016 ---------------------------
1017 -- Check_Function_Return --
1018 ---------------------------
1020 procedure Check_Function_Return is
1022 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1023 and then not Result_Seen
1026 ("result of & must appear in exactly one output list",
1029 end Check_Function_Return;
1035 procedure Check_Role
1037 Item_Id : Entity_Id;
1042 (Item_Is_Input : out Boolean;
1043 Item_Is_Output : out Boolean);
1044 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1045 -- Item_Is_Output are set depending on the role.
1047 procedure Role_Error
1048 (Item_Is_Input : Boolean;
1049 Item_Is_Output : Boolean);
1050 -- Emit an error message concerning the incorrect use of Item in
1051 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1052 -- denote whether the item is an input and/or an output.
1059 (Item_Is_Input : out Boolean;
1060 Item_Is_Output : out Boolean)
1063 Item_Is_Input := False;
1064 Item_Is_Output := False;
1066 -- Abstract state cases
1068 if Ekind (Item_Id) = E_Abstract_State then
1070 -- When pragma Global is present, the mode of the state may be
1071 -- further constrained by setting a more restrictive mode.
1074 if Appears_In (Subp_Inputs, Item_Id) then
1075 Item_Is_Input := True;
1078 if Appears_In (Subp_Outputs, Item_Id) then
1079 Item_Is_Output := True;
1082 -- Otherwise the state has a default IN OUT mode
1085 Item_Is_Input := True;
1086 Item_Is_Output := True;
1091 elsif Ekind (Item_Id) = E_Constant then
1092 Item_Is_Input := True;
1094 elsif Ekind (Item_Id) = E_Discriminant then
1095 Item_Is_Input := True;
1097 -- Generic parameter cases
1099 elsif Ekind (Item_Id) = E_Generic_In_Parameter then
1100 Item_Is_Input := True;
1102 elsif Ekind (Item_Id) = E_Generic_In_Out_Parameter then
1103 Item_Is_Input := True;
1104 Item_Is_Output := True;
1108 elsif Ekind (Item_Id) = E_In_Parameter then
1109 Item_Is_Input := True;
1111 elsif Ekind (Item_Id) = E_In_Out_Parameter then
1112 Item_Is_Input := True;
1113 Item_Is_Output := True;
1115 elsif Ekind (Item_Id) = E_Out_Parameter then
1116 if Scope (Item_Id) = Spec_Id then
1118 -- An OUT parameter of the related subprogram has mode IN
1119 -- if its type is unconstrained or tagged because array
1120 -- bounds, discriminants or tags can be read.
1122 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1123 Item_Is_Input := True;
1126 Item_Is_Output := True;
1128 -- An OUT parameter of an enclosing subprogram behaves as a
1129 -- read-write variable in which case the mode is IN OUT.
1132 Item_Is_Input := True;
1133 Item_Is_Output := True;
1138 elsif Ekind (Item_Id) = E_Protected_Type then
1140 -- A protected type acts as a formal parameter of mode IN when
1141 -- it applies to a protected function.
1143 if Ekind (Spec_Id) = E_Function then
1144 Item_Is_Input := True;
1146 -- Otherwise the protected type acts as a formal of mode IN OUT
1149 Item_Is_Input := True;
1150 Item_Is_Output := True;
1155 elsif Ekind (Item_Id) = E_Task_Type then
1156 Item_Is_Input := True;
1157 Item_Is_Output := True;
1161 else pragma Assert (Ekind (Item_Id) = E_Variable);
1163 -- When pragma Global is present, the mode of the variable may
1164 -- be further constrained by setting a more restrictive mode.
1168 -- A variable has mode IN when its type is unconstrained or
1169 -- tagged because array bounds, discriminants or tags can be
1172 if Appears_In (Subp_Inputs, Item_Id)
1173 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1175 Item_Is_Input := True;
1178 if Appears_In (Subp_Outputs, Item_Id) then
1179 Item_Is_Output := True;
1182 -- Otherwise the variable has a default IN OUT mode
1185 Item_Is_Input := True;
1186 Item_Is_Output := True;
1195 procedure Role_Error
1196 (Item_Is_Input : Boolean;
1197 Item_Is_Output : Boolean)
1199 Error_Msg : Name_Id;
1204 -- When the item is not part of the input and the output set of
1205 -- the related subprogram, then it appears as extra in pragma
1206 -- [Refined_]Depends.
1208 if not Item_Is_Input and then not Item_Is_Output then
1209 Add_Item_To_Name_Buffer (Item_Id);
1210 Add_Str_To_Name_Buffer
1211 (" & cannot appear in dependence relation");
1213 Error_Msg := Name_Find;
1214 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1216 Error_Msg_Name_1 := Chars (Spec_Id);
1218 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1219 & "set of subprogram %"), Item, Item_Id);
1221 -- The mode of the item and its role in pragma [Refined_]Depends
1222 -- are in conflict. Construct a detailed message explaining the
1223 -- illegality (SPARK RM 6.1.5(5-6)).
1226 if Item_Is_Input then
1227 Add_Str_To_Name_Buffer ("read-only");
1229 Add_Str_To_Name_Buffer ("write-only");
1232 Add_Char_To_Name_Buffer (' ');
1233 Add_Item_To_Name_Buffer (Item_Id);
1234 Add_Str_To_Name_Buffer (" & cannot appear as ");
1236 if Item_Is_Input then
1237 Add_Str_To_Name_Buffer ("output");
1239 Add_Str_To_Name_Buffer ("input");
1242 Add_Str_To_Name_Buffer (" in dependence relation");
1243 Error_Msg := Name_Find;
1244 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1250 Item_Is_Input : Boolean;
1251 Item_Is_Output : Boolean;
1253 -- Start of processing for Check_Role
1256 Find_Role (Item_Is_Input, Item_Is_Output);
1261 if not Item_Is_Input then
1262 Role_Error (Item_Is_Input, Item_Is_Output);
1265 -- Self-referential item
1268 if not Item_Is_Input or else not Item_Is_Output then
1269 Role_Error (Item_Is_Input, Item_Is_Output);
1274 elsif not Item_Is_Output then
1275 Role_Error (Item_Is_Input, Item_Is_Output);
1283 procedure Check_Usage
1284 (Subp_Items : Elist_Id;
1285 Used_Items : Elist_Id;
1288 procedure Usage_Error (Item_Id : Entity_Id);
1289 -- Emit an error concerning the illegal usage of an item
1295 procedure Usage_Error (Item_Id : Entity_Id) is
1296 Error_Msg : Name_Id;
1303 -- Unconstrained and tagged items are not part of the explicit
1304 -- input set of the related subprogram, they do not have to be
1305 -- present in a dependence relation and should not be flagged
1306 -- (SPARK RM 6.1.5(8)).
1308 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1311 Add_Item_To_Name_Buffer (Item_Id);
1312 Add_Str_To_Name_Buffer
1313 (" & is missing from input dependence list");
1315 Error_Msg := Name_Find;
1316 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1319 -- Output case (SPARK RM 6.1.5(10))
1324 Add_Item_To_Name_Buffer (Item_Id);
1325 Add_Str_To_Name_Buffer
1326 (" & is missing from output dependence list");
1328 Error_Msg := Name_Find;
1329 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1337 Item_Id : Entity_Id;
1339 -- Start of processing for Check_Usage
1342 if No (Subp_Items) then
1346 -- Each input or output of the subprogram must appear in a dependency
1349 Elmt := First_Elmt (Subp_Items);
1350 while Present (Elmt) loop
1351 Item := Node (Elmt);
1353 if Nkind (Item) = N_Defining_Identifier then
1356 Item_Id := Entity_Of (Item);
1359 -- The item does not appear in a dependency
1361 if Present (Item_Id)
1362 and then not Contains (Used_Items, Item_Id)
1364 -- The current instance of a concurrent type behaves as a
1365 -- formal parameter (SPARK RM 6.1.4).
1367 if Is_Formal (Item_Id)
1368 or else Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
1370 Usage_Error (Item_Id);
1372 -- States and global objects are not used properly only when
1373 -- the subprogram is subject to pragma Global.
1375 elsif Global_Seen then
1376 Usage_Error (Item_Id);
1384 ----------------------
1385 -- Normalize_Clause --
1386 ----------------------
1388 procedure Normalize_Clause (Clause : Node_Id) is
1389 procedure Create_Or_Modify_Clause
1395 Multiple : Boolean);
1396 -- Create a brand new clause to represent the self-reference or
1397 -- modify the input and/or output lists of an existing clause. Output
1398 -- denotes a self-referencial output. Outputs is the output list of a
1399 -- clause. Inputs is the input list of a clause. After denotes the
1400 -- clause after which the new clause is to be inserted. Flag In_Place
1401 -- should be set when normalizing the last output of an output list.
1402 -- Flag Multiple should be set when Output comes from a list with
1405 -----------------------------
1406 -- Create_Or_Modify_Clause --
1407 -----------------------------
1409 procedure Create_Or_Modify_Clause
1417 procedure Propagate_Output
1420 -- Handle the various cases of output propagation to the input
1421 -- list. Output denotes a self-referencial output item. Inputs
1422 -- is the input list of a clause.
1424 ----------------------
1425 -- Propagate_Output --
1426 ----------------------
1428 procedure Propagate_Output
1432 function In_Input_List
1434 Inputs : List_Id) return Boolean;
1435 -- Determine whether a particulat item appears in the input
1436 -- list of a clause.
1442 function In_Input_List
1444 Inputs : List_Id) return Boolean
1449 Elmt := First (Inputs);
1450 while Present (Elmt) loop
1451 if Entity_Of (Elmt) = Item then
1463 Output_Id : constant Entity_Id := Entity_Of (Output);
1466 -- Start of processing for Propagate_Output
1469 -- The clause is of the form:
1471 -- (Output =>+ null)
1473 -- Remove null input and replace it with a copy of the output:
1475 -- (Output => Output)
1477 if Nkind (Inputs) = N_Null then
1478 Rewrite (Inputs, New_Copy_Tree (Output));
1480 -- The clause is of the form:
1482 -- (Output =>+ (Input1, ..., InputN))
1484 -- Determine whether the output is not already mentioned in the
1485 -- input list and if not, add it to the list of inputs:
1487 -- (Output => (Output, Input1, ..., InputN))
1489 elsif Nkind (Inputs) = N_Aggregate then
1490 Grouped := Expressions (Inputs);
1492 if not In_Input_List
1496 Prepend_To (Grouped, New_Copy_Tree (Output));
1499 -- The clause is of the form:
1501 -- (Output =>+ Input)
1503 -- If the input does not mention the output, group the two
1506 -- (Output => (Output, Input))
1508 elsif Entity_Of (Inputs) /= Output_Id then
1510 Make_Aggregate (Loc,
1511 Expressions => New_List (
1512 New_Copy_Tree (Output),
1513 New_Copy_Tree (Inputs))));
1515 end Propagate_Output;
1519 Loc : constant Source_Ptr := Sloc (Clause);
1520 New_Clause : Node_Id;
1522 -- Start of processing for Create_Or_Modify_Clause
1525 -- A null output depending on itself does not require any
1528 if Nkind (Output) = N_Null then
1531 -- A function result cannot depend on itself because it cannot
1532 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1534 elsif Is_Attribute_Result (Output) then
1535 SPARK_Msg_N ("function result cannot depend on itself", Output);
1539 -- When performing the transformation in place, simply add the
1540 -- output to the list of inputs (if not already there). This
1541 -- case arises when dealing with the last output of an output
1542 -- list. Perform the normalization in place to avoid generating
1543 -- a malformed tree.
1546 Propagate_Output (Output, Inputs);
1548 -- A list with multiple outputs is slowly trimmed until only
1549 -- one element remains. When this happens, replace aggregate
1550 -- with the element itself.
1554 Rewrite (Outputs, Output);
1560 -- Unchain the output from its output list as it will appear in
1561 -- a new clause. Note that we cannot simply rewrite the output
1562 -- as null because this will violate the semantics of pragma
1567 -- Generate a new clause of the form:
1568 -- (Output => Inputs)
1571 Make_Component_Association (Loc,
1572 Choices => New_List (Output),
1573 Expression => New_Copy_Tree (Inputs));
1575 -- The new clause contains replicated content that has already
1576 -- been analyzed. There is not need to reanalyze or renormalize
1579 Set_Analyzed (New_Clause);
1582 (Output => First (Choices (New_Clause)),
1583 Inputs => Expression (New_Clause));
1585 Insert_After (After, New_Clause);
1587 end Create_Or_Modify_Clause;
1591 Outputs : constant Node_Id := First (Choices (Clause));
1593 Last_Output : Node_Id;
1594 Next_Output : Node_Id;
1597 -- Start of processing for Normalize_Clause
1600 -- A self-dependency appears as operator "+". Remove the "+" from the
1601 -- tree by moving the real inputs to their proper place.
1603 if Nkind (Expression (Clause)) = N_Op_Plus then
1604 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1605 Inputs := Expression (Clause);
1607 -- Multiple outputs appear as an aggregate
1609 if Nkind (Outputs) = N_Aggregate then
1610 Last_Output := Last (Expressions (Outputs));
1612 Output := First (Expressions (Outputs));
1613 while Present (Output) loop
1615 -- Normalization may remove an output from its list,
1616 -- preserve the subsequent output now.
1618 Next_Output := Next (Output);
1620 Create_Or_Modify_Clause
1625 In_Place => Output = Last_Output,
1628 Output := Next_Output;
1634 Create_Or_Modify_Clause
1643 end Normalize_Clause;
1647 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1648 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1652 Last_Clause : Node_Id;
1653 Restore_Scope : Boolean := False;
1655 -- Start of processing for Analyze_Depends_In_Decl_Part
1658 -- Do not analyze the pragma multiple times
1660 if Is_Analyzed_Pragma (N) then
1664 -- Empty dependency list
1666 if Nkind (Deps) = N_Null then
1668 -- Gather all states, objects and formal parameters that the
1669 -- subprogram may depend on. These items are obtained from the
1670 -- parameter profile or pragma [Refined_]Global (if available).
1672 Collect_Subprogram_Inputs_Outputs
1673 (Subp_Id => Subp_Id,
1674 Subp_Inputs => Subp_Inputs,
1675 Subp_Outputs => Subp_Outputs,
1676 Global_Seen => Global_Seen);
1678 -- Verify that every input or output of the subprogram appear in a
1681 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1682 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1683 Check_Function_Return;
1685 -- Dependency clauses appear as component associations of an aggregate
1687 elsif Nkind (Deps) = N_Aggregate then
1689 -- Do not attempt to perform analysis of a syntactically illegal
1690 -- clause as this will lead to misleading errors.
1692 if Has_Extra_Parentheses (Deps) then
1696 if Present (Component_Associations (Deps)) then
1697 Last_Clause := Last (Component_Associations (Deps));
1699 -- Gather all states, objects and formal parameters that the
1700 -- subprogram may depend on. These items are obtained from the
1701 -- parameter profile or pragma [Refined_]Global (if available).
1703 Collect_Subprogram_Inputs_Outputs
1704 (Subp_Id => Subp_Id,
1705 Subp_Inputs => Subp_Inputs,
1706 Subp_Outputs => Subp_Outputs,
1707 Global_Seen => Global_Seen);
1709 -- When pragma [Refined_]Depends appears on a single concurrent
1710 -- type, it is relocated to the anonymous object.
1712 if Is_Single_Concurrent_Object (Spec_Id) then
1715 -- Ensure that the formal parameters are visible when analyzing
1716 -- all clauses. This falls out of the general rule of aspects
1717 -- pertaining to subprogram declarations.
1719 elsif not In_Open_Scopes (Spec_Id) then
1720 Restore_Scope := True;
1721 Push_Scope (Spec_Id);
1723 if Ekind (Spec_Id) = E_Task_Type then
1724 if Has_Discriminants (Spec_Id) then
1725 Install_Discriminants (Spec_Id);
1728 elsif Is_Generic_Subprogram (Spec_Id) then
1729 Install_Generic_Formals (Spec_Id);
1732 Install_Formals (Spec_Id);
1736 Clause := First (Component_Associations (Deps));
1737 while Present (Clause) loop
1738 Errors := Serious_Errors_Detected;
1740 -- The normalization mechanism may create extra clauses that
1741 -- contain replicated input and output names. There is no need
1742 -- to reanalyze them.
1744 if not Analyzed (Clause) then
1745 Set_Analyzed (Clause);
1747 Analyze_Dependency_Clause
1749 Is_Last => Clause = Last_Clause);
1752 -- Do not normalize a clause if errors were detected (count
1753 -- of Serious_Errors has increased) because the inputs and/or
1754 -- outputs may denote illegal items. Normalization is disabled
1755 -- in ASIS mode as it alters the tree by introducing new nodes
1756 -- similar to expansion.
1758 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1759 Normalize_Clause (Clause);
1765 if Restore_Scope then
1769 -- Verify that every input or output of the subprogram appear in a
1772 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1773 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1774 Check_Function_Return;
1776 -- The dependency list is malformed. This is a syntax error, always
1780 Error_Msg_N ("malformed dependency relation", Deps);
1784 -- The top level dependency relation is malformed. This is a syntax
1785 -- error, always report.
1788 Error_Msg_N ("malformed dependency relation", Deps);
1792 -- Ensure that a state and a corresponding constituent do not appear
1793 -- together in pragma [Refined_]Depends.
1795 Check_State_And_Constituent_Use
1796 (States => States_Seen,
1797 Constits => Constits_Seen,
1801 Set_Is_Analyzed_Pragma (N);
1802 end Analyze_Depends_In_Decl_Part;
1804 --------------------------------------------
1805 -- Analyze_External_Property_In_Decl_Part --
1806 --------------------------------------------
1808 procedure Analyze_External_Property_In_Decl_Part
1810 Expr_Val : out Boolean)
1812 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1813 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1814 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1820 -- Do not analyze the pragma multiple times
1822 if Is_Analyzed_Pragma (N) then
1826 Error_Msg_Name_1 := Pragma_Name (N);
1828 -- An external property pragma must apply to an effectively volatile
1829 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1830 -- The check is performed at the end of the declarative region due to a
1831 -- possible out-of-order arrangement of pragmas:
1834 -- pragma Async_Readers (Obj);
1835 -- pragma Volatile (Obj);
1837 if not Is_Effectively_Volatile (Obj_Id) then
1839 ("external property % must apply to a volatile object", N);
1842 -- Ensure that the Boolean expression (if present) is static. A missing
1843 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1847 if Present (Arg1) then
1848 Expr := Get_Pragma_Arg (Arg1);
1850 if Is_OK_Static_Expression (Expr) then
1851 Expr_Val := Is_True (Expr_Value (Expr));
1855 Set_Is_Analyzed_Pragma (N);
1856 end Analyze_External_Property_In_Decl_Part;
1858 ---------------------------------
1859 -- Analyze_Global_In_Decl_Part --
1860 ---------------------------------
1862 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1863 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
1864 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
1865 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1867 Constits_Seen : Elist_Id := No_Elist;
1868 -- A list containing the entities of all constituents processed so far.
1869 -- It aids in detecting illegal usage of a state and a corresponding
1870 -- constituent in pragma [Refinde_]Global.
1872 Seen : Elist_Id := No_Elist;
1873 -- A list containing the entities of all the items processed so far. It
1874 -- plays a role in detecting distinct entities.
1876 States_Seen : Elist_Id := No_Elist;
1877 -- A list containing the entities of all states processed so far. It
1878 -- helps in detecting illegal usage of a state and a corresponding
1879 -- constituent in pragma [Refined_]Global.
1881 In_Out_Seen : Boolean := False;
1882 Input_Seen : Boolean := False;
1883 Output_Seen : Boolean := False;
1884 Proof_Seen : Boolean := False;
1885 -- Flags used to verify the consistency of modes
1887 procedure Analyze_Global_List
1889 Global_Mode : Name_Id := Name_Input);
1890 -- Verify the legality of a single global list declaration. Global_Mode
1891 -- denotes the current mode in effect.
1893 -------------------------
1894 -- Analyze_Global_List --
1895 -------------------------
1897 procedure Analyze_Global_List
1899 Global_Mode : Name_Id := Name_Input)
1901 procedure Analyze_Global_Item
1903 Global_Mode : Name_Id);
1904 -- Verify the legality of a single global item declaration denoted by
1905 -- Item. Global_Mode denotes the current mode in effect.
1907 procedure Check_Duplicate_Mode
1909 Status : in out Boolean);
1910 -- Flag Status denotes whether a particular mode has been seen while
1911 -- processing a global list. This routine verifies that Mode is not a
1912 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1914 procedure Check_Mode_Restriction_In_Enclosing_Context
1916 Item_Id : Entity_Id);
1917 -- Verify that an item of mode In_Out or Output does not appear as an
1918 -- input in the Global aspect of an enclosing subprogram. If this is
1919 -- the case, emit an error. Item and Item_Id are respectively the
1920 -- item and its entity.
1922 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1923 -- Mode denotes either In_Out or Output. Depending on the kind of the
1924 -- related subprogram, emit an error if those two modes apply to a
1925 -- function (SPARK RM 6.1.4(10)).
1927 -------------------------
1928 -- Analyze_Global_Item --
1929 -------------------------
1931 procedure Analyze_Global_Item
1933 Global_Mode : Name_Id)
1935 Item_Id : Entity_Id;
1938 -- Detect one of the following cases
1940 -- with Global => (null, Name)
1941 -- with Global => (Name_1, null, Name_2)
1942 -- with Global => (Name, null)
1944 if Nkind (Item) = N_Null then
1945 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
1950 Resolve_State (Item);
1952 -- Find the entity of the item. If this is a renaming, climb the
1953 -- renaming chain to reach the root object. Renamings of non-
1954 -- entire objects do not yield an entity (Empty).
1956 Item_Id := Entity_Of (Item);
1958 if Present (Item_Id) then
1960 -- A global item may denote a formal parameter of an enclosing
1961 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1962 -- provide a better error diagnostic.
1964 if Is_Formal (Item_Id) then
1965 if Scope (Item_Id) = Spec_Id then
1967 (Fix_Msg (Spec_Id, "global item cannot reference "
1968 & "parameter of subprogram &"), Item, Spec_Id);
1972 -- A global item may denote a concurrent type as long as it is
1973 -- the current instance of an enclosing concurrent type
1974 -- (SPARK RM 6.1.4).
1976 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
1977 if Is_CCT_Instance (Item) then
1979 -- Pragma [Refined_]Global associated with a protected
1980 -- subprogram cannot mention the current instance of a
1981 -- protected type because the instance behaves as a
1982 -- formal parameter.
1984 if Ekind (Item_Id) = E_Protected_Type
1985 and then Scope (Spec_Id) = Item_Id
1987 Error_Msg_Name_1 := Chars (Item_Id);
1989 (Fix_Msg (Spec_Id, "global item of subprogram & "
1990 & "cannot reference current instance of protected "
1991 & "type %"), Item, Spec_Id);
1994 -- Pragma [Refined_]Global associated with a task type
1995 -- cannot mention the current instance of a task type
1996 -- because the instance behaves as a formal parameter.
1998 elsif Ekind (Item_Id) = E_Task_Type
1999 and then Spec_Id = Item_Id
2001 Error_Msg_Name_1 := Chars (Item_Id);
2003 (Fix_Msg (Spec_Id, "global item of subprogram & "
2004 & "cannot reference current instance of task type "
2005 & "%"), Item, Spec_Id);
2009 -- Otherwise the global item denotes a subtype mark that is
2010 -- not a current instance.
2014 ("invalid use of subtype mark in global list", Item);
2018 -- A formal object may act as a global item inside a generic
2020 elsif Is_Formal_Object (Item_Id) then
2023 -- The only legal references are those to abstract states,
2024 -- discriminants and objects (SPARK RM 6.1.4(4)).
2026 elsif not Ekind_In (Item_Id, E_Abstract_State,
2032 ("global item must denote object, state or current "
2033 & "instance of concurrent type", Item);
2037 -- State related checks
2039 if Ekind (Item_Id) = E_Abstract_State then
2041 -- Package and subprogram bodies are instantiated
2042 -- individually in a separate compiler pass. Due to this
2043 -- mode of instantiation, the refinement of a state may
2044 -- no longer be visible when a subprogram body contract
2045 -- is instantiated. Since the generic template is legal,
2046 -- do not perform this check in the instance to circumvent
2049 if Is_Generic_Instance (Spec_Id) then
2052 -- An abstract state with visible refinement cannot appear
2053 -- in pragma [Refined_]Global as its place must be taken by
2054 -- some of its constituents (SPARK RM 6.1.4(7)).
2056 elsif Has_Visible_Refinement (Item_Id) then
2058 ("cannot mention state & in global refinement",
2060 SPARK_Msg_N ("\use its constituents instead", Item);
2063 -- An external state cannot appear as a global item of a
2064 -- nonvolatile function (SPARK RM 7.1.3(8)).
2066 elsif Is_External_State (Item_Id)
2067 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2068 and then not Is_Volatile_Function (Spec_Id)
2071 ("external state & cannot act as global item of "
2072 & "nonvolatile function", Item, Item_Id);
2075 -- If the reference to the abstract state appears in an
2076 -- enclosing package body that will eventually refine the
2077 -- state, record the reference for future checks.
2080 Record_Possible_Body_Reference
2081 (State_Id => Item_Id,
2085 -- Constant related checks
2087 elsif Ekind (Item_Id) = E_Constant then
2089 -- A constant is a read-only item, therefore it cannot act
2092 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2094 ("constant & cannot act as output", Item, Item_Id);
2098 -- Discriminant related checks
2100 elsif Ekind (Item_Id) = E_Discriminant then
2102 -- A discriminant is a read-only item, therefore it cannot
2103 -- act as an output.
2105 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2107 ("discriminant & cannot act as output", Item, Item_Id);
2111 -- Variable related checks. These are only relevant when
2112 -- SPARK_Mode is on as they are not standard Ada legality
2115 elsif SPARK_Mode = On
2116 and then Ekind (Item_Id) = E_Variable
2117 and then Is_Effectively_Volatile (Item_Id)
2119 -- An effectively volatile object cannot appear as a global
2120 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2122 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2123 and then not Is_Volatile_Function (Spec_Id)
2126 ("volatile object & cannot act as global item of a "
2127 & "function", Item, Item_Id);
2130 -- An effectively volatile object with external property
2131 -- Effective_Reads set to True must have mode Output or
2132 -- In_Out (SPARK RM 7.1.3(11)).
2134 elsif Effective_Reads_Enabled (Item_Id)
2135 and then Global_Mode = Name_Input
2138 ("volatile object & with property Effective_Reads must "
2139 & "have mode In_Out or Output", Item, Item_Id);
2144 -- When the item renames an entire object, replace the item
2145 -- with a reference to the object.
2147 if Entity (Item) /= Item_Id then
2148 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2152 -- Some form of illegal construct masquerading as a name
2153 -- (SPARK RM 6.1.4(4)).
2157 ("global item must denote object, state or current instance "
2158 & "of concurrent type", Item);
2162 -- Verify that an output does not appear as an input in an
2163 -- enclosing subprogram.
2165 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2166 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2169 -- The same entity might be referenced through various way.
2170 -- Check the entity of the item rather than the item itself
2171 -- (SPARK RM 6.1.4(10)).
2173 if Contains (Seen, Item_Id) then
2174 SPARK_Msg_N ("duplicate global item", Item);
2176 -- Add the entity of the current item to the list of processed
2180 Append_New_Elmt (Item_Id, Seen);
2182 if Ekind (Item_Id) = E_Abstract_State then
2183 Append_New_Elmt (Item_Id, States_Seen);
2186 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2187 and then Present (Encapsulating_State (Item_Id))
2189 Append_New_Elmt (Item_Id, Constits_Seen);
2192 end Analyze_Global_Item;
2194 --------------------------
2195 -- Check_Duplicate_Mode --
2196 --------------------------
2198 procedure Check_Duplicate_Mode
2200 Status : in out Boolean)
2204 SPARK_Msg_N ("duplicate global mode", Mode);
2208 end Check_Duplicate_Mode;
2210 -------------------------------------------------
2211 -- Check_Mode_Restriction_In_Enclosing_Context --
2212 -------------------------------------------------
2214 procedure Check_Mode_Restriction_In_Enclosing_Context
2216 Item_Id : Entity_Id)
2218 Context : Entity_Id;
2220 Inputs : Elist_Id := No_Elist;
2221 Outputs : Elist_Id := No_Elist;
2224 -- Traverse the scope stack looking for enclosing subprograms
2225 -- subject to pragma [Refined_]Global.
2227 Context := Scope (Subp_Id);
2228 while Present (Context) and then Context /= Standard_Standard loop
2229 if Is_Subprogram (Context)
2231 (Present (Get_Pragma (Context, Pragma_Global))
2233 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2235 Collect_Subprogram_Inputs_Outputs
2236 (Subp_Id => Context,
2237 Subp_Inputs => Inputs,
2238 Subp_Outputs => Outputs,
2239 Global_Seen => Dummy);
2241 -- The item is classified as In_Out or Output but appears as
2242 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2244 if Appears_In (Inputs, Item_Id)
2245 and then not Appears_In (Outputs, Item_Id)
2248 ("global item & cannot have mode In_Out or Output",
2252 (Fix_Msg (Subp_Id, "\item already appears as input of "
2253 & "subprogram &"), Item, Context);
2255 -- Stop the traversal once an error has been detected
2261 Context := Scope (Context);
2263 end Check_Mode_Restriction_In_Enclosing_Context;
2265 ----------------------------------------
2266 -- Check_Mode_Restriction_In_Function --
2267 ----------------------------------------
2269 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2271 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2273 ("global mode & is not applicable to functions", Mode);
2275 end Check_Mode_Restriction_In_Function;
2283 -- Start of processing for Analyze_Global_List
2286 if Nkind (List) = N_Null then
2287 Set_Analyzed (List);
2289 -- Single global item declaration
2291 elsif Nkind_In (List, N_Expanded_Name,
2293 N_Selected_Component)
2295 Analyze_Global_Item (List, Global_Mode);
2297 -- Simple global list or moded global list declaration
2299 elsif Nkind (List) = N_Aggregate then
2300 Set_Analyzed (List);
2302 -- The declaration of a simple global list appear as a collection
2305 if Present (Expressions (List)) then
2306 if Present (Component_Associations (List)) then
2308 ("cannot mix moded and non-moded global lists", List);
2311 Item := First (Expressions (List));
2312 while Present (Item) loop
2313 Analyze_Global_Item (Item, Global_Mode);
2317 -- The declaration of a moded global list appears as a collection
2318 -- of component associations where individual choices denote
2321 elsif Present (Component_Associations (List)) then
2322 if Present (Expressions (List)) then
2324 ("cannot mix moded and non-moded global lists", List);
2327 Assoc := First (Component_Associations (List));
2328 while Present (Assoc) loop
2329 Mode := First (Choices (Assoc));
2331 if Nkind (Mode) = N_Identifier then
2332 if Chars (Mode) = Name_In_Out then
2333 Check_Duplicate_Mode (Mode, In_Out_Seen);
2334 Check_Mode_Restriction_In_Function (Mode);
2336 elsif Chars (Mode) = Name_Input then
2337 Check_Duplicate_Mode (Mode, Input_Seen);
2339 elsif Chars (Mode) = Name_Output then
2340 Check_Duplicate_Mode (Mode, Output_Seen);
2341 Check_Mode_Restriction_In_Function (Mode);
2343 elsif Chars (Mode) = Name_Proof_In then
2344 Check_Duplicate_Mode (Mode, Proof_Seen);
2347 SPARK_Msg_N ("invalid mode selector", Mode);
2351 SPARK_Msg_N ("invalid mode selector", Mode);
2354 -- Items in a moded list appear as a collection of
2355 -- expressions. Reuse the existing machinery to analyze
2359 (List => Expression (Assoc),
2360 Global_Mode => Chars (Mode));
2368 raise Program_Error;
2371 -- Any other attempt to declare a global item is illegal. This is a
2372 -- syntax error, always report.
2375 Error_Msg_N ("malformed global list", List);
2377 end Analyze_Global_List;
2381 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2383 Restore_Scope : Boolean := False;
2385 -- Start of processing for Analyze_Global_In_Decl_Part
2388 -- Do not analyze the pragma multiple times
2390 if Is_Analyzed_Pragma (N) then
2394 -- There is nothing to be done for a null global list
2396 if Nkind (Items) = N_Null then
2397 Set_Analyzed (Items);
2399 -- Analyze the various forms of global lists and items. Note that some
2400 -- of these may be malformed in which case the analysis emits error
2404 -- When pragma [Refined_]Global appears on a single concurrent type,
2405 -- it is relocated to the anonymous object.
2407 if Is_Single_Concurrent_Object (Spec_Id) then
2410 -- Ensure that the formal parameters are visible when processing an
2411 -- item. This falls out of the general rule of aspects pertaining to
2412 -- subprogram declarations.
2414 elsif not In_Open_Scopes (Spec_Id) then
2415 Restore_Scope := True;
2416 Push_Scope (Spec_Id);
2418 if Ekind (Spec_Id) = E_Task_Type then
2419 if Has_Discriminants (Spec_Id) then
2420 Install_Discriminants (Spec_Id);
2423 elsif Is_Generic_Subprogram (Spec_Id) then
2424 Install_Generic_Formals (Spec_Id);
2427 Install_Formals (Spec_Id);
2431 Analyze_Global_List (Items);
2433 if Restore_Scope then
2438 -- Ensure that a state and a corresponding constituent do not appear
2439 -- together in pragma [Refined_]Global.
2441 Check_State_And_Constituent_Use
2442 (States => States_Seen,
2443 Constits => Constits_Seen,
2446 Set_Is_Analyzed_Pragma (N);
2447 end Analyze_Global_In_Decl_Part;
2449 --------------------------------------------
2450 -- Analyze_Initial_Condition_In_Decl_Part --
2451 --------------------------------------------
2453 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2454 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2455 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2456 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2458 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2461 -- Do not analyze the pragma multiple times
2463 if Is_Analyzed_Pragma (N) then
2467 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2468 -- analysis of the pragma, the Ghost mode at point of declaration and
2469 -- point of analysis may not necessarely be the same. Use the mode in
2470 -- effect at the point of declaration.
2474 -- The expression is preanalyzed because it has not been moved to its
2475 -- final place yet. A direct analysis may generate side effects and this
2476 -- is not desired at this point.
2478 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2479 Ghost_Mode := Save_Ghost_Mode;
2481 Set_Is_Analyzed_Pragma (N);
2482 end Analyze_Initial_Condition_In_Decl_Part;
2484 --------------------------------------
2485 -- Analyze_Initializes_In_Decl_Part --
2486 --------------------------------------
2488 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2489 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2490 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2492 Constits_Seen : Elist_Id := No_Elist;
2493 -- A list containing the entities of all constituents processed so far.
2494 -- It aids in detecting illegal usage of a state and a corresponding
2495 -- constituent in pragma Initializes.
2497 Items_Seen : Elist_Id := No_Elist;
2498 -- A list of all initialization items processed so far. This list is
2499 -- used to detect duplicate items.
2501 Non_Null_Seen : Boolean := False;
2502 Null_Seen : Boolean := False;
2503 -- Flags used to check the legality of a null initialization list
2505 States_And_Objs : Elist_Id := No_Elist;
2506 -- A list of all abstract states and objects declared in the visible
2507 -- declarations of the related package. This list is used to detect the
2508 -- legality of initialization items.
2510 States_Seen : Elist_Id := No_Elist;
2511 -- A list containing the entities of all states processed so far. It
2512 -- helps in detecting illegal usage of a state and a corresponding
2513 -- constituent in pragma Initializes.
2515 procedure Analyze_Initialization_Item (Item : Node_Id);
2516 -- Verify the legality of a single initialization item
2518 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2519 -- Verify the legality of a single initialization item followed by a
2520 -- list of input items.
2522 procedure Collect_States_And_Objects;
2523 -- Inspect the visible declarations of the related package and gather
2524 -- the entities of all abstract states and objects in States_And_Objs.
2526 ---------------------------------
2527 -- Analyze_Initialization_Item --
2528 ---------------------------------
2530 procedure Analyze_Initialization_Item (Item : Node_Id) is
2531 Item_Id : Entity_Id;
2534 -- Null initialization list
2536 if Nkind (Item) = N_Null then
2538 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2540 elsif Non_Null_Seen then
2542 ("cannot mix null and non-null initialization items", Item);
2547 -- Initialization item
2550 Non_Null_Seen := True;
2554 ("cannot mix null and non-null initialization items", Item);
2558 Resolve_State (Item);
2560 if Is_Entity_Name (Item) then
2561 Item_Id := Entity_Of (Item);
2563 if Ekind_In (Item_Id, E_Abstract_State,
2567 -- The state or variable must be declared in the visible
2568 -- declarations of the package (SPARK RM 7.1.5(7)).
2570 if not Contains (States_And_Objs, Item_Id) then
2571 Error_Msg_Name_1 := Chars (Pack_Id);
2573 ("initialization item & must appear in the visible "
2574 & "declarations of package %", Item, Item_Id);
2576 -- Detect a duplicate use of the same initialization item
2577 -- (SPARK RM 7.1.5(5)).
2579 elsif Contains (Items_Seen, Item_Id) then
2580 SPARK_Msg_N ("duplicate initialization item", Item);
2582 -- The item is legal, add it to the list of processed states
2586 Append_New_Elmt (Item_Id, Items_Seen);
2588 if Ekind (Item_Id) = E_Abstract_State then
2589 Append_New_Elmt (Item_Id, States_Seen);
2592 if Present (Encapsulating_State (Item_Id)) then
2593 Append_New_Elmt (Item_Id, Constits_Seen);
2597 -- The item references something that is not a state or object
2598 -- (SPARK RM 7.1.5(3)).
2602 ("initialization item must denote object or state", Item);
2605 -- Some form of illegal construct masquerading as a name
2606 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2610 ("initialization item must denote object or state", Item);
2613 end Analyze_Initialization_Item;
2615 ---------------------------------------------
2616 -- Analyze_Initialization_Item_With_Inputs --
2617 ---------------------------------------------
2619 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2620 Inputs_Seen : Elist_Id := No_Elist;
2621 -- A list of all inputs processed so far. This list is used to detect
2622 -- duplicate uses of an input.
2624 Non_Null_Seen : Boolean := False;
2625 Null_Seen : Boolean := False;
2626 -- Flags used to check the legality of an input list
2628 procedure Analyze_Input_Item (Input : Node_Id);
2629 -- Verify the legality of a single input item
2631 ------------------------
2632 -- Analyze_Input_Item --
2633 ------------------------
2635 procedure Analyze_Input_Item (Input : Node_Id) is
2636 Input_Id : Entity_Id;
2641 if Nkind (Input) = N_Null then
2644 ("multiple null initializations not allowed", Item);
2646 elsif Non_Null_Seen then
2648 ("cannot mix null and non-null initialization item", Item);
2656 Non_Null_Seen := True;
2660 ("cannot mix null and non-null initialization item", Item);
2664 Resolve_State (Input);
2666 if Is_Entity_Name (Input) then
2667 Input_Id := Entity_Of (Input);
2669 if Ekind_In (Input_Id, E_Abstract_State,
2676 -- The input cannot denote states or objects declared
2677 -- within the related package (SPARK RM 7.1.5(4)).
2679 if Within_Scope (Input_Id, Current_Scope) then
2680 Error_Msg_Name_1 := Chars (Pack_Id);
2682 ("input item & cannot denote a visible object or "
2683 & "state of package %", Input, Input_Id);
2685 -- Detect a duplicate use of the same input item
2686 -- (SPARK RM 7.1.5(5)).
2688 elsif Contains (Inputs_Seen, Input_Id) then
2689 SPARK_Msg_N ("duplicate input item", Input);
2691 -- Input is legal, add it to the list of processed inputs
2694 Append_New_Elmt (Input_Id, Inputs_Seen);
2696 if Ekind (Input_Id) = E_Abstract_State then
2697 Append_New_Elmt (Input_Id, States_Seen);
2700 if Ekind_In (Input_Id, E_Abstract_State,
2703 and then Present (Encapsulating_State (Input_Id))
2705 Append_New_Elmt (Input_Id, Constits_Seen);
2709 -- The input references something that is not a state or an
2710 -- object (SPARK RM 7.1.5(3)).
2714 ("input item must denote object or state", Input);
2717 -- Some form of illegal construct masquerading as a name
2718 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2722 ("input item must denote object or state", Input);
2725 end Analyze_Input_Item;
2729 Inputs : constant Node_Id := Expression (Item);
2733 Name_Seen : Boolean := False;
2734 -- A flag used to detect multiple item names
2736 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2739 -- Inspect the name of an item with inputs
2741 Elmt := First (Choices (Item));
2742 while Present (Elmt) loop
2744 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2747 Analyze_Initialization_Item (Elmt);
2753 -- Multiple input items appear as an aggregate
2755 if Nkind (Inputs) = N_Aggregate then
2756 if Present (Expressions (Inputs)) then
2757 Input := First (Expressions (Inputs));
2758 while Present (Input) loop
2759 Analyze_Input_Item (Input);
2764 if Present (Component_Associations (Inputs)) then
2766 ("inputs must appear in named association form", Inputs);
2769 -- Single input item
2772 Analyze_Input_Item (Inputs);
2774 end Analyze_Initialization_Item_With_Inputs;
2776 --------------------------------
2777 -- Collect_States_And_Objects --
2778 --------------------------------
2780 procedure Collect_States_And_Objects is
2781 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
2785 -- Collect the abstract states defined in the package (if any)
2787 if Present (Abstract_States (Pack_Id)) then
2788 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
2791 -- Collect all objects the appear in the visible declarations of the
2794 if Present (Visible_Declarations (Pack_Spec)) then
2795 Decl := First (Visible_Declarations (Pack_Spec));
2796 while Present (Decl) loop
2797 if Comes_From_Source (Decl)
2798 and then Nkind (Decl) = N_Object_Declaration
2800 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
2806 end Collect_States_And_Objects;
2810 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2813 -- Start of processing for Analyze_Initializes_In_Decl_Part
2816 -- Do not analyze the pragma multiple times
2818 if Is_Analyzed_Pragma (N) then
2822 -- Nothing to do when the initialization list is empty
2824 if Nkind (Inits) = N_Null then
2828 -- Single and multiple initialization clauses appear as an aggregate. If
2829 -- this is not the case, then either the parser or the analysis of the
2830 -- pragma failed to produce an aggregate.
2832 pragma Assert (Nkind (Inits) = N_Aggregate);
2834 -- Initialize the various lists used during analysis
2836 Collect_States_And_Objects;
2838 if Present (Expressions (Inits)) then
2839 Init := First (Expressions (Inits));
2840 while Present (Init) loop
2841 Analyze_Initialization_Item (Init);
2846 if Present (Component_Associations (Inits)) then
2847 Init := First (Component_Associations (Inits));
2848 while Present (Init) loop
2849 Analyze_Initialization_Item_With_Inputs (Init);
2854 -- Ensure that a state and a corresponding constituent do not appear
2855 -- together in pragma Initializes.
2857 Check_State_And_Constituent_Use
2858 (States => States_Seen,
2859 Constits => Constits_Seen,
2862 Set_Is_Analyzed_Pragma (N);
2863 end Analyze_Initializes_In_Decl_Part;
2865 ---------------------
2866 -- Analyze_Part_Of --
2867 ---------------------
2869 procedure Analyze_Part_Of
2871 Item_Id : Entity_Id;
2873 Encap_Id : out Entity_Id;
2874 Legal : out Boolean)
2876 Encap_Typ : Entity_Id;
2877 Item_Decl : Node_Id;
2878 Pack_Id : Entity_Id;
2879 Placement : State_Space_Kind;
2880 Parent_Unit : Entity_Id;
2883 -- Assume that the indicator is illegal
2888 if Nkind_In (Encap, N_Expanded_Name,
2890 N_Selected_Component)
2893 Resolve_State (Encap);
2895 Encap_Id := Entity (Encap);
2897 -- The encapsulator is an abstract state
2899 if Ekind (Encap_Id) = E_Abstract_State then
2902 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
2904 elsif Is_Single_Concurrent_Object (Encap_Id) then
2907 -- Otherwise the encapsulator is not a legal choice
2911 ("indicator Part_Of must denote abstract state, single "
2912 & "protected type or single task type", Encap);
2916 -- This is a syntax error, always report
2920 ("indicator Part_Of must denote abstract state, single protected "
2921 & "type or single task type", Encap);
2925 -- Catch a case where indicator Part_Of denotes the abstract view of a
2926 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
2928 if From_Limited_With (Encap_Id)
2929 and then Present (Non_Limited_View (Encap_Id))
2930 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
2932 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
2933 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
2937 -- The encapsulator is an abstract state
2939 if Ekind (Encap_Id) = E_Abstract_State then
2941 -- Determine where the object, package instantiation or state lives
2942 -- with respect to the enclosing packages or package bodies.
2944 Find_Placement_In_State_Space
2945 (Item_Id => Item_Id,
2946 Placement => Placement,
2947 Pack_Id => Pack_Id);
2949 -- The item appears in a non-package construct with a declarative
2950 -- part (subprogram, block, etc). As such, the item is not allowed
2951 -- to be a part of an encapsulating state because the item is not
2954 if Placement = Not_In_Package then
2956 ("indicator Part_Of cannot appear in this context "
2957 & "(SPARK RM 7.2.6(5))", Indic);
2958 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
2960 ("\& is not part of the hidden state of package %",
2963 -- The item appears in the visible state space of some package. In
2964 -- general this scenario does not warrant Part_Of except when the
2965 -- package is a private child unit and the encapsulating state is
2966 -- declared in a parent unit or a public descendant of that parent
2969 elsif Placement = Visible_State_Space then
2970 if Is_Child_Unit (Pack_Id)
2971 and then Is_Private_Descendant (Pack_Id)
2973 -- A variable or state abstraction which is part of the visible
2974 -- state of a private child unit (or one of its public
2975 -- descendants) must have its Part_Of indicator specified. The
2976 -- Part_Of indicator must denote a state abstraction declared
2977 -- by either the parent unit of the private unit or by a public
2978 -- descendant of that parent unit.
2980 -- Find nearest private ancestor (which can be the current unit
2983 Parent_Unit := Pack_Id;
2984 while Present (Parent_Unit) loop
2987 (Parent (Unit_Declaration_Node (Parent_Unit)));
2988 Parent_Unit := Scope (Parent_Unit);
2991 Parent_Unit := Scope (Parent_Unit);
2993 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
2995 ("indicator Part_Of must denote abstract state or public "
2996 & "descendant of & (SPARK RM 7.2.6(3))",
2997 Indic, Parent_Unit);
2999 elsif Scope (Encap_Id) = Parent_Unit
3001 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3002 and then not Is_Private_Descendant (Scope (Encap_Id)))
3008 ("indicator Part_Of must denote abstract state or public "
3009 & "descendant of & (SPARK RM 7.2.6(3))",
3010 Indic, Parent_Unit);
3013 -- Indicator Part_Of is not needed when the related package is not
3014 -- a private child unit or a public descendant thereof.
3018 ("indicator Part_Of cannot appear in this context "
3019 & "(SPARK RM 7.2.6(5))", Indic);
3020 Error_Msg_Name_1 := Chars (Pack_Id);
3022 ("\& is declared in the visible part of package %",
3026 -- When the item appears in the private state space of a package, the
3027 -- encapsulating state must be declared in the same package.
3029 elsif Placement = Private_State_Space then
3030 if Scope (Encap_Id) /= Pack_Id then
3032 ("indicator Part_Of must designate an abstract state of "
3033 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3034 Error_Msg_Name_1 := Chars (Pack_Id);
3036 ("\& is declared in the private part of package %",
3040 -- Items declared in the body state space of a package do not need
3041 -- Part_Of indicators as the refinement has already been seen.
3045 ("indicator Part_Of cannot appear in this context "
3046 & "(SPARK RM 7.2.6(5))", Indic);
3048 if Scope (Encap_Id) = Pack_Id then
3049 Error_Msg_Name_1 := Chars (Pack_Id);
3051 ("\& is declared in the body of package %", Indic, Item_Id);
3055 -- The encapsulator is a single concurrent type
3058 Encap_Typ := Etype (Encap_Id);
3060 -- Only abstract states and variables can act as constituents of an
3061 -- encapsulating single concurrent type.
3063 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3066 -- The constituent is a constant
3068 elsif Ekind (Item_Id) = E_Constant then
3069 Error_Msg_Name_1 := Chars (Encap_Id);
3071 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3072 & "single protected type %"), Indic, Item_Id);
3074 -- The constituent is a package instantiation
3077 Error_Msg_Name_1 := Chars (Encap_Id);
3079 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3080 & "constituent of single protected type %"), Indic, Item_Id);
3083 -- When the item denotes an abstract state of a nested package, use
3084 -- the declaration of the package to detect proper placement.
3089 -- with Abstract_State => (State with Part_Of => T)
3091 if Ekind (Item_Id) = E_Abstract_State then
3092 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3094 Item_Decl := Declaration_Node (Item_Id);
3097 -- Both the item and its encapsulating single concurrent type must
3098 -- appear in the same declarative region (SPARK RM 9.3). Note that
3099 -- privacy is ignored.
3101 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3102 Error_Msg_Name_1 := Chars (Encap_Id);
3104 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3105 & "immediately within the same region as single protected "
3106 & "type %"), Indic, Item_Id);
3111 end Analyze_Part_Of;
3113 ----------------------------------
3114 -- Analyze_Part_Of_In_Decl_Part --
3115 ----------------------------------
3117 procedure Analyze_Part_Of_In_Decl_Part (N : Node_Id) is
3118 Var_Decl : constant Node_Id := Find_Related_Context (N);
3119 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3120 Encap_Id : Entity_Id;
3124 -- Detect any discrepancies between the placement of the variable with
3125 -- respect to general state space and the encapsulating state or single
3131 Encap => Get_Pragma_Arg (First (Pragma_Argument_Associations (N))),
3132 Encap_Id => Encap_Id,
3135 -- The Part_Of indicator turns the variable into a constituent of the
3136 -- encapsulating state or single concurrent type.
3139 pragma Assert (Present (Encap_Id));
3141 Append_Elmt (Var_Id, Part_Of_Constituents (Encap_Id));
3142 Set_Encapsulating_State (Var_Id, Encap_Id);
3144 end Analyze_Part_Of_In_Decl_Part;
3146 --------------------
3147 -- Analyze_Pragma --
3148 --------------------
3150 procedure Analyze_Pragma (N : Node_Id) is
3151 Loc : constant Source_Ptr := Sloc (N);
3152 Prag_Id : Pragma_Id;
3155 -- Name of the source pragma, or name of the corresponding aspect for
3156 -- pragmas which originate in a source aspect. In the latter case, the
3157 -- name may be different from the pragma name.
3159 Pragma_Exit : exception;
3160 -- This exception is used to exit pragma processing completely. It
3161 -- is used when an error is detected, and no further processing is
3162 -- required. It is also used if an earlier error has left the tree in
3163 -- a state where the pragma should not be processed.
3166 -- Number of pragma argument associations
3172 -- First four pragma arguments (pragma argument association nodes, or
3173 -- Empty if the corresponding argument does not exist).
3175 type Name_List is array (Natural range <>) of Name_Id;
3176 type Args_List is array (Natural range <>) of Node_Id;
3177 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3179 -----------------------
3180 -- Local Subprograms --
3181 -----------------------
3183 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3184 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3185 -- get the given string argument, and place it in Name_Buffer, adding
3186 -- leading and trailing asterisks if they are not already present. The
3187 -- caller has already checked that Arg is a static string expression.
3189 procedure Ada_2005_Pragma;
3190 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3191 -- Ada 95 mode, these are implementation defined pragmas, so should be
3192 -- caught by the No_Implementation_Pragmas restriction.
3194 procedure Ada_2012_Pragma;
3195 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3196 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3197 -- should be caught by the No_Implementation_Pragmas restriction.
3199 procedure Analyze_Depends_Global
3200 (Spec_Id : out Entity_Id;
3201 Subp_Decl : out Node_Id;
3202 Legal : out Boolean);
3203 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3204 -- legality of the placement and related context of the pragma. Spec_Id
3205 -- is the entity of the related subprogram. Subp_Decl is the declaration
3206 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3208 procedure Analyze_If_Present (Id : Pragma_Id);
3209 -- Inspect the remainder of the list containing pragma N and look for
3210 -- a pragma that matches Id. If found, analyze the pragma.
3212 procedure Analyze_Pre_Post_Condition;
3213 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3215 procedure Analyze_Refined_Depends_Global_Post
3216 (Spec_Id : out Entity_Id;
3217 Body_Id : out Entity_Id;
3218 Legal : out Boolean);
3219 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3220 -- Refined_Global and Refined_Post. Verify the legality of the placement
3221 -- and related context of the pragma. Spec_Id is the entity of the
3222 -- related subprogram. Body_Id is the entity of the subprogram body.
3223 -- Flag Legal is set when the pragma is legal.
3225 procedure Check_Ada_83_Warning;
3226 -- Issues a warning message for the current pragma if operating in Ada
3227 -- 83 mode (used for language pragmas that are not a standard part of
3228 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3231 procedure Check_Arg_Count (Required : Nat);
3232 -- Check argument count for pragma is equal to given parameter. If not,
3233 -- then issue an error message and raise Pragma_Exit.
3235 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3236 -- Arg which can either be a pragma argument association, in which case
3237 -- the check is applied to the expression of the association or an
3238 -- expression directly.
3240 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3241 -- Check that an argument has the right form for an EXTERNAL_NAME
3242 -- parameter of an extended import/export pragma. The rule is that the
3243 -- name must be an identifier or string literal (in Ada 83 mode) or a
3244 -- static string expression (in Ada 95 mode).
3246 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3247 -- Check the specified argument Arg to make sure that it is an
3248 -- identifier. If not give error and raise Pragma_Exit.
3250 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3251 -- Check the specified argument Arg to make sure that it is an integer
3252 -- literal. If not give error and raise Pragma_Exit.
3254 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3255 -- Check the specified argument Arg to make sure that it has the proper
3256 -- syntactic form for a local name and meets the semantic requirements
3257 -- for a local name. The local name is analyzed as part of the
3258 -- processing for this call. In addition, the local name is required
3259 -- to represent an entity at the library level.
3261 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3262 -- Check the specified argument Arg to make sure that it has the proper
3263 -- syntactic form for a local name and meets the semantic requirements
3264 -- for a local name. The local name is analyzed as part of the
3265 -- processing for this call.
3267 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3268 -- Check the specified argument Arg to make sure that it is a valid
3269 -- locking policy name. If not give error and raise Pragma_Exit.
3271 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3272 -- Check the specified argument Arg to make sure that it is a valid
3273 -- elaboration policy name. If not give error and raise Pragma_Exit.
3275 procedure Check_Arg_Is_One_Of
3278 procedure Check_Arg_Is_One_Of
3280 N1, N2, N3 : Name_Id);
3281 procedure Check_Arg_Is_One_Of
3283 N1, N2, N3, N4 : Name_Id);
3284 procedure Check_Arg_Is_One_Of
3286 N1, N2, N3, N4, N5 : Name_Id);
3287 -- Check the specified argument Arg to make sure that it is an
3288 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3289 -- present). If not then give error and raise Pragma_Exit.
3291 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3292 -- Check the specified argument Arg to make sure that it is a valid
3293 -- queuing policy name. If not give error and raise Pragma_Exit.
3295 procedure Check_Arg_Is_OK_Static_Expression
3297 Typ : Entity_Id := Empty);
3298 -- Check the specified argument Arg to make sure that it is a static
3299 -- expression of the given type (i.e. it will be analyzed and resolved
3300 -- using this type, which can be any valid argument to Resolve, e.g.
3301 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3302 -- Typ is left Empty, then any static expression is allowed. Includes
3303 -- checking that the argument does not raise Constraint_Error.
3305 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3306 -- Check the specified argument Arg to make sure that it is a valid task
3307 -- dispatching policy name. If not give error and raise Pragma_Exit.
3309 procedure Check_Arg_Order (Names : Name_List);
3310 -- Checks for an instance of two arguments with identifiers for the
3311 -- current pragma which are not in the sequence indicated by Names,
3312 -- and if so, generates a fatal message about bad order of arguments.
3314 procedure Check_At_Least_N_Arguments (N : Nat);
3315 -- Check there are at least N arguments present
3317 procedure Check_At_Most_N_Arguments (N : Nat);
3318 -- Check there are no more than N arguments present
3320 procedure Check_Component
3323 In_Variant_Part : Boolean := False);
3324 -- Examine an Unchecked_Union component for correct use of per-object
3325 -- constrained subtypes, and for restrictions on finalizable components.
3326 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3327 -- should be set when Comp comes from a record variant.
3329 procedure Check_Duplicate_Pragma (E : Entity_Id);
3330 -- Check if a rep item of the same name as the current pragma is already
3331 -- chained as a rep pragma to the given entity. If so give a message
3332 -- about the duplicate, and then raise Pragma_Exit so does not return.
3333 -- Note that if E is a type, then this routine avoids flagging a pragma
3334 -- which applies to a parent type from which E is derived.
3336 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3337 -- Nam is an N_String_Literal node containing the external name set by
3338 -- an Import or Export pragma (or extended Import or Export pragma).
3339 -- This procedure checks for possible duplications if this is the export
3340 -- case, and if found, issues an appropriate error message.
3342 procedure Check_Expr_Is_OK_Static_Expression
3344 Typ : Entity_Id := Empty);
3345 -- Check the specified expression Expr to make sure that it is a static
3346 -- expression of the given type (i.e. it will be analyzed and resolved
3347 -- using this type, which can be any valid argument to Resolve, e.g.
3348 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3349 -- Typ is left Empty, then any static expression is allowed. Includes
3350 -- checking that the expression does not raise Constraint_Error.
3352 procedure Check_First_Subtype (Arg : Node_Id);
3353 -- Checks that Arg, whose expression is an entity name, references a
3356 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3357 -- Checks that the given argument has an identifier, and if so, requires
3358 -- it to match the given identifier name. If there is no identifier, or
3359 -- a non-matching identifier, then an error message is given and
3360 -- Pragma_Exit is raised.
3362 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3363 -- Checks that the given argument has an identifier, and if so, requires
3364 -- it to match one of the given identifier names. If there is no
3365 -- identifier, or a non-matching identifier, then an error message is
3366 -- given and Pragma_Exit is raised.
3368 procedure Check_In_Main_Program;
3369 -- Common checks for pragmas that appear within a main program
3370 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3372 procedure Check_Interrupt_Or_Attach_Handler;
3373 -- Common processing for first argument of pragma Interrupt_Handler or
3374 -- pragma Attach_Handler.
3376 procedure Check_Loop_Pragma_Placement;
3377 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3378 -- appear immediately within a construct restricted to loops, and that
3379 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3381 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3382 -- Check that pragma appears in a declarative part, or in a package
3383 -- specification, i.e. that it does not occur in a statement sequence
3386 procedure Check_No_Identifier (Arg : Node_Id);
3387 -- Checks that the given argument does not have an identifier. If
3388 -- an identifier is present, then an error message is issued, and
3389 -- Pragma_Exit is raised.
3391 procedure Check_No_Identifiers;
3392 -- Checks that none of the arguments to the pragma has an identifier.
3393 -- If any argument has an identifier, then an error message is issued,
3394 -- and Pragma_Exit is raised.
3396 procedure Check_No_Link_Name;
3397 -- Checks that no link name is specified
3399 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3400 -- Checks if the given argument has an identifier, and if so, requires
3401 -- it to match the given identifier name. If there is a non-matching
3402 -- identifier, then an error message is given and Pragma_Exit is raised.
3404 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3405 -- Checks if the given argument has an identifier, and if so, requires
3406 -- it to match the given identifier name. If there is a non-matching
3407 -- identifier, then an error message is given and Pragma_Exit is raised.
3408 -- In this version of the procedure, the identifier name is given as
3409 -- a string with lower case letters.
3411 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3412 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3413 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3414 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3415 -- is an OK static boolean expression. Emit an error if this is not the
3418 procedure Check_Static_Constraint (Constr : Node_Id);
3419 -- Constr is a constraint from an N_Subtype_Indication node from a
3420 -- component constraint in an Unchecked_Union type. This routine checks
3421 -- that the constraint is static as required by the restrictions for
3424 procedure Check_Valid_Configuration_Pragma;
3425 -- Legality checks for placement of a configuration pragma
3427 procedure Check_Valid_Library_Unit_Pragma;
3428 -- Legality checks for library unit pragmas. A special case arises for
3429 -- pragmas in generic instances that come from copies of the original
3430 -- library unit pragmas in the generic templates. In the case of other
3431 -- than library level instantiations these can appear in contexts which
3432 -- would normally be invalid (they only apply to the original template
3433 -- and to library level instantiations), and they are simply ignored,
3434 -- which is implemented by rewriting them as null statements.
3436 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3437 -- Check an Unchecked_Union variant for lack of nested variants and
3438 -- presence of at least one component. UU_Typ is the related Unchecked_
3441 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3442 -- Subsidiary routine to the processing of pragmas Abstract_State,
3443 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3444 -- Refined_Global and Refined_State. Transform argument Arg into
3445 -- an aggregate if not one already. N_Null is never transformed.
3446 -- Arg may denote an aspect specification or a pragma argument
3449 procedure Error_Pragma (Msg : String);
3450 pragma No_Return (Error_Pragma);
3451 -- Outputs error message for current pragma. The message contains a %
3452 -- that will be replaced with the pragma name, and the flag is placed
3453 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3454 -- calls Fix_Error (see spec of that procedure for details).
3456 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3457 pragma No_Return (Error_Pragma_Arg);
3458 -- Outputs error message for current pragma. The message may contain
3459 -- a % that will be replaced with the pragma name. The parameter Arg
3460 -- may either be a pragma argument association, in which case the flag
3461 -- is placed on the expression of this association, or an expression,
3462 -- in which case the flag is placed directly on the expression. The
3463 -- message is placed using Error_Msg_N, so the message may also contain
3464 -- an & insertion character which will reference the given Arg value.
3465 -- After placing the message, Pragma_Exit is raised. Note: this routine
3466 -- calls Fix_Error (see spec of that procedure for details).
3468 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3469 pragma No_Return (Error_Pragma_Arg);
3470 -- Similar to above form of Error_Pragma_Arg except that two messages
3471 -- are provided, the second is a continuation comment starting with \.
3473 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3474 pragma No_Return (Error_Pragma_Arg_Ident);
3475 -- Outputs error message for current pragma. The message may contain a %
3476 -- that will be replaced with the pragma name. The parameter Arg must be
3477 -- a pragma argument association with a non-empty identifier (i.e. its
3478 -- Chars field must be set), and the error message is placed on the
3479 -- identifier. The message is placed using Error_Msg_N so the message
3480 -- may also contain an & insertion character which will reference
3481 -- the identifier. After placing the message, Pragma_Exit is raised.
3482 -- Note: this routine calls Fix_Error (see spec of that procedure for
3485 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3486 pragma No_Return (Error_Pragma_Ref);
3487 -- Outputs error message for current pragma. The message may contain
3488 -- a % that will be replaced with the pragma name. The parameter Ref
3489 -- must be an entity whose name can be referenced by & and sloc by #.
3490 -- After placing the message, Pragma_Exit is raised. Note: this routine
3491 -- calls Fix_Error (see spec of that procedure for details).
3493 function Find_Lib_Unit_Name return Entity_Id;
3494 -- Used for a library unit pragma to find the entity to which the
3495 -- library unit pragma applies, returns the entity found.
3497 procedure Find_Program_Unit_Name (Id : Node_Id);
3498 -- If the pragma is a compilation unit pragma, the id must denote the
3499 -- compilation unit in the same compilation, and the pragma must appear
3500 -- in the list of preceding or trailing pragmas. If it is a program
3501 -- unit pragma that is not a compilation unit pragma, then the
3502 -- identifier must be visible.
3504 function Find_Unique_Parameterless_Procedure
3506 Arg : Node_Id) return Entity_Id;
3507 -- Used for a procedure pragma to find the unique parameterless
3508 -- procedure identified by Name, returns it if it exists, otherwise
3509 -- errors out and uses Arg as the pragma argument for the message.
3511 function Fix_Error (Msg : String) return String;
3512 -- This is called prior to issuing an error message. Msg is the normal
3513 -- error message issued in the pragma case. This routine checks for the
3514 -- case of a pragma coming from an aspect in the source, and returns a
3515 -- message suitable for the aspect case as follows:
3517 -- Each substring "pragma" is replaced by "aspect"
3519 -- If "argument of" is at the start of the error message text, it is
3520 -- replaced by "entity for".
3522 -- If "argument" is at the start of the error message text, it is
3523 -- replaced by "entity".
3525 -- So for example, "argument of pragma X must be discrete type"
3526 -- returns "entity for aspect X must be a discrete type".
3528 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3529 -- be different from the pragma name). If the current pragma results
3530 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3531 -- original pragma name.
3533 procedure Gather_Associations
3535 Args : out Args_List);
3536 -- This procedure is used to gather the arguments for a pragma that
3537 -- permits arbitrary ordering of parameters using the normal rules
3538 -- for named and positional parameters. The Names argument is a list
3539 -- of Name_Id values that corresponds to the allowed pragma argument
3540 -- association identifiers in order. The result returned in Args is
3541 -- a list of corresponding expressions that are the pragma arguments.
3542 -- Note that this is a list of expressions, not of pragma argument
3543 -- associations (Gather_Associations has completely checked all the
3544 -- optional identifiers when it returns). An entry in Args is Empty
3545 -- on return if the corresponding argument is not present.
3547 procedure GNAT_Pragma;
3548 -- Called for all GNAT defined pragmas to check the relevant restriction
3549 -- (No_Implementation_Pragmas).
3551 function Is_Before_First_Decl
3552 (Pragma_Node : Node_Id;
3553 Decls : List_Id) return Boolean;
3554 -- Return True if Pragma_Node is before the first declarative item in
3555 -- Decls where Decls is the list of declarative items.
3557 function Is_Configuration_Pragma return Boolean;
3558 -- Determines if the placement of the current pragma is appropriate
3559 -- for a configuration pragma.
3561 function Is_In_Context_Clause return Boolean;
3562 -- Returns True if pragma appears within the context clause of a unit,
3563 -- and False for any other placement (does not generate any messages).
3565 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3566 -- Analyzes the argument, and determines if it is a static string
3567 -- expression, returns True if so, False if non-static or not String.
3568 -- A special case is that a string literal returns True in Ada 83 mode
3569 -- (which has no such thing as static string expressions). Note that
3570 -- the call analyzes its argument, so this cannot be used for the case
3571 -- where an identifier might not be declared.
3573 procedure Pragma_Misplaced;
3574 pragma No_Return (Pragma_Misplaced);
3575 -- Issue fatal error message for misplaced pragma
3577 procedure Process_Atomic_Independent_Shared_Volatile;
3578 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3579 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3580 -- and treated as being identical in effect to pragma Atomic.
3582 procedure Process_Compile_Time_Warning_Or_Error;
3583 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3585 procedure Process_Convention
3586 (C : out Convention_Id;
3587 Ent : out Entity_Id);
3588 -- Common processing for Convention, Interface, Import and Export.
3589 -- Checks first two arguments of pragma, and sets the appropriate
3590 -- convention value in the specified entity or entities. On return
3591 -- C is the convention, Ent is the referenced entity.
3593 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3594 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3595 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3597 procedure Process_Extended_Import_Export_Object_Pragma
3598 (Arg_Internal : Node_Id;
3599 Arg_External : Node_Id;
3600 Arg_Size : Node_Id);
3601 -- Common processing for the pragmas Import/Export_Object. The three
3602 -- arguments correspond to the three named parameters of the pragmas. An
3603 -- argument is empty if the corresponding parameter is not present in
3606 procedure Process_Extended_Import_Export_Internal_Arg
3607 (Arg_Internal : Node_Id := Empty);
3608 -- Common processing for all extended Import and Export pragmas. The
3609 -- argument is the pragma parameter for the Internal argument. If
3610 -- Arg_Internal is empty or inappropriate, an error message is posted.
3611 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3612 -- set to identify the referenced entity.
3614 procedure Process_Extended_Import_Export_Subprogram_Pragma
3615 (Arg_Internal : Node_Id;
3616 Arg_External : Node_Id;
3617 Arg_Parameter_Types : Node_Id;
3618 Arg_Result_Type : Node_Id := Empty;
3619 Arg_Mechanism : Node_Id;
3620 Arg_Result_Mechanism : Node_Id := Empty);
3621 -- Common processing for all extended Import and Export pragmas applying
3622 -- to subprograms. The caller omits any arguments that do not apply to
3623 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3624 -- only in the Import_Function and Export_Function cases). The argument
3625 -- names correspond to the allowed pragma association identifiers.
3627 procedure Process_Generic_List;
3628 -- Common processing for Share_Generic and Inline_Generic
3630 procedure Process_Import_Or_Interface;
3631 -- Common processing for Import or Interface
3633 procedure Process_Import_Predefined_Type;
3634 -- Processing for completing a type with pragma Import. This is used
3635 -- to declare types that match predefined C types, especially for cases
3636 -- without corresponding Ada predefined type.
3638 type Inline_Status is (Suppressed, Disabled, Enabled);
3639 -- Inline status of a subprogram, indicated as follows:
3640 -- Suppressed: inlining is suppressed for the subprogram
3641 -- Disabled: no inlining is requested for the subprogram
3642 -- Enabled: inlining is requested/required for the subprogram
3644 procedure Process_Inline (Status : Inline_Status);
3645 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3646 -- indicates the inline status specified by the pragma.
3648 procedure Process_Interface_Name
3649 (Subprogram_Def : Entity_Id;
3651 Link_Arg : Node_Id);
3652 -- Given the last two arguments of pragma Import, pragma Export, or
3653 -- pragma Interface_Name, performs validity checks and sets the
3654 -- Interface_Name field of the given subprogram entity to the
3655 -- appropriate external or link name, depending on the arguments given.
3656 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3657 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3658 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3659 -- nor Link_Arg is present, the interface name is set to the default
3660 -- from the subprogram name.
3662 procedure Process_Interrupt_Or_Attach_Handler;
3663 -- Common processing for Interrupt and Attach_Handler pragmas
3665 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3666 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3667 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3668 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3669 -- is not set in the Restrictions case.
3671 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3672 -- Common processing for Suppress and Unsuppress. The boolean parameter
3673 -- Suppress_Case is True for the Suppress case, and False for the
3676 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3677 -- Subsidiary to the analysis of pragmas Independent[_Components].
3678 -- Record such a pragma N applied to entity E for future checks.
3680 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3681 -- This procedure sets the Is_Exported flag for the given entity,
3682 -- checking that the entity was not previously imported. Arg is
3683 -- the argument that specified the entity. A check is also made
3684 -- for exporting inappropriate entities.
3686 procedure Set_Extended_Import_Export_External_Name
3687 (Internal_Ent : Entity_Id;
3688 Arg_External : Node_Id);
3689 -- Common processing for all extended import export pragmas. The first
3690 -- argument, Internal_Ent, is the internal entity, which has already
3691 -- been checked for validity by the caller. Arg_External is from the
3692 -- Import or Export pragma, and may be null if no External parameter
3693 -- was present. If Arg_External is present and is a non-null string
3694 -- (a null string is treated as the default), then the Interface_Name
3695 -- field of Internal_Ent is set appropriately.
3697 procedure Set_Imported (E : Entity_Id);
3698 -- This procedure sets the Is_Imported flag for the given entity,
3699 -- checking that it is not previously exported or imported.
3701 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3702 -- Mech is a parameter passing mechanism (see Import_Function syntax
3703 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3704 -- has the right form, and if not issues an error message. If the
3705 -- argument has the right form then the Mechanism field of Ent is
3706 -- set appropriately.
3708 procedure Set_Rational_Profile;
3709 -- Activate the set of configuration pragmas and permissions that make
3710 -- up the Rational profile.
3712 procedure Set_Ravenscar_Profile (N : Node_Id);
3713 -- Activate the set of configuration pragmas and restrictions that make
3714 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3715 -- is used for error messages on any constructs violating the profile.
3717 ----------------------------------
3718 -- Acquire_Warning_Match_String --
3719 ----------------------------------
3721 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3723 String_To_Name_Buffer
3724 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3726 -- Add asterisk at start if not already there
3728 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3729 Name_Buffer (2 .. Name_Len + 1) :=
3730 Name_Buffer (1 .. Name_Len);
3731 Name_Buffer (1) := '*';
3732 Name_Len := Name_Len + 1;
3735 -- Add asterisk at end if not already there
3737 if Name_Buffer (Name_Len) /= '*' then
3738 Name_Len := Name_Len + 1;
3739 Name_Buffer (Name_Len) := '*';
3741 end Acquire_Warning_Match_String;
3743 ---------------------
3744 -- Ada_2005_Pragma --
3745 ---------------------
3747 procedure Ada_2005_Pragma is
3749 if Ada_Version <= Ada_95 then
3750 Check_Restriction (No_Implementation_Pragmas, N);
3752 end Ada_2005_Pragma;
3754 ---------------------
3755 -- Ada_2012_Pragma --
3756 ---------------------
3758 procedure Ada_2012_Pragma is
3760 if Ada_Version <= Ada_2005 then
3761 Check_Restriction (No_Implementation_Pragmas, N);
3763 end Ada_2012_Pragma;
3765 ----------------------------
3766 -- Analyze_Depends_Global --
3767 ----------------------------
3769 procedure Analyze_Depends_Global
3770 (Spec_Id : out Entity_Id;
3771 Subp_Decl : out Node_Id;
3772 Legal : out Boolean)
3775 -- Assume that the pragma is illegal
3782 Check_Arg_Count (1);
3784 -- Ensure the proper placement of the pragma. Depends/Global must be
3785 -- associated with a subprogram declaration or a body that acts as a
3788 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
3792 if Nkind (Subp_Decl) = N_Entry_Declaration then
3795 -- Generic subprogram
3797 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
3800 -- Object declaration of a single concurrent type
3802 elsif Nkind (Subp_Decl) = N_Object_Declaration then
3807 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
3810 -- Subprogram body acts as spec
3812 elsif Nkind (Subp_Decl) = N_Subprogram_Body
3813 and then No (Corresponding_Spec (Subp_Decl))
3817 -- Subprogram body stub acts as spec
3819 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3820 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
3824 -- Subprogram declaration
3826 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
3831 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
3839 -- If we get here, then the pragma is legal
3842 Spec_Id := Unique_Defining_Entity (Subp_Decl);
3844 -- When the related context is an entry, the entry must belong to a
3845 -- protected unit (SPARK RM 6.1.4(6)).
3847 if Is_Entry_Declaration (Spec_Id)
3848 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
3853 -- When the related context is an anonymous object created for a
3854 -- simple concurrent type, the type must be a task
3855 -- (SPARK RM 6.1.4(6)).
3857 elsif Is_Single_Concurrent_Object (Spec_Id)
3858 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
3864 -- A pragma that applies to a Ghost entity becomes Ghost for the
3865 -- purposes of legality checks and removal of ignored Ghost code.
3867 Mark_Pragma_As_Ghost (N, Spec_Id);
3868 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
3869 end Analyze_Depends_Global;
3871 ------------------------
3872 -- Analyze_If_Present --
3873 ------------------------
3875 procedure Analyze_If_Present (Id : Pragma_Id) is
3879 pragma Assert (Is_List_Member (N));
3881 -- Inspect the declarations or statements following pragma N looking
3882 -- for another pragma whose Id matches the caller's request. If it is
3883 -- available, analyze it.
3886 while Present (Stmt) loop
3887 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
3888 Analyze_Pragma (Stmt);
3891 -- The first source declaration or statement immediately following
3892 -- N ends the region where a pragma may appear.
3894 elsif Comes_From_Source (Stmt) then
3900 end Analyze_If_Present;
3902 --------------------------------
3903 -- Analyze_Pre_Post_Condition --
3904 --------------------------------
3906 procedure Analyze_Pre_Post_Condition is
3907 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
3908 Subp_Decl : Node_Id;
3909 Subp_Id : Entity_Id;
3911 Duplicates_OK : Boolean := False;
3912 -- Flag set when a pre/postcondition allows multiple pragmas of the
3915 In_Body_OK : Boolean := False;
3916 -- Flag set when a pre/postcondition is allowed to appear on a body
3917 -- even though the subprogram may have a spec.
3919 Is_Pre_Post : Boolean := False;
3920 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
3924 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
3925 -- offer uniformity among the various kinds of pre/postconditions by
3926 -- rewriting the pragma identifier. This allows the retrieval of the
3927 -- original pragma name by routine Original_Aspect_Pragma_Name.
3929 if Comes_From_Source (N) then
3930 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
3931 Is_Pre_Post := True;
3932 Set_Class_Present (N, Pname = Name_Pre_Class);
3933 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
3935 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
3936 Is_Pre_Post := True;
3937 Set_Class_Present (N, Pname = Name_Post_Class);
3938 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
3942 -- Determine the semantics with respect to duplicates and placement
3943 -- in a body. Pragmas Precondition and Postcondition were introduced
3944 -- before aspects and are not subject to the same aspect-like rules.
3946 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
3947 Duplicates_OK := True;
3953 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
3954 -- argument without an identifier.
3957 Check_Arg_Count (1);
3958 Check_No_Identifiers;
3960 -- Pragmas Precondition and Postcondition have complex argument
3964 Check_At_Least_N_Arguments (1);
3965 Check_At_Most_N_Arguments (2);
3966 Check_Optional_Identifier (Arg1, Name_Check);
3968 if Present (Arg2) then
3969 Check_Optional_Identifier (Arg2, Name_Message);
3970 Preanalyze_Spec_Expression
3971 (Get_Pragma_Arg (Arg2), Standard_String);
3975 -- For a pragma PPC in the extended main source unit, record enabled
3977 -- ??? nothing checks that the pragma is in the main source unit
3979 if Is_Checked (N) and then not Split_PPC (N) then
3980 Set_SCO_Pragma_Enabled (Loc);
3983 -- Ensure the proper placement of the pragma
3986 Find_Related_Declaration_Or_Body
3987 (N, Do_Checks => not Duplicates_OK);
3989 -- When a pre/postcondition pragma applies to an abstract subprogram,
3990 -- its original form must be an aspect with 'Class.
3992 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
3993 if not From_Aspect_Specification (N) then
3995 ("pragma % cannot be applied to abstract subprogram");
3997 elsif not Class_Present (N) then
3999 ("aspect % requires ''Class for abstract subprogram");
4002 -- Entry declaration
4004 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4007 -- Generic subprogram declaration
4009 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4014 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4015 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4019 -- Subprogram body stub
4021 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4022 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4026 -- Subprogram declaration
4028 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4030 -- AI05-0230: When a pre/postcondition pragma applies to a null
4031 -- procedure, its original form must be an aspect with 'Class.
4033 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4034 and then Null_Present (Specification (Subp_Decl))
4035 and then From_Aspect_Specification (N)
4036 and then not Class_Present (N)
4038 Error_Pragma ("aspect % requires ''Class for null procedure");
4041 -- Otherwise the placement is illegal
4048 Subp_Id := Defining_Entity (Subp_Decl);
4050 -- Chain the pragma on the contract for further processing by
4051 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4053 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4055 -- A pragma that applies to a Ghost entity becomes Ghost for the
4056 -- purposes of legality checks and removal of ignored Ghost code.
4058 Mark_Pragma_As_Ghost (N, Subp_Id);
4060 -- Fully analyze the pragma when it appears inside an entry or
4061 -- subprogram body because it cannot benefit from forward references.
4063 if Nkind_In (Subp_Decl, N_Entry_Body,
4065 N_Subprogram_Body_Stub)
4067 -- The legality checks of pragmas Precondition and Postcondition
4068 -- are affected by the SPARK mode in effect and the volatility of
4069 -- the context. Analyze all pragmas in a specific order.
4071 Analyze_If_Present (Pragma_SPARK_Mode);
4072 Analyze_If_Present (Pragma_Volatile_Function);
4073 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4075 end Analyze_Pre_Post_Condition;
4077 -----------------------------------------
4078 -- Analyze_Refined_Depends_Global_Post --
4079 -----------------------------------------
4081 procedure Analyze_Refined_Depends_Global_Post
4082 (Spec_Id : out Entity_Id;
4083 Body_Id : out Entity_Id;
4084 Legal : out Boolean)
4086 Body_Decl : Node_Id;
4087 Spec_Decl : Node_Id;
4090 -- Assume that the pragma is illegal
4097 Check_Arg_Count (1);
4098 Check_No_Identifiers;
4100 -- Verify the placement of the pragma and check for duplicates. The
4101 -- pragma must apply to a subprogram body [stub].
4103 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4107 if Nkind (Body_Decl) = N_Entry_Body then
4112 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4115 -- Subprogram body stub
4117 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4122 elsif Nkind (Body_Decl) = N_Task_Body then
4130 Body_Id := Defining_Entity (Body_Decl);
4131 Spec_Id := Unique_Defining_Entity (Body_Decl);
4133 -- The pragma must apply to the second declaration of a subprogram.
4134 -- In other words, the body [stub] cannot acts as a spec.
4136 if No (Spec_Id) then
4137 Error_Pragma ("pragma % cannot apply to a stand alone body");
4140 -- Catch the case where the subprogram body is a subunit and acts as
4141 -- the third declaration of the subprogram.
4143 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4144 Error_Pragma ("pragma % cannot apply to a subunit");
4148 -- A refined pragma can only apply to the body [stub] of a subprogram
4149 -- declared in the visible part of a package. Retrieve the context of
4150 -- the subprogram declaration.
4152 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4154 -- When dealing with protected entries or protected subprograms, use
4155 -- the enclosing protected type as the proper context.
4157 if Ekind_In (Spec_Id, E_Entry,
4161 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4163 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4166 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4168 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4169 & "subprogram declared in a package specification"));
4173 -- If we get here, then the pragma is legal
4177 -- A pragma that applies to a Ghost entity becomes Ghost for the
4178 -- purposes of legality checks and removal of ignored Ghost code.
4180 Mark_Pragma_As_Ghost (N, Spec_Id);
4182 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4183 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4185 end Analyze_Refined_Depends_Global_Post;
4187 --------------------------
4188 -- Check_Ada_83_Warning --
4189 --------------------------
4191 procedure Check_Ada_83_Warning is
4193 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4194 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4196 end Check_Ada_83_Warning;
4198 ---------------------
4199 -- Check_Arg_Count --
4200 ---------------------
4202 procedure Check_Arg_Count (Required : Nat) is
4204 if Arg_Count /= Required then
4205 Error_Pragma ("wrong number of arguments for pragma%");
4207 end Check_Arg_Count;
4209 --------------------------------
4210 -- Check_Arg_Is_External_Name --
4211 --------------------------------
4213 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4214 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4217 if Nkind (Argx) = N_Identifier then
4221 Analyze_And_Resolve (Argx, Standard_String);
4223 if Is_OK_Static_Expression (Argx) then
4226 elsif Etype (Argx) = Any_Type then
4229 -- An interesting special case, if we have a string literal and
4230 -- we are in Ada 83 mode, then we allow it even though it will
4231 -- not be flagged as static. This allows expected Ada 83 mode
4232 -- use of external names which are string literals, even though
4233 -- technically these are not static in Ada 83.
4235 elsif Ada_Version = Ada_83
4236 and then Nkind (Argx) = N_String_Literal
4240 -- Static expression that raises Constraint_Error. This has
4241 -- already been flagged, so just exit from pragma processing.
4243 elsif Is_OK_Static_Expression (Argx) then
4246 -- Here we have a real error (non-static expression)
4249 Error_Msg_Name_1 := Pname;
4252 Msg : constant String :=
4253 "argument for pragma% must be a identifier or "
4254 & "static string expression!";
4256 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4261 end Check_Arg_Is_External_Name;
4263 -----------------------------
4264 -- Check_Arg_Is_Identifier --
4265 -----------------------------
4267 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4268 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4270 if Nkind (Argx) /= N_Identifier then
4272 ("argument for pragma% must be identifier", Argx);
4274 end Check_Arg_Is_Identifier;
4276 ----------------------------------
4277 -- Check_Arg_Is_Integer_Literal --
4278 ----------------------------------
4280 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4281 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4283 if Nkind (Argx) /= N_Integer_Literal then
4285 ("argument for pragma% must be integer literal", Argx);
4287 end Check_Arg_Is_Integer_Literal;
4289 -------------------------------------------
4290 -- Check_Arg_Is_Library_Level_Local_Name --
4291 -------------------------------------------
4295 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4296 -- | library_unit_NAME
4298 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4300 Check_Arg_Is_Local_Name (Arg);
4302 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4303 and then Comes_From_Source (N)
4306 ("argument for pragma% must be library level entity", Arg);
4308 end Check_Arg_Is_Library_Level_Local_Name;
4310 -----------------------------
4311 -- Check_Arg_Is_Local_Name --
4312 -----------------------------
4316 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4317 -- | library_unit_NAME
4319 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4320 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4325 if Nkind (Argx) not in N_Direct_Name
4326 and then (Nkind (Argx) /= N_Attribute_Reference
4327 or else Present (Expressions (Argx))
4328 or else Nkind (Prefix (Argx)) /= N_Identifier)
4329 and then (not Is_Entity_Name (Argx)
4330 or else not Is_Compilation_Unit (Entity (Argx)))
4332 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4335 -- No further check required if not an entity name
4337 if not Is_Entity_Name (Argx) then
4343 Ent : constant Entity_Id := Entity (Argx);
4344 Scop : constant Entity_Id := Scope (Ent);
4347 -- Case of a pragma applied to a compilation unit: pragma must
4348 -- occur immediately after the program unit in the compilation.
4350 if Is_Compilation_Unit (Ent) then
4352 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4355 -- Case of pragma placed immediately after spec
4357 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4360 -- Case of pragma placed immediately after body
4362 elsif Nkind (Decl) = N_Subprogram_Declaration
4363 and then Present (Corresponding_Body (Decl))
4367 (Parent (Unit_Declaration_Node
4368 (Corresponding_Body (Decl))));
4370 -- All other cases are illegal
4377 -- Special restricted placement rule from 10.2.1(11.8/2)
4379 elsif Is_Generic_Formal (Ent)
4380 and then Prag_Id = Pragma_Preelaborable_Initialization
4382 OK := List_Containing (N) =
4383 Generic_Formal_Declarations
4384 (Unit_Declaration_Node (Scop));
4386 -- If this is an aspect applied to a subprogram body, the
4387 -- pragma is inserted in its declarative part.
4389 elsif From_Aspect_Specification (N)
4390 and then Ent = Current_Scope
4392 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4396 -- If the aspect is a predicate (possibly others ???) and the
4397 -- context is a record type, this is a discriminant expression
4398 -- within a type declaration, that freezes the predicated
4401 elsif From_Aspect_Specification (N)
4402 and then Prag_Id = Pragma_Predicate
4403 and then Ekind (Current_Scope) = E_Record_Type
4404 and then Scop = Scope (Current_Scope)
4408 -- Default case, just check that the pragma occurs in the scope
4409 -- of the entity denoted by the name.
4412 OK := Current_Scope = Scop;
4417 ("pragma% argument must be in same declarative part", Arg);
4421 end Check_Arg_Is_Local_Name;
4423 ---------------------------------
4424 -- Check_Arg_Is_Locking_Policy --
4425 ---------------------------------
4427 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
4428 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4431 Check_Arg_Is_Identifier (Argx);
4433 if not Is_Locking_Policy_Name (Chars (Argx)) then
4434 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
4436 end Check_Arg_Is_Locking_Policy;
4438 -----------------------------------------------
4439 -- Check_Arg_Is_Partition_Elaboration_Policy --
4440 -----------------------------------------------
4442 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
4443 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4446 Check_Arg_Is_Identifier (Argx);
4448 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
4450 ("& is not a valid partition elaboration policy name", Argx);
4452 end Check_Arg_Is_Partition_Elaboration_Policy;
4454 -------------------------
4455 -- Check_Arg_Is_One_Of --
4456 -------------------------
4458 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4459 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4462 Check_Arg_Is_Identifier (Argx);
4464 if not Nam_In (Chars (Argx), N1, N2) then
4465 Error_Msg_Name_2 := N1;
4466 Error_Msg_Name_3 := N2;
4467 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
4469 end Check_Arg_Is_One_Of;
4471 procedure Check_Arg_Is_One_Of
4473 N1, N2, N3 : Name_Id)
4475 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4478 Check_Arg_Is_Identifier (Argx);
4480 if not Nam_In (Chars (Argx), N1, N2, N3) then
4481 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4483 end Check_Arg_Is_One_Of;
4485 procedure Check_Arg_Is_One_Of
4487 N1, N2, N3, N4 : Name_Id)
4489 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4492 Check_Arg_Is_Identifier (Argx);
4494 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
4495 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4497 end Check_Arg_Is_One_Of;
4499 procedure Check_Arg_Is_One_Of
4501 N1, N2, N3, N4, N5 : Name_Id)
4503 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4506 Check_Arg_Is_Identifier (Argx);
4508 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
4509 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4511 end Check_Arg_Is_One_Of;
4513 ---------------------------------
4514 -- Check_Arg_Is_Queuing_Policy --
4515 ---------------------------------
4517 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
4518 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4521 Check_Arg_Is_Identifier (Argx);
4523 if not Is_Queuing_Policy_Name (Chars (Argx)) then
4524 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
4526 end Check_Arg_Is_Queuing_Policy;
4528 ---------------------------------------
4529 -- Check_Arg_Is_OK_Static_Expression --
4530 ---------------------------------------
4532 procedure Check_Arg_Is_OK_Static_Expression
4534 Typ : Entity_Id := Empty)
4537 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4538 end Check_Arg_Is_OK_Static_Expression;
4540 ------------------------------------------
4541 -- Check_Arg_Is_Task_Dispatching_Policy --
4542 ------------------------------------------
4544 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4545 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4548 Check_Arg_Is_Identifier (Argx);
4550 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4552 ("& is not an allowed task dispatching policy name", Argx);
4554 end Check_Arg_Is_Task_Dispatching_Policy;
4556 ---------------------
4557 -- Check_Arg_Order --
4558 ---------------------
4560 procedure Check_Arg_Order (Names : Name_List) is
4563 Highest_So_Far : Natural := 0;
4564 -- Highest index in Names seen do far
4568 for J in 1 .. Arg_Count loop
4569 if Chars (Arg) /= No_Name then
4570 for K in Names'Range loop
4571 if Chars (Arg) = Names (K) then
4572 if K < Highest_So_Far then
4573 Error_Msg_Name_1 := Pname;
4575 ("parameters out of order for pragma%", Arg);
4576 Error_Msg_Name_1 := Names (K);
4577 Error_Msg_Name_2 := Names (Highest_So_Far);
4578 Error_Msg_N ("\% must appear before %", Arg);
4582 Highest_So_Far := K;
4590 end Check_Arg_Order;
4592 --------------------------------
4593 -- Check_At_Least_N_Arguments --
4594 --------------------------------
4596 procedure Check_At_Least_N_Arguments (N : Nat) is
4598 if Arg_Count < N then
4599 Error_Pragma ("too few arguments for pragma%");
4601 end Check_At_Least_N_Arguments;
4603 -------------------------------
4604 -- Check_At_Most_N_Arguments --
4605 -------------------------------
4607 procedure Check_At_Most_N_Arguments (N : Nat) is
4610 if Arg_Count > N then
4612 for J in 1 .. N loop
4614 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4617 end Check_At_Most_N_Arguments;
4619 ---------------------
4620 -- Check_Component --
4621 ---------------------
4623 procedure Check_Component
4626 In_Variant_Part : Boolean := False)
4628 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4629 Sindic : constant Node_Id :=
4630 Subtype_Indication (Component_Definition (Comp));
4631 Typ : constant Entity_Id := Etype (Comp_Id);
4634 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4635 -- object constraint, then the component type shall be an Unchecked_
4638 if Nkind (Sindic) = N_Subtype_Indication
4639 and then Has_Per_Object_Constraint (Comp_Id)
4640 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4643 ("component subtype subject to per-object constraint "
4644 & "must be an Unchecked_Union", Comp);
4646 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4647 -- the body of a generic unit, or within the body of any of its
4648 -- descendant library units, no part of the type of a component
4649 -- declared in a variant_part of the unchecked union type shall be of
4650 -- a formal private type or formal private extension declared within
4651 -- the formal part of the generic unit.
4653 elsif Ada_Version >= Ada_2012
4654 and then In_Generic_Body (UU_Typ)
4655 and then In_Variant_Part
4656 and then Is_Private_Type (Typ)
4657 and then Is_Generic_Type (Typ)
4660 ("component of unchecked union cannot be of generic type", Comp);
4662 elsif Needs_Finalization (Typ) then
4664 ("component of unchecked union cannot be controlled", Comp);
4666 elsif Has_Task (Typ) then
4668 ("component of unchecked union cannot have tasks", Comp);
4670 end Check_Component;
4672 ----------------------------
4673 -- Check_Duplicate_Pragma --
4674 ----------------------------
4676 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4677 Id : Entity_Id := E;
4681 -- Nothing to do if this pragma comes from an aspect specification,
4682 -- since we could not be duplicating a pragma, and we dealt with the
4683 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4685 if From_Aspect_Specification (N) then
4689 -- Otherwise current pragma may duplicate previous pragma or a
4690 -- previously given aspect specification or attribute definition
4691 -- clause for the same pragma.
4693 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4697 -- If the entity is a type, then we have to make sure that the
4698 -- ostensible duplicate is not for a parent type from which this
4702 if Nkind (P) = N_Pragma then
4704 Args : constant List_Id :=
4705 Pragma_Argument_Associations (P);
4708 and then Is_Entity_Name (Expression (First (Args)))
4709 and then Is_Type (Entity (Expression (First (Args))))
4710 and then Entity (Expression (First (Args))) /= E
4716 elsif Nkind (P) = N_Aspect_Specification
4717 and then Is_Type (Entity (P))
4718 and then Entity (P) /= E
4724 -- Here we have a definite duplicate
4726 Error_Msg_Name_1 := Pragma_Name (N);
4727 Error_Msg_Sloc := Sloc (P);
4729 -- For a single protected or a single task object, the error is
4730 -- issued on the original entity.
4732 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4733 Id := Defining_Identifier (Original_Node (Parent (Id)));
4736 if Nkind (P) = N_Aspect_Specification
4737 or else From_Aspect_Specification (P)
4739 Error_Msg_NE ("aspect% for & previously given#", N, Id);
4741 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
4746 end Check_Duplicate_Pragma;
4748 ----------------------------------
4749 -- Check_Duplicated_Export_Name --
4750 ----------------------------------
4752 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
4753 String_Val : constant String_Id := Strval (Nam);
4756 -- We are only interested in the export case, and in the case of
4757 -- generics, it is the instance, not the template, that is the
4758 -- problem (the template will generate a warning in any case).
4760 if not Inside_A_Generic
4761 and then (Prag_Id = Pragma_Export
4763 Prag_Id = Pragma_Export_Procedure
4765 Prag_Id = Pragma_Export_Valued_Procedure
4767 Prag_Id = Pragma_Export_Function)
4769 for J in Externals.First .. Externals.Last loop
4770 if String_Equal (String_Val, Strval (Externals.Table (J))) then
4771 Error_Msg_Sloc := Sloc (Externals.Table (J));
4772 Error_Msg_N ("external name duplicates name given#", Nam);
4777 Externals.Append (Nam);
4779 end Check_Duplicated_Export_Name;
4781 ----------------------------------------
4782 -- Check_Expr_Is_OK_Static_Expression --
4783 ----------------------------------------
4785 procedure Check_Expr_Is_OK_Static_Expression
4787 Typ : Entity_Id := Empty)
4790 if Present (Typ) then
4791 Analyze_And_Resolve (Expr, Typ);
4793 Analyze_And_Resolve (Expr);
4796 if Is_OK_Static_Expression (Expr) then
4799 elsif Etype (Expr) = Any_Type then
4802 -- An interesting special case, if we have a string literal and we
4803 -- are in Ada 83 mode, then we allow it even though it will not be
4804 -- flagged as static. This allows the use of Ada 95 pragmas like
4805 -- Import in Ada 83 mode. They will of course be flagged with
4806 -- warnings as usual, but will not cause errors.
4808 elsif Ada_Version = Ada_83
4809 and then Nkind (Expr) = N_String_Literal
4813 -- Static expression that raises Constraint_Error. This has already
4814 -- been flagged, so just exit from pragma processing.
4816 elsif Is_OK_Static_Expression (Expr) then
4819 -- Finally, we have a real error
4822 Error_Msg_Name_1 := Pname;
4823 Flag_Non_Static_Expr
4824 (Fix_Error ("argument for pragma% must be a static expression!"),
4828 end Check_Expr_Is_OK_Static_Expression;
4830 -------------------------
4831 -- Check_First_Subtype --
4832 -------------------------
4834 procedure Check_First_Subtype (Arg : Node_Id) is
4835 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4836 Ent : constant Entity_Id := Entity (Argx);
4839 if Is_First_Subtype (Ent) then
4842 elsif Is_Type (Ent) then
4844 ("pragma% cannot apply to subtype", Argx);
4846 elsif Is_Object (Ent) then
4848 ("pragma% cannot apply to object, requires a type", Argx);
4852 ("pragma% cannot apply to&, requires a type", Argx);
4854 end Check_First_Subtype;
4856 ----------------------
4857 -- Check_Identifier --
4858 ----------------------
4860 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
4863 and then Nkind (Arg) = N_Pragma_Argument_Association
4865 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
4866 Error_Msg_Name_1 := Pname;
4867 Error_Msg_Name_2 := Id;
4868 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4872 end Check_Identifier;
4874 --------------------------------
4875 -- Check_Identifier_Is_One_Of --
4876 --------------------------------
4878 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4881 and then Nkind (Arg) = N_Pragma_Argument_Association
4883 if Chars (Arg) = No_Name then
4884 Error_Msg_Name_1 := Pname;
4885 Error_Msg_N ("pragma% argument expects an identifier", Arg);
4888 elsif Chars (Arg) /= N1
4889 and then Chars (Arg) /= N2
4891 Error_Msg_Name_1 := Pname;
4892 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
4896 end Check_Identifier_Is_One_Of;
4898 ---------------------------
4899 -- Check_In_Main_Program --
4900 ---------------------------
4902 procedure Check_In_Main_Program is
4903 P : constant Node_Id := Parent (N);
4906 -- Must be in subprogram body
4908 if Nkind (P) /= N_Subprogram_Body then
4909 Error_Pragma ("% pragma allowed only in subprogram");
4911 -- Otherwise warn if obviously not main program
4913 elsif Present (Parameter_Specifications (Specification (P)))
4914 or else not Is_Compilation_Unit (Defining_Entity (P))
4916 Error_Msg_Name_1 := Pname;
4918 ("??pragma% is only effective in main program", N);
4920 end Check_In_Main_Program;
4922 ---------------------------------------
4923 -- Check_Interrupt_Or_Attach_Handler --
4924 ---------------------------------------
4926 procedure Check_Interrupt_Or_Attach_Handler is
4927 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4928 Handler_Proc, Proc_Scope : Entity_Id;
4933 if Prag_Id = Pragma_Interrupt_Handler then
4934 Check_Restriction (No_Dynamic_Attachment, N);
4937 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4938 Proc_Scope := Scope (Handler_Proc);
4940 -- On AAMP only, a pragma Interrupt_Handler is supported for
4941 -- nonprotected parameterless procedures.
4943 if not AAMP_On_Target
4944 or else Prag_Id = Pragma_Attach_Handler
4946 if Ekind (Proc_Scope) /= E_Protected_Type then
4948 ("argument of pragma% must be protected procedure", Arg1);
4951 -- For pragma case (as opposed to access case), check placement.
4952 -- We don't need to do that for aspects, because we have the
4953 -- check that they aspect applies an appropriate procedure.
4955 if not From_Aspect_Specification (N)
4956 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
4958 Error_Pragma ("pragma% must be in protected definition");
4962 if not Is_Library_Level_Entity (Proc_Scope)
4963 or else (AAMP_On_Target
4964 and then not Is_Library_Level_Entity (Handler_Proc))
4967 ("argument for pragma% must be library level entity", Arg1);
4970 -- AI05-0033: A pragma cannot appear within a generic body, because
4971 -- instance can be in a nested scope. The check that protected type
4972 -- is itself a library-level declaration is done elsewhere.
4974 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4975 -- handle code prior to AI-0033. Analysis tools typically are not
4976 -- interested in this pragma in any case, so no need to worry too
4977 -- much about its placement.
4979 if Inside_A_Generic then
4980 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4981 and then In_Package_Body (Scope (Current_Scope))
4982 and then not Relaxed_RM_Semantics
4984 Error_Pragma ("pragma% cannot be used inside a generic");
4987 end Check_Interrupt_Or_Attach_Handler;
4989 ---------------------------------
4990 -- Check_Loop_Pragma_Placement --
4991 ---------------------------------
4993 procedure Check_Loop_Pragma_Placement is
4994 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
4995 -- Verify whether the current pragma is properly grouped with other
4996 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4997 -- related loop where the pragma appears.
4999 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5000 -- Determine whether an arbitrary statement Stmt denotes pragma
5001 -- Loop_Invariant or Loop_Variant.
5003 procedure Placement_Error (Constr : Node_Id);
5004 pragma No_Return (Placement_Error);
5005 -- Node Constr denotes the last loop restricted construct before we
5006 -- encountered an illegal relation between enclosing constructs. Emit
5007 -- an error depending on what Constr was.
5009 --------------------------------
5010 -- Check_Loop_Pragma_Grouping --
5011 --------------------------------
5013 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5014 Stop_Search : exception;
5015 -- This exception is used to terminate the recursive descent of
5016 -- routine Check_Grouping.
5018 procedure Check_Grouping (L : List_Id);
5019 -- Find the first group of pragmas in list L and if successful,
5020 -- ensure that the current pragma is part of that group. The
5021 -- routine raises Stop_Search once such a check is performed to
5022 -- halt the recursive descent.
5024 procedure Grouping_Error (Prag : Node_Id);
5025 pragma No_Return (Grouping_Error);
5026 -- Emit an error concerning the current pragma indicating that it
5027 -- should be placed after pragma Prag.
5029 --------------------
5030 -- Check_Grouping --
5031 --------------------
5033 procedure Check_Grouping (L : List_Id) is
5039 -- Inspect the list of declarations or statements looking for
5040 -- the first grouping of pragmas:
5043 -- pragma Loop_Invariant ...;
5044 -- pragma Loop_Variant ...;
5046 -- pragma Loop_Variant ...; -- current pragma
5048 -- If the current pragma is not in the grouping, then it must
5049 -- either appear in a different declarative or statement list
5050 -- or the construct at (1) is separating the pragma from the
5054 while Present (Stmt) loop
5056 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5057 -- inside a loop or a block housed inside a loop. Inspect
5058 -- the declarations and statements of the block as they may
5059 -- contain the first grouping.
5061 if Nkind (Stmt) = N_Block_Statement then
5062 HSS := Handled_Statement_Sequence (Stmt);
5064 Check_Grouping (Declarations (Stmt));
5066 if Present (HSS) then
5067 Check_Grouping (Statements (HSS));
5070 -- First pragma of the first topmost grouping has been found
5072 elsif Is_Loop_Pragma (Stmt) then
5074 -- The group and the current pragma are not in the same
5075 -- declarative or statement list.
5077 if List_Containing (Stmt) /= List_Containing (N) then
5078 Grouping_Error (Stmt);
5080 -- Try to reach the current pragma from the first pragma
5081 -- of the grouping while skipping other members:
5083 -- pragma Loop_Invariant ...; -- first pragma
5084 -- pragma Loop_Variant ...; -- member
5086 -- pragma Loop_Variant ...; -- current pragma
5089 while Present (Stmt) loop
5091 -- The current pragma is either the first pragma
5092 -- of the group or is a member of the group. Stop
5093 -- the search as the placement is legal.
5098 -- Skip group members, but keep track of the last
5099 -- pragma in the group.
5101 elsif Is_Loop_Pragma (Stmt) then
5104 -- Skip declarations and statements generated by
5105 -- the compiler during expansion.
5107 elsif not Comes_From_Source (Stmt) then
5110 -- A non-pragma is separating the group from the
5111 -- current pragma, the placement is illegal.
5114 Grouping_Error (Prag);
5120 -- If the traversal did not reach the current pragma,
5121 -- then the list must be malformed.
5123 raise Program_Error;
5131 --------------------
5132 -- Grouping_Error --
5133 --------------------
5135 procedure Grouping_Error (Prag : Node_Id) is
5137 Error_Msg_Sloc := Sloc (Prag);
5138 Error_Pragma ("pragma% must appear next to pragma#");
5141 -- Start of processing for Check_Loop_Pragma_Grouping
5144 -- Inspect the statements of the loop or nested blocks housed
5145 -- within to determine whether the current pragma is part of the
5146 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5148 Check_Grouping (Statements (Loop_Stmt));
5151 when Stop_Search => null;
5152 end Check_Loop_Pragma_Grouping;
5154 --------------------
5155 -- Is_Loop_Pragma --
5156 --------------------
5158 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5160 -- Inspect the original node as Loop_Invariant and Loop_Variant
5161 -- pragmas are rewritten to null when assertions are disabled.
5163 if Nkind (Original_Node (Stmt)) = N_Pragma then
5165 Nam_In (Pragma_Name (Original_Node (Stmt)),
5166 Name_Loop_Invariant,
5173 ---------------------
5174 -- Placement_Error --
5175 ---------------------
5177 procedure Placement_Error (Constr : Node_Id) is
5178 LA : constant String := " with Loop_Entry";
5181 if Prag_Id = Pragma_Assert then
5182 Error_Msg_String (1 .. LA'Length) := LA;
5183 Error_Msg_Strlen := LA'Length;
5185 Error_Msg_Strlen := 0;
5188 if Nkind (Constr) = N_Pragma then
5190 ("pragma %~ must appear immediately within the statements "
5194 ("block containing pragma %~ must appear immediately within "
5195 & "the statements of a loop", Constr);
5197 end Placement_Error;
5199 -- Local declarations
5204 -- Start of processing for Check_Loop_Pragma_Placement
5207 -- Check that pragma appears immediately within a loop statement,
5208 -- ignoring intervening block statements.
5212 while Present (Stmt) loop
5214 -- The pragma or previous block must appear immediately within the
5215 -- current block's declarative or statement part.
5217 if Nkind (Stmt) = N_Block_Statement then
5218 if (No (Declarations (Stmt))
5219 or else List_Containing (Prev) /= Declarations (Stmt))
5221 List_Containing (Prev) /=
5222 Statements (Handled_Statement_Sequence (Stmt))
5224 Placement_Error (Prev);
5227 -- Keep inspecting the parents because we are now within a
5228 -- chain of nested blocks.
5232 Stmt := Parent (Stmt);
5235 -- The pragma or previous block must appear immediately within the
5236 -- statements of the loop.
5238 elsif Nkind (Stmt) = N_Loop_Statement then
5239 if List_Containing (Prev) /= Statements (Stmt) then
5240 Placement_Error (Prev);
5243 -- Stop the traversal because we reached the innermost loop
5244 -- regardless of whether we encountered an error or not.
5248 -- Ignore a handled statement sequence. Note that this node may
5249 -- be related to a subprogram body in which case we will emit an
5250 -- error on the next iteration of the search.
5252 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5253 Stmt := Parent (Stmt);
5255 -- Any other statement breaks the chain from the pragma to the
5259 Placement_Error (Prev);
5264 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5265 -- grouped together with other such pragmas.
5267 if Is_Loop_Pragma (N) then
5269 -- The previous check should have located the related loop
5271 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5272 Check_Loop_Pragma_Grouping (Stmt);
5274 end Check_Loop_Pragma_Placement;
5276 -------------------------------------------
5277 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5278 -------------------------------------------
5280 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5289 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5292 elsif Nkind_In (P, N_Package_Specification,
5297 -- Note: the following tests seem a little peculiar, because
5298 -- they test for bodies, but if we were in the statement part
5299 -- of the body, we would already have hit the handled statement
5300 -- sequence, so the only way we get here is by being in the
5301 -- declarative part of the body.
5303 elsif Nkind_In (P, N_Subprogram_Body,
5314 Error_Pragma ("pragma% is not in declarative part or package spec");
5315 end Check_Is_In_Decl_Part_Or_Package_Spec;
5317 -------------------------
5318 -- Check_No_Identifier --
5319 -------------------------
5321 procedure Check_No_Identifier (Arg : Node_Id) is
5323 if Nkind (Arg) = N_Pragma_Argument_Association
5324 and then Chars (Arg) /= No_Name
5326 Error_Pragma_Arg_Ident
5327 ("pragma% does not permit identifier& here", Arg);
5329 end Check_No_Identifier;
5331 --------------------------
5332 -- Check_No_Identifiers --
5333 --------------------------
5335 procedure Check_No_Identifiers is
5339 for J in 1 .. Arg_Count loop
5340 Check_No_Identifier (Arg_Node);
5343 end Check_No_Identifiers;
5345 ------------------------
5346 -- Check_No_Link_Name --
5347 ------------------------
5349 procedure Check_No_Link_Name is
5351 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5355 if Present (Arg4) then
5357 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5359 end Check_No_Link_Name;
5361 -------------------------------
5362 -- Check_Optional_Identifier --
5363 -------------------------------
5365 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5368 and then Nkind (Arg) = N_Pragma_Argument_Association
5369 and then Chars (Arg) /= No_Name
5371 if Chars (Arg) /= Id then
5372 Error_Msg_Name_1 := Pname;
5373 Error_Msg_Name_2 := Id;
5374 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5378 end Check_Optional_Identifier;
5380 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5382 Name_Buffer (1 .. Id'Length) := Id;
5383 Name_Len := Id'Length;
5384 Check_Optional_Identifier (Arg, Name_Find);
5385 end Check_Optional_Identifier;
5387 -------------------------------------
5388 -- Check_Static_Boolean_Expression --
5389 -------------------------------------
5391 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5393 if Present (Expr) then
5394 Analyze_And_Resolve (Expr, Standard_Boolean);
5396 if not Is_OK_Static_Expression (Expr) then
5398 ("expression of pragma % must be static", Expr);
5401 end Check_Static_Boolean_Expression;
5403 -----------------------------
5404 -- Check_Static_Constraint --
5405 -----------------------------
5407 -- Note: for convenience in writing this procedure, in addition to
5408 -- the officially (i.e. by spec) allowed argument which is always a
5409 -- constraint, it also allows ranges and discriminant associations.
5410 -- Above is not clear ???
5412 procedure Check_Static_Constraint (Constr : Node_Id) is
5414 procedure Require_Static (E : Node_Id);
5415 -- Require given expression to be static expression
5417 --------------------
5418 -- Require_Static --
5419 --------------------
5421 procedure Require_Static (E : Node_Id) is
5423 if not Is_OK_Static_Expression (E) then
5424 Flag_Non_Static_Expr
5425 ("non-static constraint not allowed in Unchecked_Union!", E);
5430 -- Start of processing for Check_Static_Constraint
5433 case Nkind (Constr) is
5434 when N_Discriminant_Association =>
5435 Require_Static (Expression (Constr));
5438 Require_Static (Low_Bound (Constr));
5439 Require_Static (High_Bound (Constr));
5441 when N_Attribute_Reference =>
5442 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5443 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5445 when N_Range_Constraint =>
5446 Check_Static_Constraint (Range_Expression (Constr));
5448 when N_Index_Or_Discriminant_Constraint =>
5452 IDC := First (Constraints (Constr));
5453 while Present (IDC) loop
5454 Check_Static_Constraint (IDC);
5462 end Check_Static_Constraint;
5464 --------------------------------------
5465 -- Check_Valid_Configuration_Pragma --
5466 --------------------------------------
5468 -- A configuration pragma must appear in the context clause of a
5469 -- compilation unit, and only other pragmas may precede it. Note that
5470 -- the test also allows use in a configuration pragma file.
5472 procedure Check_Valid_Configuration_Pragma is
5474 if not Is_Configuration_Pragma then
5475 Error_Pragma ("incorrect placement for configuration pragma%");
5477 end Check_Valid_Configuration_Pragma;
5479 -------------------------------------
5480 -- Check_Valid_Library_Unit_Pragma --
5481 -------------------------------------
5483 procedure Check_Valid_Library_Unit_Pragma is
5485 Parent_Node : Node_Id;
5486 Unit_Name : Entity_Id;
5487 Unit_Kind : Node_Kind;
5488 Unit_Node : Node_Id;
5489 Sindex : Source_File_Index;
5492 if not Is_List_Member (N) then
5496 Plist := List_Containing (N);
5497 Parent_Node := Parent (Plist);
5499 if Parent_Node = Empty then
5502 -- Case of pragma appearing after a compilation unit. In this case
5503 -- it must have an argument with the corresponding name and must
5504 -- be part of the following pragmas of its parent.
5506 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5507 if Plist /= Pragmas_After (Parent_Node) then
5510 elsif Arg_Count = 0 then
5512 ("argument required if outside compilation unit");
5515 Check_No_Identifiers;
5516 Check_Arg_Count (1);
5517 Unit_Node := Unit (Parent (Parent_Node));
5518 Unit_Kind := Nkind (Unit_Node);
5520 Analyze (Get_Pragma_Arg (Arg1));
5522 if Unit_Kind = N_Generic_Subprogram_Declaration
5523 or else Unit_Kind = N_Subprogram_Declaration
5525 Unit_Name := Defining_Entity (Unit_Node);
5527 elsif Unit_Kind in N_Generic_Instantiation then
5528 Unit_Name := Defining_Entity (Unit_Node);
5531 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5534 if Chars (Unit_Name) /=
5535 Chars (Entity (Get_Pragma_Arg (Arg1)))
5538 ("pragma% argument is not current unit name", Arg1);
5541 if Ekind (Unit_Name) = E_Package
5542 and then Present (Renamed_Entity (Unit_Name))
5544 Error_Pragma ("pragma% not allowed for renamed package");
5548 -- Pragma appears other than after a compilation unit
5551 -- Here we check for the generic instantiation case and also
5552 -- for the case of processing a generic formal package. We
5553 -- detect these cases by noting that the Sloc on the node
5554 -- does not belong to the current compilation unit.
5556 Sindex := Source_Index (Current_Sem_Unit);
5558 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5559 Rewrite (N, Make_Null_Statement (Loc));
5562 -- If before first declaration, the pragma applies to the
5563 -- enclosing unit, and the name if present must be this name.
5565 elsif Is_Before_First_Decl (N, Plist) then
5566 Unit_Node := Unit_Declaration_Node (Current_Scope);
5567 Unit_Kind := Nkind (Unit_Node);
5569 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5572 elsif Unit_Kind = N_Subprogram_Body
5573 and then not Acts_As_Spec (Unit_Node)
5577 elsif Nkind (Parent_Node) = N_Package_Body then
5580 elsif Nkind (Parent_Node) = N_Package_Specification
5581 and then Plist = Private_Declarations (Parent_Node)
5585 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5586 or else Nkind (Parent_Node) =
5587 N_Generic_Subprogram_Declaration)
5588 and then Plist = Generic_Formal_Declarations (Parent_Node)
5592 elsif Arg_Count > 0 then
5593 Analyze (Get_Pragma_Arg (Arg1));
5595 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5597 ("name in pragma% must be enclosing unit", Arg1);
5600 -- It is legal to have no argument in this context
5606 -- Error if not before first declaration. This is because a
5607 -- library unit pragma argument must be the name of a library
5608 -- unit (RM 10.1.5(7)), but the only names permitted in this
5609 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5610 -- generic subprogram declarations or generic instantiations.
5614 ("pragma% misplaced, must be before first declaration");
5618 end Check_Valid_Library_Unit_Pragma;
5624 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5625 Clist : constant Node_Id := Component_List (Variant);
5629 Comp := First (Component_Items (Clist));
5630 while Present (Comp) loop
5631 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5636 ---------------------------
5637 -- Ensure_Aggregate_Form --
5638 ---------------------------
5640 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5641 CFSD : constant Boolean := Get_Comes_From_Source_Default;
5642 Expr : constant Node_Id := Expression (Arg);
5643 Loc : constant Source_Ptr := Sloc (Expr);
5644 Comps : List_Id := No_List;
5645 Exprs : List_Id := No_List;
5646 Nam : Name_Id := No_Name;
5647 Nam_Loc : Source_Ptr;
5650 -- The pragma argument is in positional form:
5652 -- pragma Depends (Nam => ...)
5656 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5657 -- argument association.
5659 if Nkind (Arg) = N_Pragma_Argument_Association then
5661 Nam_Loc := Sloc (Arg);
5663 -- Remove the pragma argument name as this will be captured in the
5666 Set_Chars (Arg, No_Name);
5669 -- The argument is already in aggregate form, but the presence of a
5670 -- name causes this to be interpreted as named association which in
5671 -- turn must be converted into an aggregate.
5673 -- pragma Global (In_Out => (A, B, C))
5677 -- pragma Global ((In_Out => (A, B, C)))
5679 -- aggregate aggregate
5681 if Nkind (Expr) = N_Aggregate then
5682 if Nam = No_Name then
5686 -- Do not transform a null argument into an aggregate as N_Null has
5687 -- special meaning in formal verification pragmas.
5689 elsif Nkind (Expr) = N_Null then
5693 -- Everything comes from source if the original comes from source
5695 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
5697 -- Positional argument is transformed into an aggregate with an
5698 -- Expressions list.
5700 if Nam = No_Name then
5701 Exprs := New_List (Relocate_Node (Expr));
5703 -- An associative argument is transformed into an aggregate with
5704 -- Component_Associations.
5708 Make_Component_Association (Loc,
5709 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
5710 Expression => Relocate_Node (Expr)));
5713 Set_Expression (Arg,
5714 Make_Aggregate (Loc,
5715 Component_Associations => Comps,
5716 Expressions => Exprs));
5718 -- Restore Comes_From_Source default
5720 Set_Comes_From_Source_Default (CFSD);
5721 end Ensure_Aggregate_Form;
5727 procedure Error_Pragma (Msg : String) is
5729 Error_Msg_Name_1 := Pname;
5730 Error_Msg_N (Fix_Error (Msg), N);
5734 ----------------------
5735 -- Error_Pragma_Arg --
5736 ----------------------
5738 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5740 Error_Msg_Name_1 := Pname;
5741 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5743 end Error_Pragma_Arg;
5745 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5747 Error_Msg_Name_1 := Pname;
5748 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
5749 Error_Pragma_Arg (Msg2, Arg);
5750 end Error_Pragma_Arg;
5752 ----------------------------
5753 -- Error_Pragma_Arg_Ident --
5754 ----------------------------
5756 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5758 Error_Msg_Name_1 := Pname;
5759 Error_Msg_N (Fix_Error (Msg), Arg);
5761 end Error_Pragma_Arg_Ident;
5763 ----------------------
5764 -- Error_Pragma_Ref --
5765 ----------------------
5767 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5769 Error_Msg_Name_1 := Pname;
5770 Error_Msg_Sloc := Sloc (Ref);
5771 Error_Msg_NE (Fix_Error (Msg), N, Ref);
5773 end Error_Pragma_Ref;
5775 ------------------------
5776 -- Find_Lib_Unit_Name --
5777 ------------------------
5779 function Find_Lib_Unit_Name return Entity_Id is
5781 -- Return inner compilation unit entity, for case of nested
5782 -- categorization pragmas. This happens in generic unit.
5784 if Nkind (Parent (N)) = N_Package_Specification
5785 and then Defining_Entity (Parent (N)) /= Current_Scope
5787 return Defining_Entity (Parent (N));
5789 return Current_Scope;
5791 end Find_Lib_Unit_Name;
5793 ----------------------------
5794 -- Find_Program_Unit_Name --
5795 ----------------------------
5797 procedure Find_Program_Unit_Name (Id : Node_Id) is
5798 Unit_Name : Entity_Id;
5799 Unit_Kind : Node_Kind;
5800 P : constant Node_Id := Parent (N);
5803 if Nkind (P) = N_Compilation_Unit then
5804 Unit_Kind := Nkind (Unit (P));
5806 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
5807 N_Package_Declaration)
5808 or else Unit_Kind in N_Generic_Declaration
5810 Unit_Name := Defining_Entity (Unit (P));
5812 if Chars (Id) = Chars (Unit_Name) then
5813 Set_Entity (Id, Unit_Name);
5814 Set_Etype (Id, Etype (Unit_Name));
5816 Set_Etype (Id, Any_Type);
5818 ("cannot find program unit referenced by pragma%");
5822 Set_Etype (Id, Any_Type);
5823 Error_Pragma ("pragma% inapplicable to this unit");
5829 end Find_Program_Unit_Name;
5831 -----------------------------------------
5832 -- Find_Unique_Parameterless_Procedure --
5833 -----------------------------------------
5835 function Find_Unique_Parameterless_Procedure
5837 Arg : Node_Id) return Entity_Id
5839 Proc : Entity_Id := Empty;
5842 -- The body of this procedure needs some comments ???
5844 if not Is_Entity_Name (Name) then
5846 ("argument of pragma% must be entity name", Arg);
5848 elsif not Is_Overloaded (Name) then
5849 Proc := Entity (Name);
5851 if Ekind (Proc) /= E_Procedure
5852 or else Present (First_Formal (Proc))
5855 ("argument of pragma% must be parameterless procedure", Arg);
5860 Found : Boolean := False;
5862 Index : Interp_Index;
5865 Get_First_Interp (Name, Index, It);
5866 while Present (It.Nam) loop
5869 if Ekind (Proc) = E_Procedure
5870 and then No (First_Formal (Proc))
5874 Set_Entity (Name, Proc);
5875 Set_Is_Overloaded (Name, False);
5878 ("ambiguous handler name for pragma% ", Arg);
5882 Get_Next_Interp (Index, It);
5887 ("argument of pragma% must be parameterless procedure",
5890 Proc := Entity (Name);
5896 end Find_Unique_Parameterless_Procedure;
5902 function Fix_Error (Msg : String) return String is
5903 Res : String (Msg'Range) := Msg;
5904 Res_Last : Natural := Msg'Last;
5908 -- If we have a rewriting of another pragma, go to that pragma
5910 if Is_Rewrite_Substitution (N)
5911 and then Nkind (Original_Node (N)) = N_Pragma
5913 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5916 -- Case where pragma comes from an aspect specification
5918 if From_Aspect_Specification (N) then
5920 -- Change appearence of "pragma" in message to "aspect"
5923 while J <= Res_Last - 5 loop
5924 if Res (J .. J + 5) = "pragma" then
5925 Res (J .. J + 5) := "aspect";
5933 -- Change "argument of" at start of message to "entity for"
5936 and then Res (Res'First .. Res'First + 10) = "argument of"
5938 Res (Res'First .. Res'First + 9) := "entity for";
5939 Res (Res'First + 10 .. Res_Last - 1) :=
5940 Res (Res'First + 11 .. Res_Last);
5941 Res_Last := Res_Last - 1;
5944 -- Change "argument" at start of message to "entity"
5947 and then Res (Res'First .. Res'First + 7) = "argument"
5949 Res (Res'First .. Res'First + 5) := "entity";
5950 Res (Res'First + 6 .. Res_Last - 2) :=
5951 Res (Res'First + 8 .. Res_Last);
5952 Res_Last := Res_Last - 2;
5955 -- Get name from corresponding aspect
5957 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
5960 -- Return possibly modified message
5962 return Res (Res'First .. Res_Last);
5965 -------------------------
5966 -- Gather_Associations --
5967 -------------------------
5969 procedure Gather_Associations
5971 Args : out Args_List)
5976 -- Initialize all parameters to Empty
5978 for J in Args'Range loop
5982 -- That's all we have to do if there are no argument associations
5984 if No (Pragma_Argument_Associations (N)) then
5988 -- Otherwise first deal with any positional parameters present
5990 Arg := First (Pragma_Argument_Associations (N));
5991 for Index in Args'Range loop
5992 exit when No (Arg) or else Chars (Arg) /= No_Name;
5993 Args (Index) := Get_Pragma_Arg (Arg);
5997 -- Positional parameters all processed, if any left, then we
5998 -- have too many positional parameters.
6000 if Present (Arg) and then Chars (Arg) = No_Name then
6002 ("too many positional associations for pragma%", Arg);
6005 -- Process named parameters if any are present
6007 while Present (Arg) loop
6008 if Chars (Arg) = No_Name then
6010 ("positional association cannot follow named association",
6014 for Index in Names'Range loop
6015 if Names (Index) = Chars (Arg) then
6016 if Present (Args (Index)) then
6018 ("duplicate argument association for pragma%", Arg);
6020 Args (Index) := Get_Pragma_Arg (Arg);
6025 if Index = Names'Last then
6026 Error_Msg_Name_1 := Pname;
6027 Error_Msg_N ("pragma% does not allow & argument", Arg);
6029 -- Check for possible misspelling
6031 for Index1 in Names'Range loop
6032 if Is_Bad_Spelling_Of
6033 (Chars (Arg), Names (Index1))
6035 Error_Msg_Name_1 := Names (Index1);
6036 Error_Msg_N -- CODEFIX
6037 ("\possible misspelling of%", Arg);
6049 end Gather_Associations;
6055 procedure GNAT_Pragma is
6057 -- We need to check the No_Implementation_Pragmas restriction for
6058 -- the case of a pragma from source. Note that the case of aspects
6059 -- generating corresponding pragmas marks these pragmas as not being
6060 -- from source, so this test also catches that case.
6062 if Comes_From_Source (N) then
6063 Check_Restriction (No_Implementation_Pragmas, N);
6067 --------------------------
6068 -- Is_Before_First_Decl --
6069 --------------------------
6071 function Is_Before_First_Decl
6072 (Pragma_Node : Node_Id;
6073 Decls : List_Id) return Boolean
6075 Item : Node_Id := First (Decls);
6078 -- Only other pragmas can come before this pragma
6081 if No (Item) or else Nkind (Item) /= N_Pragma then
6084 elsif Item = Pragma_Node then
6090 end Is_Before_First_Decl;
6092 -----------------------------
6093 -- Is_Configuration_Pragma --
6094 -----------------------------
6096 -- A configuration pragma must appear in the context clause of a
6097 -- compilation unit, and only other pragmas may precede it. Note that
6098 -- the test below also permits use in a configuration pragma file.
6100 function Is_Configuration_Pragma return Boolean is
6101 Lis : constant List_Id := List_Containing (N);
6102 Par : constant Node_Id := Parent (N);
6106 -- If no parent, then we are in the configuration pragma file,
6107 -- so the placement is definitely appropriate.
6112 -- Otherwise we must be in the context clause of a compilation unit
6113 -- and the only thing allowed before us in the context list is more
6114 -- configuration pragmas.
6116 elsif Nkind (Par) = N_Compilation_Unit
6117 and then Context_Items (Par) = Lis
6124 elsif Nkind (Prg) /= N_Pragma then
6134 end Is_Configuration_Pragma;
6136 --------------------------
6137 -- Is_In_Context_Clause --
6138 --------------------------
6140 function Is_In_Context_Clause return Boolean is
6142 Parent_Node : Node_Id;
6145 if not Is_List_Member (N) then
6149 Plist := List_Containing (N);
6150 Parent_Node := Parent (Plist);
6152 if Parent_Node = Empty
6153 or else Nkind (Parent_Node) /= N_Compilation_Unit
6154 or else Context_Items (Parent_Node) /= Plist
6161 end Is_In_Context_Clause;
6163 ---------------------------------
6164 -- Is_Static_String_Expression --
6165 ---------------------------------
6167 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6168 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6169 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6172 Analyze_And_Resolve (Argx);
6174 -- Special case Ada 83, where the expression will never be static,
6175 -- but we will return true if we had a string literal to start with.
6177 if Ada_Version = Ada_83 then
6180 -- Normal case, true only if we end up with a string literal that
6181 -- is marked as being the result of evaluating a static expression.
6184 return Is_OK_Static_Expression (Argx)
6185 and then Nkind (Argx) = N_String_Literal;
6188 end Is_Static_String_Expression;
6190 ----------------------
6191 -- Pragma_Misplaced --
6192 ----------------------
6194 procedure Pragma_Misplaced is
6196 Error_Pragma ("incorrect placement of pragma%");
6197 end Pragma_Misplaced;
6199 ------------------------------------------------
6200 -- Process_Atomic_Independent_Shared_Volatile --
6201 ------------------------------------------------
6203 procedure Process_Atomic_Independent_Shared_Volatile is
6209 procedure Set_Atomic_VFA (E : Entity_Id);
6210 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6211 -- no explicit alignment was given, set alignment to unknown, since
6212 -- back end knows what the alignment requirements are for atomic and
6213 -- full access arrays. Note: this is necessary for derived types.
6215 --------------------
6216 -- Set_Atomic_VFA --
6217 --------------------
6219 procedure Set_Atomic_VFA (E : Entity_Id) is
6221 if Prag_Id = Pragma_Volatile_Full_Access then
6222 Set_Is_Volatile_Full_Access (E);
6227 if not Has_Alignment_Clause (E) then
6228 Set_Alignment (E, Uint_0);
6232 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6235 Check_Ada_83_Warning;
6236 Check_No_Identifiers;
6237 Check_Arg_Count (1);
6238 Check_Arg_Is_Local_Name (Arg1);
6239 E_Id := Get_Pragma_Arg (Arg1);
6241 if Etype (E_Id) = Any_Type then
6246 D := Declaration_Node (E);
6249 -- A pragma that applies to a Ghost entity becomes Ghost for the
6250 -- purposes of legality checks and removal of ignored Ghost code.
6252 Mark_Pragma_As_Ghost (N, E);
6254 -- Check duplicate before we chain ourselves
6256 Check_Duplicate_Pragma (E);
6258 -- Check Atomic and VFA used together
6260 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6261 or else (Is_Volatile_Full_Access (E)
6262 and then (Prag_Id = Pragma_Atomic
6264 Prag_Id = Pragma_Shared))
6267 ("cannot have Volatile_Full_Access and Atomic for same entity");
6270 -- Check for applying VFA to an entity which has aliased component
6272 if Prag_Id = Pragma_Volatile_Full_Access then
6275 Aliased_Comp : Boolean := False;
6276 -- Set True if aliased component present
6279 if Is_Array_Type (Etype (E)) then
6280 Aliased_Comp := Has_Aliased_Components (Etype (E));
6282 -- Record case, too bad Has_Aliased_Components is not also
6283 -- set for records, should it be ???
6285 elsif Is_Record_Type (Etype (E)) then
6286 Comp := First_Component_Or_Discriminant (Etype (E));
6287 while Present (Comp) loop
6288 if Is_Aliased (Comp)
6289 or else Is_Aliased (Etype (Comp))
6291 Aliased_Comp := True;
6295 Next_Component_Or_Discriminant (Comp);
6299 if Aliased_Comp then
6301 ("cannot apply Volatile_Full_Access (aliased component "
6307 -- Now check appropriateness of the entity
6310 if Rep_Item_Too_Early (E, N)
6312 Rep_Item_Too_Late (E, N)
6316 Check_First_Subtype (Arg1);
6319 -- Attribute belongs on the base type. If the view of the type is
6320 -- currently private, it also belongs on the underlying type.
6322 if Prag_Id = Pragma_Atomic
6324 Prag_Id = Pragma_Shared
6326 Prag_Id = Pragma_Volatile_Full_Access
6329 Set_Atomic_VFA (Base_Type (E));
6330 Set_Atomic_VFA (Underlying_Type (E));
6333 -- Atomic/Shared/Volatile_Full_Access imply Independent
6335 if Prag_Id /= Pragma_Volatile then
6336 Set_Is_Independent (E);
6337 Set_Is_Independent (Base_Type (E));
6338 Set_Is_Independent (Underlying_Type (E));
6340 if Prag_Id = Pragma_Independent then
6341 Record_Independence_Check (N, Base_Type (E));
6345 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6347 if Prag_Id /= Pragma_Independent then
6348 Set_Is_Volatile (E);
6349 Set_Is_Volatile (Base_Type (E));
6350 Set_Is_Volatile (Underlying_Type (E));
6352 Set_Treat_As_Volatile (E);
6353 Set_Treat_As_Volatile (Underlying_Type (E));
6356 elsif K = N_Object_Declaration
6357 or else (K = N_Component_Declaration
6358 and then Original_Record_Component (E) = E)
6360 if Rep_Item_Too_Late (E, N) then
6364 if Prag_Id = Pragma_Atomic
6366 Prag_Id = Pragma_Shared
6368 Prag_Id = Pragma_Volatile_Full_Access
6370 if Prag_Id = Pragma_Volatile_Full_Access then
6371 Set_Is_Volatile_Full_Access (E);
6376 -- If the object declaration has an explicit initialization, a
6377 -- temporary may have to be created to hold the expression, to
6378 -- ensure that access to the object remain atomic.
6380 if Nkind (Parent (E)) = N_Object_Declaration
6381 and then Present (Expression (Parent (E)))
6383 Set_Has_Delayed_Freeze (E);
6387 -- Atomic/Shared/Volatile_Full_Access imply Independent
6389 if Prag_Id /= Pragma_Volatile then
6390 Set_Is_Independent (E);
6392 if Prag_Id = Pragma_Independent then
6393 Record_Independence_Check (N, E);
6397 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6399 if Prag_Id /= Pragma_Independent then
6400 Set_Is_Volatile (E);
6401 Set_Treat_As_Volatile (E);
6405 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6408 -- The following check is only relevant when SPARK_Mode is on as
6409 -- this is not a standard Ada legality rule. Pragma Volatile can
6410 -- only apply to a full type declaration or an object declaration
6411 -- (SPARK RM C.6(1)).
6414 and then Prag_Id = Pragma_Volatile
6415 and then not Nkind_In (K, N_Full_Type_Declaration,
6416 N_Object_Declaration)
6419 ("argument of pragma % must denote a full type or object "
6420 & "declaration", Arg1);
6422 end Process_Atomic_Independent_Shared_Volatile;
6424 -------------------------------------------
6425 -- Process_Compile_Time_Warning_Or_Error --
6426 -------------------------------------------
6428 procedure Process_Compile_Time_Warning_Or_Error is
6429 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6432 Check_Arg_Count (2);
6433 Check_No_Identifiers;
6434 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6435 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6437 if Compile_Time_Known_Value (Arg1x) then
6438 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6440 Str : constant String_Id :=
6441 Strval (Get_Pragma_Arg (Arg2));
6442 Len : constant Int := String_Length (Str);
6447 Cent : constant Entity_Id :=
6448 Cunit_Entity (Current_Sem_Unit);
6450 Force : constant Boolean :=
6451 Prag_Id = Pragma_Compile_Time_Warning
6453 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6454 and then (Ekind (Cent) /= E_Package
6455 or else not In_Private_Part (Cent));
6456 -- Set True if this is the warning case, and we are in the
6457 -- visible part of a package spec, or in a subprogram spec,
6458 -- in which case we want to force the client to see the
6459 -- warning, even though it is not in the main unit.
6462 -- Loop through segments of message separated by line feeds.
6463 -- We output these segments as separate messages with
6464 -- continuation marks for all but the first.
6469 Error_Msg_Strlen := 0;
6471 -- Loop to copy characters from argument to error message
6475 exit when Ptr > Len;
6476 CC := Get_String_Char (Str, Ptr);
6479 -- Ignore wide chars ??? else store character
6481 if In_Character_Range (CC) then
6482 C := Get_Character (CC);
6483 exit when C = ASCII.LF;
6484 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6485 Error_Msg_String (Error_Msg_Strlen) := C;
6489 -- Here with one line ready to go
6491 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6493 -- If this is a warning in a spec, then we want clients
6494 -- to see the warning, so mark the message with the
6495 -- special sequence !! to force the warning. In the case
6496 -- of a package spec, we do not force this if we are in
6497 -- the private part of the spec.
6500 if Cont = False then
6501 Error_Msg_N ("<<~!!", Arg1);
6504 Error_Msg_N ("\<<~!!", Arg1);
6507 -- Error, rather than warning, or in a body, so we do not
6508 -- need to force visibility for client (error will be
6509 -- output in any case, and this is the situation in which
6510 -- we do not want a client to get a warning, since the
6511 -- warning is in the body or the spec private part).
6514 if Cont = False then
6515 Error_Msg_N ("<<~", Arg1);
6518 Error_Msg_N ("\<<~", Arg1);
6522 exit when Ptr > Len;
6527 end Process_Compile_Time_Warning_Or_Error;
6529 ------------------------
6530 -- Process_Convention --
6531 ------------------------
6533 procedure Process_Convention
6534 (C : out Convention_Id;
6535 Ent : out Entity_Id)
6539 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6540 -- Called if we have more than one Export/Import/Convention pragma.
6541 -- This is generally illegal, but we have a special case of allowing
6542 -- Import and Interface to coexist if they specify the convention in
6543 -- a consistent manner. We are allowed to do this, since Interface is
6544 -- an implementation defined pragma, and we choose to do it since we
6545 -- know Rational allows this combination. S is the entity id of the
6546 -- subprogram in question. This procedure also sets the special flag
6547 -- Import_Interface_Present in both pragmas in the case where we do
6548 -- have matching Import and Interface pragmas.
6550 procedure Set_Convention_From_Pragma (E : Entity_Id);
6551 -- Set convention in entity E, and also flag that the entity has a
6552 -- convention pragma. If entity is for a private or incomplete type,
6553 -- also set convention and flag on underlying type. This procedure
6554 -- also deals with the special case of C_Pass_By_Copy convention,
6555 -- and error checks for inappropriate convention specification.
6557 -------------------------------
6558 -- Diagnose_Multiple_Pragmas --
6559 -------------------------------
6561 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6562 Pdec : constant Node_Id := Declaration_Node (S);
6566 function Same_Convention (Decl : Node_Id) return Boolean;
6567 -- Decl is a pragma node. This function returns True if this
6568 -- pragma has a first argument that is an identifier with a
6569 -- Chars field corresponding to the Convention_Id C.
6571 function Same_Name (Decl : Node_Id) return Boolean;
6572 -- Decl is a pragma node. This function returns True if this
6573 -- pragma has a second argument that is an identifier with a
6574 -- Chars field that matches the Chars of the current subprogram.
6576 ---------------------
6577 -- Same_Convention --
6578 ---------------------
6580 function Same_Convention (Decl : Node_Id) return Boolean is
6581 Arg1 : constant Node_Id :=
6582 First (Pragma_Argument_Associations (Decl));
6585 if Present (Arg1) then
6587 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6589 if Nkind (Arg) = N_Identifier
6590 and then Is_Convention_Name (Chars (Arg))
6591 and then Get_Convention_Id (Chars (Arg)) = C
6599 end Same_Convention;
6605 function Same_Name (Decl : Node_Id) return Boolean is
6606 Arg1 : constant Node_Id :=
6607 First (Pragma_Argument_Associations (Decl));
6615 Arg2 := Next (Arg1);
6622 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6624 if Nkind (Arg) = N_Identifier
6625 and then Chars (Arg) = Chars (S)
6634 -- Start of processing for Diagnose_Multiple_Pragmas
6639 -- Definitely give message if we have Convention/Export here
6641 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6644 -- If we have an Import or Export, scan back from pragma to
6645 -- find any previous pragma applying to the same procedure.
6646 -- The scan will be terminated by the start of the list, or
6647 -- hitting the subprogram declaration. This won't allow one
6648 -- pragma to appear in the public part and one in the private
6649 -- part, but that seems very unlikely in practice.
6653 while Present (Decl) and then Decl /= Pdec loop
6655 -- Look for pragma with same name as us
6657 if Nkind (Decl) = N_Pragma
6658 and then Same_Name (Decl)
6660 -- Give error if same as our pragma or Export/Convention
6662 if Nam_In (Pragma_Name (Decl), Name_Export,
6668 -- Case of Import/Interface or the other way round
6670 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6673 -- Here we know that we have Import and Interface. It
6674 -- doesn't matter which way round they are. See if
6675 -- they specify the same convention. If so, all OK,
6676 -- and set special flags to stop other messages
6678 if Same_Convention (Decl) then
6679 Set_Import_Interface_Present (N);
6680 Set_Import_Interface_Present (Decl);
6683 -- If different conventions, special message
6686 Error_Msg_Sloc := Sloc (Decl);
6688 ("convention differs from that given#", Arg1);
6698 -- Give message if needed if we fall through those tests
6699 -- except on Relaxed_RM_Semantics where we let go: either this
6700 -- is a case accepted/ignored by other Ada compilers (e.g.
6701 -- a mix of Convention and Import), or another error will be
6702 -- generated later (e.g. using both Import and Export).
6704 if Err and not Relaxed_RM_Semantics then
6706 ("at most one Convention/Export/Import pragma is allowed",
6709 end Diagnose_Multiple_Pragmas;
6711 --------------------------------
6712 -- Set_Convention_From_Pragma --
6713 --------------------------------
6715 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6717 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6718 -- for an overridden dispatching operation. Technically this is
6719 -- an amendment and should only be done in Ada 2005 mode. However,
6720 -- this is clearly a mistake, since the problem that is addressed
6721 -- by this AI is that there is a clear gap in the RM.
6723 if Is_Dispatching_Operation (E)
6724 and then Present (Overridden_Operation (E))
6725 and then C /= Convention (Overridden_Operation (E))
6728 ("cannot change convention for overridden dispatching "
6729 & "operation", Arg1);
6732 -- Special checks for Convention_Stdcall
6734 if C = Convention_Stdcall then
6736 -- A dispatching call is not allowed. A dispatching subprogram
6737 -- cannot be used to interface to the Win32 API, so in fact
6738 -- this check does not impose any effective restriction.
6740 if Is_Dispatching_Operation (E) then
6741 Error_Msg_Sloc := Sloc (E);
6743 -- Note: make this unconditional so that if there is more
6744 -- than one call to which the pragma applies, we get a
6745 -- message for each call. Also don't use Error_Pragma,
6746 -- so that we get multiple messages.
6749 ("dispatching subprogram# cannot use Stdcall convention!",
6752 -- Subprograms are not allowed
6754 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
6758 and then Ekind (E) /= E_Variable
6760 -- An access to subprogram is also allowed
6764 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
6766 -- Allow internal call to set convention of subprogram type
6768 and then not (Ekind (E) = E_Subprogram_Type)
6771 ("second argument of pragma% must be subprogram (type)",
6776 -- Set the convention
6778 Set_Convention (E, C);
6779 Set_Has_Convention_Pragma (E);
6781 -- For the case of a record base type, also set the convention of
6782 -- any anonymous access types declared in the record which do not
6783 -- currently have a specified convention.
6785 if Is_Record_Type (E) and then Is_Base_Type (E) then
6790 Comp := First_Component (E);
6791 while Present (Comp) loop
6792 if Present (Etype (Comp))
6793 and then Ekind_In (Etype (Comp),
6794 E_Anonymous_Access_Type,
6795 E_Anonymous_Access_Subprogram_Type)
6796 and then not Has_Convention_Pragma (Comp)
6798 Set_Convention (Comp, C);
6801 Next_Component (Comp);
6806 -- Deal with incomplete/private type case, where underlying type
6807 -- is available, so set convention of that underlying type.
6809 if Is_Incomplete_Or_Private_Type (E)
6810 and then Present (Underlying_Type (E))
6812 Set_Convention (Underlying_Type (E), C);
6813 Set_Has_Convention_Pragma (Underlying_Type (E), True);
6816 -- A class-wide type should inherit the convention of the specific
6817 -- root type (although this isn't specified clearly by the RM).
6819 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
6820 Set_Convention (Class_Wide_Type (E), C);
6823 -- If the entity is a record type, then check for special case of
6824 -- C_Pass_By_Copy, which is treated the same as C except that the
6825 -- special record flag is set. This convention is only permitted
6826 -- on record types (see AI95-00131).
6828 if Cname = Name_C_Pass_By_Copy then
6829 if Is_Record_Type (E) then
6830 Set_C_Pass_By_Copy (Base_Type (E));
6831 elsif Is_Incomplete_Or_Private_Type (E)
6832 and then Is_Record_Type (Underlying_Type (E))
6834 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
6837 ("C_Pass_By_Copy convention allowed only for record type",
6842 -- If the entity is a derived boolean type, check for the special
6843 -- case of convention C, C++, or Fortran, where we consider any
6844 -- nonzero value to represent true.
6846 if Is_Discrete_Type (E)
6847 and then Root_Type (Etype (E)) = Standard_Boolean
6853 C = Convention_Fortran)
6855 Set_Nonzero_Is_True (Base_Type (E));
6857 end Set_Convention_From_Pragma;
6861 Comp_Unit : Unit_Number_Type;
6866 -- Start of processing for Process_Convention
6869 Check_At_Least_N_Arguments (2);
6870 Check_Optional_Identifier (Arg1, Name_Convention);
6871 Check_Arg_Is_Identifier (Arg1);
6872 Cname := Chars (Get_Pragma_Arg (Arg1));
6874 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6875 -- tested again below to set the critical flag).
6877 if Cname = Name_C_Pass_By_Copy then
6880 -- Otherwise we must have something in the standard convention list
6882 elsif Is_Convention_Name (Cname) then
6883 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6885 -- Otherwise warn on unrecognized convention
6888 if Warn_On_Export_Import then
6890 ("??unrecognized convention name, C assumed",
6891 Get_Pragma_Arg (Arg1));
6897 Check_Optional_Identifier (Arg2, Name_Entity);
6898 Check_Arg_Is_Local_Name (Arg2);
6900 Id := Get_Pragma_Arg (Arg2);
6903 if not Is_Entity_Name (Id) then
6904 Error_Pragma_Arg ("entity name required", Arg2);
6909 -- Set entity to return
6913 -- Ada_Pass_By_Copy special checking
6915 if C = Convention_Ada_Pass_By_Copy then
6916 if not Is_First_Subtype (E) then
6918 ("convention `Ada_Pass_By_Copy` only allowed for types",
6922 if Is_By_Reference_Type (E) then
6924 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6928 -- Ada_Pass_By_Reference special checking
6930 elsif C = Convention_Ada_Pass_By_Reference then
6931 if not Is_First_Subtype (E) then
6933 ("convention `Ada_Pass_By_Reference` only allowed for types",
6937 if Is_By_Copy_Type (E) then
6939 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6944 -- Go to renamed subprogram if present, since convention applies to
6945 -- the actual renamed entity, not to the renaming entity. If the
6946 -- subprogram is inherited, go to parent subprogram.
6948 if Is_Subprogram (E)
6949 and then Present (Alias (E))
6951 if Nkind (Parent (Declaration_Node (E))) =
6952 N_Subprogram_Renaming_Declaration
6954 if Scope (E) /= Scope (Alias (E)) then
6956 ("cannot apply pragma% to non-local entity&#", E);
6961 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6962 N_Private_Extension_Declaration)
6963 and then Scope (E) = Scope (Alias (E))
6967 -- Return the parent subprogram the entity was inherited from
6973 -- Check that we are not applying this to a specless body. Relax this
6974 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6976 if Is_Subprogram (E)
6977 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6978 and then not Relaxed_RM_Semantics
6981 ("pragma% requires separate spec and must come before body");
6984 -- Check that we are not applying this to a named constant
6986 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6987 Error_Msg_Name_1 := Pname;
6989 ("cannot apply pragma% to named constant!",
6990 Get_Pragma_Arg (Arg2));
6992 ("\supply appropriate type for&!", Arg2);
6995 if Ekind (E) = E_Enumeration_Literal then
6996 Error_Pragma ("enumeration literal not allowed for pragma%");
6999 -- Check for rep item appearing too early or too late
7001 if Etype (E) = Any_Type
7002 or else Rep_Item_Too_Early (E, N)
7006 elsif Present (Underlying_Type (E)) then
7007 E := Underlying_Type (E);
7010 if Rep_Item_Too_Late (E, N) then
7014 if Has_Convention_Pragma (E) then
7015 Diagnose_Multiple_Pragmas (E);
7017 elsif Convention (E) = Convention_Protected
7018 or else Ekind (Scope (E)) = E_Protected_Type
7021 ("a protected operation cannot be given a different convention",
7025 -- For Intrinsic, a subprogram is required
7027 if C = Convention_Intrinsic
7028 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7031 ("second argument of pragma% must be a subprogram", Arg2);
7034 -- Deal with non-subprogram cases
7036 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7037 Set_Convention_From_Pragma (E);
7041 -- The pragma must apply to a first subtype, but it can also
7042 -- apply to a generic type in a generic formal part, in which
7043 -- case it will also appear in the corresponding instance.
7045 if Is_Generic_Type (E) or else In_Instance then
7048 Check_First_Subtype (Arg2);
7051 Set_Convention_From_Pragma (Base_Type (E));
7053 -- For access subprograms, we must set the convention on the
7054 -- internally generated directly designated type as well.
7056 if Ekind (E) = E_Access_Subprogram_Type then
7057 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7061 -- For the subprogram case, set proper convention for all homonyms
7062 -- in same scope and the same declarative part, i.e. the same
7063 -- compilation unit.
7066 Comp_Unit := Get_Source_Unit (E);
7067 Set_Convention_From_Pragma (E);
7069 -- Treat a pragma Import as an implicit body, and pragma import
7070 -- as implicit reference (for navigation in GPS).
7072 if Prag_Id = Pragma_Import then
7073 Generate_Reference (E, Id, 'b');
7075 -- For exported entities we restrict the generation of references
7076 -- to entities exported to foreign languages since entities
7077 -- exported to Ada do not provide further information to GPS and
7078 -- add undesired references to the output of the gnatxref tool.
7080 elsif Prag_Id = Pragma_Export
7081 and then Convention (E) /= Convention_Ada
7083 Generate_Reference (E, Id, 'i');
7086 -- If the pragma comes from an aspect, it only applies to the
7087 -- given entity, not its homonyms.
7089 if From_Aspect_Specification (N) then
7093 -- Otherwise Loop through the homonyms of the pragma argument's
7094 -- entity, an apply convention to those in the current scope.
7100 exit when No (E1) or else Scope (E1) /= Current_Scope;
7102 -- Ignore entry for which convention is already set
7104 if Has_Convention_Pragma (E1) then
7108 -- Do not set the pragma on inherited operations or on formal
7111 if Comes_From_Source (E1)
7112 and then Comp_Unit = Get_Source_Unit (E1)
7113 and then not Is_Formal_Subprogram (E1)
7114 and then Nkind (Original_Node (Parent (E1))) /=
7115 N_Full_Type_Declaration
7117 if Present (Alias (E1))
7118 and then Scope (E1) /= Scope (Alias (E1))
7121 ("cannot apply pragma% to non-local entity& declared#",
7125 Set_Convention_From_Pragma (E1);
7127 if Prag_Id = Pragma_Import then
7128 Generate_Reference (E1, Id, 'b');
7136 end Process_Convention;
7138 ----------------------------------------
7139 -- Process_Disable_Enable_Atomic_Sync --
7140 ----------------------------------------
7142 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7144 Check_No_Identifiers;
7145 Check_At_Most_N_Arguments (1);
7147 -- Modeled internally as
7148 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7152 Pragma_Identifier =>
7153 Make_Identifier (Loc, Nam),
7154 Pragma_Argument_Associations => New_List (
7155 Make_Pragma_Argument_Association (Loc,
7157 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7159 if Present (Arg1) then
7160 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7164 end Process_Disable_Enable_Atomic_Sync;
7166 -------------------------------------------------
7167 -- Process_Extended_Import_Export_Internal_Arg --
7168 -------------------------------------------------
7170 procedure Process_Extended_Import_Export_Internal_Arg
7171 (Arg_Internal : Node_Id := Empty)
7174 if No (Arg_Internal) then
7175 Error_Pragma ("Internal parameter required for pragma%");
7178 if Nkind (Arg_Internal) = N_Identifier then
7181 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7182 and then (Prag_Id = Pragma_Import_Function
7184 Prag_Id = Pragma_Export_Function)
7190 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7193 Check_Arg_Is_Local_Name (Arg_Internal);
7194 end Process_Extended_Import_Export_Internal_Arg;
7196 --------------------------------------------------
7197 -- Process_Extended_Import_Export_Object_Pragma --
7198 --------------------------------------------------
7200 procedure Process_Extended_Import_Export_Object_Pragma
7201 (Arg_Internal : Node_Id;
7202 Arg_External : Node_Id;
7208 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7209 Def_Id := Entity (Arg_Internal);
7211 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7213 ("pragma% must designate an object", Arg_Internal);
7216 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7218 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7221 ("previous Common/Psect_Object applies, pragma % not permitted",
7225 if Rep_Item_Too_Late (Def_Id, N) then
7229 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7231 if Present (Arg_Size) then
7232 Check_Arg_Is_External_Name (Arg_Size);
7235 -- Export_Object case
7237 if Prag_Id = Pragma_Export_Object then
7238 if not Is_Library_Level_Entity (Def_Id) then
7240 ("argument for pragma% must be library level entity",
7244 if Ekind (Current_Scope) = E_Generic_Package then
7245 Error_Pragma ("pragma& cannot appear in a generic unit");
7248 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7250 ("exported object must have compile time known size",
7254 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7255 Error_Msg_N ("??duplicate Export_Object pragma", N);
7257 Set_Exported (Def_Id, Arg_Internal);
7260 -- Import_Object case
7263 if Is_Concurrent_Type (Etype (Def_Id)) then
7265 ("cannot use pragma% for task/protected object",
7269 if Ekind (Def_Id) = E_Constant then
7271 ("cannot import a constant", Arg_Internal);
7274 if Warn_On_Export_Import
7275 and then Has_Discriminants (Etype (Def_Id))
7278 ("imported value must be initialized??", Arg_Internal);
7281 if Warn_On_Export_Import
7282 and then Is_Access_Type (Etype (Def_Id))
7285 ("cannot import object of an access type??", Arg_Internal);
7288 if Warn_On_Export_Import
7289 and then Is_Imported (Def_Id)
7291 Error_Msg_N ("??duplicate Import_Object pragma", N);
7293 -- Check for explicit initialization present. Note that an
7294 -- initialization generated by the code generator, e.g. for an
7295 -- access type, does not count here.
7297 elsif Present (Expression (Parent (Def_Id)))
7300 (Original_Node (Expression (Parent (Def_Id))))
7302 Error_Msg_Sloc := Sloc (Def_Id);
7304 ("imported entities cannot be initialized (RM B.1(24))",
7305 "\no initialization allowed for & declared#", Arg1);
7307 Set_Imported (Def_Id);
7308 Note_Possible_Modification (Arg_Internal, Sure => False);
7311 end Process_Extended_Import_Export_Object_Pragma;
7313 ------------------------------------------------------
7314 -- Process_Extended_Import_Export_Subprogram_Pragma --
7315 ------------------------------------------------------
7317 procedure Process_Extended_Import_Export_Subprogram_Pragma
7318 (Arg_Internal : Node_Id;
7319 Arg_External : Node_Id;
7320 Arg_Parameter_Types : Node_Id;
7321 Arg_Result_Type : Node_Id := Empty;
7322 Arg_Mechanism : Node_Id;
7323 Arg_Result_Mechanism : Node_Id := Empty)
7329 Ambiguous : Boolean;
7332 function Same_Base_Type
7334 Formal : Entity_Id) return Boolean;
7335 -- Determines if Ptype references the type of Formal. Note that only
7336 -- the base types need to match according to the spec. Ptype here is
7337 -- the argument from the pragma, which is either a type name, or an
7338 -- access attribute.
7340 --------------------
7341 -- Same_Base_Type --
7342 --------------------
7344 function Same_Base_Type
7346 Formal : Entity_Id) return Boolean
7348 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7352 -- Case where pragma argument is typ'Access
7354 if Nkind (Ptype) = N_Attribute_Reference
7355 and then Attribute_Name (Ptype) = Name_Access
7357 Pref := Prefix (Ptype);
7360 if not Is_Entity_Name (Pref)
7361 or else Entity (Pref) = Any_Type
7366 -- We have a match if the corresponding argument is of an
7367 -- anonymous access type, and its designated type matches the
7368 -- type of the prefix of the access attribute
7370 return Ekind (Ftyp) = E_Anonymous_Access_Type
7371 and then Base_Type (Entity (Pref)) =
7372 Base_Type (Etype (Designated_Type (Ftyp)));
7374 -- Case where pragma argument is a type name
7379 if not Is_Entity_Name (Ptype)
7380 or else Entity (Ptype) = Any_Type
7385 -- We have a match if the corresponding argument is of the type
7386 -- given in the pragma (comparing base types)
7388 return Base_Type (Entity (Ptype)) = Ftyp;
7392 -- Start of processing for
7393 -- Process_Extended_Import_Export_Subprogram_Pragma
7396 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7400 -- Loop through homonyms (overloadings) of the entity
7402 Hom_Id := Entity (Arg_Internal);
7403 while Present (Hom_Id) loop
7404 Def_Id := Get_Base_Subprogram (Hom_Id);
7406 -- We need a subprogram in the current scope
7408 if not Is_Subprogram (Def_Id)
7409 or else Scope (Def_Id) /= Current_Scope
7416 -- Pragma cannot apply to subprogram body
7418 if Is_Subprogram (Def_Id)
7419 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7423 ("pragma% requires separate spec"
7424 & " and must come before body");
7427 -- Test result type if given, note that the result type
7428 -- parameter can only be present for the function cases.
7430 if Present (Arg_Result_Type)
7431 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7435 elsif Etype (Def_Id) /= Standard_Void_Type
7437 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7441 -- Test parameter types if given. Note that this parameter
7442 -- has not been analyzed (and must not be, since it is
7443 -- semantic nonsense), so we get it as the parser left it.
7445 elsif Present (Arg_Parameter_Types) then
7446 Check_Matching_Types : declare
7451 Formal := First_Formal (Def_Id);
7453 if Nkind (Arg_Parameter_Types) = N_Null then
7454 if Present (Formal) then
7458 -- A list of one type, e.g. (List) is parsed as
7459 -- a parenthesized expression.
7461 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7462 and then Paren_Count (Arg_Parameter_Types) = 1
7465 or else Present (Next_Formal (Formal))
7470 Same_Base_Type (Arg_Parameter_Types, Formal);
7473 -- A list of more than one type is parsed as a aggregate
7475 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7476 and then Paren_Count (Arg_Parameter_Types) = 0
7478 Ptype := First (Expressions (Arg_Parameter_Types));
7479 while Present (Ptype) or else Present (Formal) loop
7482 or else not Same_Base_Type (Ptype, Formal)
7487 Next_Formal (Formal);
7492 -- Anything else is of the wrong form
7496 ("wrong form for Parameter_Types parameter",
7497 Arg_Parameter_Types);
7499 end Check_Matching_Types;
7502 -- Match is now False if the entry we found did not match
7503 -- either a supplied Parameter_Types or Result_Types argument
7509 -- Ambiguous case, the flag Ambiguous shows if we already
7510 -- detected this and output the initial messages.
7513 if not Ambiguous then
7515 Error_Msg_Name_1 := Pname;
7517 ("pragma% does not uniquely identify subprogram!",
7519 Error_Msg_Sloc := Sloc (Ent);
7520 Error_Msg_N ("matching subprogram #!", N);
7524 Error_Msg_Sloc := Sloc (Def_Id);
7525 Error_Msg_N ("matching subprogram #!", N);
7530 Hom_Id := Homonym (Hom_Id);
7533 -- See if we found an entry
7536 if not Ambiguous then
7537 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7539 ("pragma% cannot be given for generic subprogram");
7542 ("pragma% does not identify local subprogram");
7549 -- Import pragmas must be for imported entities
7551 if Prag_Id = Pragma_Import_Function
7553 Prag_Id = Pragma_Import_Procedure
7555 Prag_Id = Pragma_Import_Valued_Procedure
7557 if not Is_Imported (Ent) then
7559 ("pragma Import or Interface must precede pragma%");
7562 -- Here we have the Export case which can set the entity as exported
7564 -- But does not do so if the specified external name is null, since
7565 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7566 -- compatible) to request no external name.
7568 elsif Nkind (Arg_External) = N_String_Literal
7569 and then String_Length (Strval (Arg_External)) = 0
7573 -- In all other cases, set entity as exported
7576 Set_Exported (Ent, Arg_Internal);
7579 -- Special processing for Valued_Procedure cases
7581 if Prag_Id = Pragma_Import_Valued_Procedure
7583 Prag_Id = Pragma_Export_Valued_Procedure
7585 Formal := First_Formal (Ent);
7588 Error_Pragma ("at least one parameter required for pragma%");
7590 elsif Ekind (Formal) /= E_Out_Parameter then
7591 Error_Pragma ("first parameter must have mode out for pragma%");
7594 Set_Is_Valued_Procedure (Ent);
7598 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7600 -- Process Result_Mechanism argument if present. We have already
7601 -- checked that this is only allowed for the function case.
7603 if Present (Arg_Result_Mechanism) then
7604 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7607 -- Process Mechanism parameter if present. Note that this parameter
7608 -- is not analyzed, and must not be analyzed since it is semantic
7609 -- nonsense, so we get it in exactly as the parser left it.
7611 if Present (Arg_Mechanism) then
7619 -- A single mechanism association without a formal parameter
7620 -- name is parsed as a parenthesized expression. All other
7621 -- cases are parsed as aggregates, so we rewrite the single
7622 -- parameter case as an aggregate for consistency.
7624 if Nkind (Arg_Mechanism) /= N_Aggregate
7625 and then Paren_Count (Arg_Mechanism) = 1
7627 Rewrite (Arg_Mechanism,
7628 Make_Aggregate (Sloc (Arg_Mechanism),
7629 Expressions => New_List (
7630 Relocate_Node (Arg_Mechanism))));
7633 -- Case of only mechanism name given, applies to all formals
7635 if Nkind (Arg_Mechanism) /= N_Aggregate then
7636 Formal := First_Formal (Ent);
7637 while Present (Formal) loop
7638 Set_Mechanism_Value (Formal, Arg_Mechanism);
7639 Next_Formal (Formal);
7642 -- Case of list of mechanism associations given
7645 if Null_Record_Present (Arg_Mechanism) then
7647 ("inappropriate form for Mechanism parameter",
7651 -- Deal with positional ones first
7653 Formal := First_Formal (Ent);
7655 if Present (Expressions (Arg_Mechanism)) then
7656 Mname := First (Expressions (Arg_Mechanism));
7657 while Present (Mname) loop
7660 ("too many mechanism associations", Mname);
7663 Set_Mechanism_Value (Formal, Mname);
7664 Next_Formal (Formal);
7669 -- Deal with named entries
7671 if Present (Component_Associations (Arg_Mechanism)) then
7672 Massoc := First (Component_Associations (Arg_Mechanism));
7673 while Present (Massoc) loop
7674 Choice := First (Choices (Massoc));
7676 if Nkind (Choice) /= N_Identifier
7677 or else Present (Next (Choice))
7680 ("incorrect form for mechanism association",
7684 Formal := First_Formal (Ent);
7688 ("parameter name & not present", Choice);
7691 if Chars (Choice) = Chars (Formal) then
7693 (Formal, Expression (Massoc));
7695 -- Set entity on identifier (needed by ASIS)
7697 Set_Entity (Choice, Formal);
7702 Next_Formal (Formal);
7711 end Process_Extended_Import_Export_Subprogram_Pragma;
7713 --------------------------
7714 -- Process_Generic_List --
7715 --------------------------
7717 procedure Process_Generic_List is
7722 Check_No_Identifiers;
7723 Check_At_Least_N_Arguments (1);
7725 -- Check all arguments are names of generic units or instances
7728 while Present (Arg) loop
7729 Exp := Get_Pragma_Arg (Arg);
7732 if not Is_Entity_Name (Exp)
7734 (not Is_Generic_Instance (Entity (Exp))
7736 not Is_Generic_Unit (Entity (Exp)))
7739 ("pragma% argument must be name of generic unit/instance",
7745 end Process_Generic_List;
7747 ------------------------------------
7748 -- Process_Import_Predefined_Type --
7749 ------------------------------------
7751 procedure Process_Import_Predefined_Type is
7752 Loc : constant Source_Ptr := Sloc (N);
7754 Ftyp : Node_Id := Empty;
7760 String_To_Name_Buffer (Strval (Expression (Arg3)));
7763 Elmt := First_Elmt (Predefined_Float_Types);
7764 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7768 Ftyp := Node (Elmt);
7770 if Present (Ftyp) then
7772 -- Don't build a derived type declaration, because predefined C
7773 -- types have no declaration anywhere, so cannot really be named.
7774 -- Instead build a full type declaration, starting with an
7775 -- appropriate type definition is built
7777 if Is_Floating_Point_Type (Ftyp) then
7778 Def := Make_Floating_Point_Definition (Loc,
7779 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7780 Make_Real_Range_Specification (Loc,
7781 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7782 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7784 -- Should never have a predefined type we cannot handle
7787 raise Program_Error;
7790 -- Build and insert a Full_Type_Declaration, which will be
7791 -- analyzed as soon as this list entry has been analyzed.
7793 Decl := Make_Full_Type_Declaration (Loc,
7794 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7795 Type_Definition => Def);
7797 Insert_After (N, Decl);
7798 Mark_Rewrite_Insertion (Decl);
7801 Error_Pragma_Arg ("no matching type found for pragma%",
7804 end Process_Import_Predefined_Type;
7806 ---------------------------------
7807 -- Process_Import_Or_Interface --
7808 ---------------------------------
7810 procedure Process_Import_Or_Interface is
7816 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7817 -- pragma Import (Entity, "external name");
7819 if Relaxed_RM_Semantics
7820 and then Arg_Count = 2
7821 and then Prag_Id = Pragma_Import
7822 and then Nkind (Expression (Arg2)) = N_String_Literal
7825 Def_Id := Get_Pragma_Arg (Arg1);
7828 if not Is_Entity_Name (Def_Id) then
7829 Error_Pragma_Arg ("entity name required", Arg1);
7832 Def_Id := Entity (Def_Id);
7833 Kill_Size_Check_Code (Def_Id);
7834 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
7837 Process_Convention (C, Def_Id);
7839 -- A pragma that applies to a Ghost entity becomes Ghost for the
7840 -- purposes of legality checks and removal of ignored Ghost code.
7842 Mark_Pragma_As_Ghost (N, Def_Id);
7843 Kill_Size_Check_Code (Def_Id);
7844 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7847 -- Various error checks
7849 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7851 -- We do not permit Import to apply to a renaming declaration
7853 if Present (Renamed_Object (Def_Id)) then
7855 ("pragma% not allowed for object renaming", Arg2);
7857 -- User initialization is not allowed for imported object, but
7858 -- the object declaration may contain a default initialization,
7859 -- that will be discarded. Note that an explicit initialization
7860 -- only counts if it comes from source, otherwise it is simply
7861 -- the code generator making an implicit initialization explicit.
7863 elsif Present (Expression (Parent (Def_Id)))
7864 and then Comes_From_Source
7865 (Original_Node (Expression (Parent (Def_Id))))
7867 -- Set imported flag to prevent cascaded errors
7869 Set_Is_Imported (Def_Id);
7871 Error_Msg_Sloc := Sloc (Def_Id);
7873 ("no initialization allowed for declaration of& #",
7874 "\imported entities cannot be initialized (RM B.1(24))",
7878 -- If the pragma comes from an aspect specification the
7879 -- Is_Imported flag has already been set.
7881 if not From_Aspect_Specification (N) then
7882 Set_Imported (Def_Id);
7885 Process_Interface_Name (Def_Id, Arg3, Arg4);
7887 -- Note that we do not set Is_Public here. That's because we
7888 -- only want to set it if there is no address clause, and we
7889 -- don't know that yet, so we delay that processing till
7892 -- pragma Import completes deferred constants
7894 if Ekind (Def_Id) = E_Constant then
7895 Set_Has_Completion (Def_Id);
7898 -- It is not possible to import a constant of an unconstrained
7899 -- array type (e.g. string) because there is no simple way to
7900 -- write a meaningful subtype for it.
7902 if Is_Array_Type (Etype (Def_Id))
7903 and then not Is_Constrained (Etype (Def_Id))
7906 ("imported constant& must have a constrained subtype",
7911 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
7913 -- If the name is overloaded, pragma applies to all of the denoted
7914 -- entities in the same declarative part, unless the pragma comes
7915 -- from an aspect specification or was generated by the compiler
7916 -- (such as for pragma Provide_Shift_Operators).
7919 while Present (Hom_Id) loop
7921 Def_Id := Get_Base_Subprogram (Hom_Id);
7923 -- Ignore inherited subprograms because the pragma will apply
7924 -- to the parent operation, which is the one called.
7926 if Is_Overloadable (Def_Id)
7927 and then Present (Alias (Def_Id))
7931 -- If it is not a subprogram, it must be in an outer scope and
7932 -- pragma does not apply.
7934 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
7937 -- The pragma does not apply to primitives of interfaces
7939 elsif Is_Dispatching_Operation (Def_Id)
7940 and then Present (Find_Dispatching_Type (Def_Id))
7941 and then Is_Interface (Find_Dispatching_Type (Def_Id))
7945 -- Verify that the homonym is in the same declarative part (not
7946 -- just the same scope). If the pragma comes from an aspect
7947 -- specification we know that it is part of the declaration.
7949 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
7950 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
7951 and then not From_Aspect_Specification (N)
7956 -- If the pragma comes from an aspect specification the
7957 -- Is_Imported flag has already been set.
7959 if not From_Aspect_Specification (N) then
7960 Set_Imported (Def_Id);
7963 -- Reject an Import applied to an abstract subprogram
7965 if Is_Subprogram (Def_Id)
7966 and then Is_Abstract_Subprogram (Def_Id)
7968 Error_Msg_Sloc := Sloc (Def_Id);
7970 ("cannot import abstract subprogram& declared#",
7974 -- Special processing for Convention_Intrinsic
7976 if C = Convention_Intrinsic then
7978 -- Link_Name argument not allowed for intrinsic
7982 Set_Is_Intrinsic_Subprogram (Def_Id);
7984 -- If no external name is present, then check that this
7985 -- is a valid intrinsic subprogram. If an external name
7986 -- is present, then this is handled by the back end.
7989 Check_Intrinsic_Subprogram
7990 (Def_Id, Get_Pragma_Arg (Arg2));
7994 -- Verify that the subprogram does not have a completion
7995 -- through a renaming declaration. For other completions the
7996 -- pragma appears as a too late representation.
7999 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8003 and then Nkind (Decl) = N_Subprogram_Declaration
8004 and then Present (Corresponding_Body (Decl))
8005 and then Nkind (Unit_Declaration_Node
8006 (Corresponding_Body (Decl))) =
8007 N_Subprogram_Renaming_Declaration
8009 Error_Msg_Sloc := Sloc (Def_Id);
8011 ("cannot import&, renaming already provided for "
8012 & "declaration #", N, Def_Id);
8016 -- If the pragma comes from an aspect specification, there
8017 -- must be an Import aspect specified as well. In the rare
8018 -- case where Import is set to False, the suprogram needs to
8019 -- have a local completion.
8022 Imp_Aspect : constant Node_Id :=
8023 Find_Aspect (Def_Id, Aspect_Import);
8027 if Present (Imp_Aspect)
8028 and then Present (Expression (Imp_Aspect))
8030 Expr := Expression (Imp_Aspect);
8031 Analyze_And_Resolve (Expr, Standard_Boolean);
8033 if Is_Entity_Name (Expr)
8034 and then Entity (Expr) = Standard_True
8036 Set_Has_Completion (Def_Id);
8039 -- If there is no expression, the default is True, as for
8040 -- all boolean aspects. Same for the older pragma.
8043 Set_Has_Completion (Def_Id);
8047 Process_Interface_Name (Def_Id, Arg3, Arg4);
8050 if Is_Compilation_Unit (Hom_Id) then
8052 -- Its possible homonyms are not affected by the pragma.
8053 -- Such homonyms might be present in the context of other
8054 -- units being compiled.
8058 elsif From_Aspect_Specification (N) then
8061 -- If the pragma was created by the compiler, then we don't
8062 -- want it to apply to other homonyms. This kind of case can
8063 -- occur when using pragma Provide_Shift_Operators, which
8064 -- generates implicit shift and rotate operators with Import
8065 -- pragmas that might apply to earlier explicit or implicit
8066 -- declarations marked with Import (for example, coming from
8067 -- an earlier pragma Provide_Shift_Operators for another type),
8068 -- and we don't generally want other homonyms being treated
8069 -- as imported or the pragma flagged as an illegal duplicate.
8071 elsif not Comes_From_Source (N) then
8075 Hom_Id := Homonym (Hom_Id);
8079 -- Import a CPP class
8081 elsif C = Convention_CPP
8082 and then (Is_Record_Type (Def_Id)
8083 or else Ekind (Def_Id) = E_Incomplete_Type)
8085 if Ekind (Def_Id) = E_Incomplete_Type then
8086 if Present (Full_View (Def_Id)) then
8087 Def_Id := Full_View (Def_Id);
8091 ("cannot import 'C'P'P type before full declaration seen",
8092 Get_Pragma_Arg (Arg2));
8094 -- Although we have reported the error we decorate it as
8095 -- CPP_Class to avoid reporting spurious errors
8097 Set_Is_CPP_Class (Def_Id);
8102 -- Types treated as CPP classes must be declared limited (note:
8103 -- this used to be a warning but there is no real benefit to it
8104 -- since we did effectively intend to treat the type as limited
8107 if not Is_Limited_Type (Def_Id) then
8109 ("imported 'C'P'P type must be limited",
8110 Get_Pragma_Arg (Arg2));
8113 if Etype (Def_Id) /= Def_Id
8114 and then not Is_CPP_Class (Root_Type (Def_Id))
8116 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8119 Set_Is_CPP_Class (Def_Id);
8121 -- Imported CPP types must not have discriminants (because C++
8122 -- classes do not have discriminants).
8124 if Has_Discriminants (Def_Id) then
8126 ("imported 'C'P'P type cannot have discriminants",
8127 First (Discriminant_Specifications
8128 (Declaration_Node (Def_Id))));
8131 -- Check that components of imported CPP types do not have default
8132 -- expressions. For private types this check is performed when the
8133 -- full view is analyzed (see Process_Full_View).
8135 if not Is_Private_Type (Def_Id) then
8136 Check_CPP_Type_Has_No_Defaults (Def_Id);
8139 -- Import a CPP exception
8141 elsif C = Convention_CPP
8142 and then Ekind (Def_Id) = E_Exception
8146 ("'External_'Name arguments is required for 'Cpp exception",
8149 -- As only a string is allowed, Check_Arg_Is_External_Name
8152 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8155 if Present (Arg4) then
8157 ("Link_Name argument not allowed for imported Cpp exception",
8161 -- Do not call Set_Interface_Name as the name of the exception
8162 -- shouldn't be modified (and in particular it shouldn't be
8163 -- the External_Name). For exceptions, the External_Name is the
8164 -- name of the RTTI structure.
8166 -- ??? Emit an error if pragma Import/Export_Exception is present
8168 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8170 Check_Arg_Count (3);
8171 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8173 Process_Import_Predefined_Type;
8177 ("second argument of pragma% must be object, subprogram "
8178 & "or incomplete type",
8182 -- If this pragma applies to a compilation unit, then the unit, which
8183 -- is a subprogram, does not require (or allow) a body. We also do
8184 -- not need to elaborate imported procedures.
8186 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8188 Cunit : constant Node_Id := Parent (Parent (N));
8190 Set_Body_Required (Cunit, False);
8193 end Process_Import_Or_Interface;
8195 --------------------
8196 -- Process_Inline --
8197 --------------------
8199 procedure Process_Inline (Status : Inline_Status) is
8206 Ghost_Error_Posted : Boolean := False;
8207 -- Flag set when an error concerning the illegal mix of Ghost and
8208 -- non-Ghost subprograms is emitted.
8210 Ghost_Id : Entity_Id := Empty;
8211 -- The entity of the first Ghost subprogram encountered while
8212 -- processing the arguments of the pragma.
8214 procedure Make_Inline (Subp : Entity_Id);
8215 -- Subp is the defining unit name of the subprogram declaration. Set
8216 -- the flag, as well as the flag in the corresponding body, if there
8219 procedure Set_Inline_Flags (Subp : Entity_Id);
8220 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8221 -- Has_Pragma_Inline_Always for the Inline_Always case.
8223 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8224 -- Returns True if it can be determined at this stage that inlining
8225 -- is not possible, for example if the body is available and contains
8226 -- exception handlers, we prevent inlining, since otherwise we can
8227 -- get undefined symbols at link time. This function also emits a
8228 -- warning if front-end inlining is enabled and the pragma appears
8231 -- ??? is business with link symbols still valid, or does it relate
8232 -- to front end ZCX which is being phased out ???
8234 ---------------------------
8235 -- Inlining_Not_Possible --
8236 ---------------------------
8238 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8239 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8243 if Nkind (Decl) = N_Subprogram_Body then
8244 Stats := Handled_Statement_Sequence (Decl);
8245 return Present (Exception_Handlers (Stats))
8246 or else Present (At_End_Proc (Stats));
8248 elsif Nkind (Decl) = N_Subprogram_Declaration
8249 and then Present (Corresponding_Body (Decl))
8251 if Front_End_Inlining
8252 and then Analyzed (Corresponding_Body (Decl))
8254 Error_Msg_N ("pragma appears too late, ignored??", N);
8257 -- If the subprogram is a renaming as body, the body is just a
8258 -- call to the renamed subprogram, and inlining is trivially
8262 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8263 N_Subprogram_Renaming_Declaration
8269 Handled_Statement_Sequence
8270 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8273 Present (Exception_Handlers (Stats))
8274 or else Present (At_End_Proc (Stats));
8278 -- If body is not available, assume the best, the check is
8279 -- performed again when compiling enclosing package bodies.
8283 end Inlining_Not_Possible;
8289 procedure Make_Inline (Subp : Entity_Id) is
8290 Kind : constant Entity_Kind := Ekind (Subp);
8291 Inner_Subp : Entity_Id := Subp;
8294 -- Ignore if bad type, avoid cascaded error
8296 if Etype (Subp) = Any_Type then
8300 -- If inlining is not possible, for now do not treat as an error
8302 elsif Status /= Suppressed
8303 and then Inlining_Not_Possible (Subp)
8308 -- Here we have a candidate for inlining, but we must exclude
8309 -- derived operations. Otherwise we would end up trying to inline
8310 -- a phantom declaration, and the result would be to drag in a
8311 -- body which has no direct inlining associated with it. That
8312 -- would not only be inefficient but would also result in the
8313 -- backend doing cross-unit inlining in cases where it was
8314 -- definitely inappropriate to do so.
8316 -- However, a simple Comes_From_Source test is insufficient, since
8317 -- we do want to allow inlining of generic instances which also do
8318 -- not come from source. We also need to recognize specs generated
8319 -- by the front-end for bodies that carry the pragma. Finally,
8320 -- predefined operators do not come from source but are not
8321 -- inlineable either.
8323 elsif Is_Generic_Instance (Subp)
8324 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8328 elsif not Comes_From_Source (Subp)
8329 and then Scope (Subp) /= Standard_Standard
8335 -- The referenced entity must either be the enclosing entity, or
8336 -- an entity declared within the current open scope.
8338 if Present (Scope (Subp))
8339 and then Scope (Subp) /= Current_Scope
8340 and then Subp /= Current_Scope
8343 ("argument of% must be entity in current scope", Assoc);
8347 -- Processing for procedure, operator or function. If subprogram
8348 -- is aliased (as for an instance) indicate that the renamed
8349 -- entity (if declared in the same unit) is inlined.
8351 if Is_Subprogram (Subp) then
8352 Inner_Subp := Ultimate_Alias (Inner_Subp);
8354 if In_Same_Source_Unit (Subp, Inner_Subp) then
8355 Set_Inline_Flags (Inner_Subp);
8357 Decl := Parent (Parent (Inner_Subp));
8359 if Nkind (Decl) = N_Subprogram_Declaration
8360 and then Present (Corresponding_Body (Decl))
8362 Set_Inline_Flags (Corresponding_Body (Decl));
8364 elsif Is_Generic_Instance (Subp) then
8366 -- Indicate that the body needs to be created for
8367 -- inlining subsequent calls. The instantiation node
8368 -- follows the declaration of the wrapper package
8371 if Scope (Subp) /= Standard_Standard
8373 Need_Subprogram_Instance_Body
8374 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
8380 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8381 -- appear in a formal part to apply to a formal subprogram.
8382 -- Do not apply check within an instance or a formal package
8383 -- the test will have been applied to the original generic.
8385 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8386 and then List_Containing (Decl) = List_Containing (N)
8387 and then not In_Instance
8390 ("Inline cannot apply to a formal subprogram", N);
8392 -- If Subp is a renaming, it is the renamed entity that
8393 -- will appear in any call, and be inlined. However, for
8394 -- ASIS uses it is convenient to indicate that the renaming
8395 -- itself is an inlined subprogram, so that some gnatcheck
8396 -- rules can be applied in the absence of expansion.
8398 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8399 Set_Inline_Flags (Subp);
8405 -- For a generic subprogram set flag as well, for use at the point
8406 -- of instantiation, to determine whether the body should be
8409 elsif Is_Generic_Subprogram (Subp) then
8410 Set_Inline_Flags (Subp);
8413 -- Literals are by definition inlined
8415 elsif Kind = E_Enumeration_Literal then
8418 -- Anything else is an error
8422 ("expect subprogram name for pragma%", Assoc);
8426 ----------------------
8427 -- Set_Inline_Flags --
8428 ----------------------
8430 procedure Set_Inline_Flags (Subp : Entity_Id) is
8432 -- First set the Has_Pragma_XXX flags and issue the appropriate
8433 -- errors and warnings for suspicious combinations.
8435 if Prag_Id = Pragma_No_Inline then
8436 if Has_Pragma_Inline_Always (Subp) then
8438 ("Inline_Always and No_Inline are mutually exclusive", N);
8439 elsif Has_Pragma_Inline (Subp) then
8441 ("Inline and No_Inline both specified for& ??",
8442 N, Entity (Subp_Id));
8445 Set_Has_Pragma_No_Inline (Subp);
8447 if Prag_Id = Pragma_Inline_Always then
8448 if Has_Pragma_No_Inline (Subp) then
8450 ("Inline_Always and No_Inline are mutually exclusive",
8454 Set_Has_Pragma_Inline_Always (Subp);
8456 if Has_Pragma_No_Inline (Subp) then
8458 ("Inline and No_Inline both specified for& ??",
8459 N, Entity (Subp_Id));
8463 if not Has_Pragma_Inline (Subp) then
8464 Set_Has_Pragma_Inline (Subp);
8468 -- Then adjust the Is_Inlined flag. It can never be set if the
8469 -- subprogram is subject to pragma No_Inline.
8473 Set_Is_Inlined (Subp, False);
8477 if not Has_Pragma_No_Inline (Subp) then
8478 Set_Is_Inlined (Subp, True);
8482 -- A pragma that applies to a Ghost entity becomes Ghost for the
8483 -- purposes of legality checks and removal of ignored Ghost code.
8485 Mark_Pragma_As_Ghost (N, Subp);
8487 -- Capture the entity of the first Ghost subprogram being
8488 -- processed for error detection purposes.
8490 if Is_Ghost_Entity (Subp) then
8491 if No (Ghost_Id) then
8495 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8496 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8498 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
8499 Ghost_Error_Posted := True;
8501 Error_Msg_Name_1 := Pname;
8503 ("pragma % cannot mention ghost and non-ghost subprograms",
8506 Error_Msg_Sloc := Sloc (Ghost_Id);
8507 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
8509 Error_Msg_Sloc := Sloc (Subp);
8510 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
8512 end Set_Inline_Flags;
8514 -- Start of processing for Process_Inline
8517 Check_No_Identifiers;
8518 Check_At_Least_N_Arguments (1);
8520 if Status = Enabled then
8521 Inline_Processing_Required := True;
8525 while Present (Assoc) loop
8526 Subp_Id := Get_Pragma_Arg (Assoc);
8530 if Is_Entity_Name (Subp_Id) then
8531 Subp := Entity (Subp_Id);
8533 if Subp = Any_Id then
8535 -- If previous error, avoid cascaded errors
8537 Check_Error_Detected;
8543 -- For the pragma case, climb homonym chain. This is
8544 -- what implements allowing the pragma in the renaming
8545 -- case, with the result applying to the ancestors, and
8546 -- also allows Inline to apply to all previous homonyms.
8548 if not From_Aspect_Specification (N) then
8549 while Present (Homonym (Subp))
8550 and then Scope (Homonym (Subp)) = Current_Scope
8552 Make_Inline (Homonym (Subp));
8553 Subp := Homonym (Subp);
8560 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
8567 ----------------------------
8568 -- Process_Interface_Name --
8569 ----------------------------
8571 procedure Process_Interface_Name
8572 (Subprogram_Def : Entity_Id;
8578 String_Val : String_Id;
8580 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
8581 -- SN is a string literal node for an interface name. This routine
8582 -- performs some minimal checks that the name is reasonable. In
8583 -- particular that no spaces or other obviously incorrect characters
8584 -- appear. This is only a warning, since any characters are allowed.
8586 ----------------------------------
8587 -- Check_Form_Of_Interface_Name --
8588 ----------------------------------
8590 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
8591 S : constant String_Id := Strval (Expr_Value_S (SN));
8592 SL : constant Nat := String_Length (S);
8597 Error_Msg_N ("interface name cannot be null string", SN);
8600 for J in 1 .. SL loop
8601 C := Get_String_Char (S, J);
8603 -- Look for dubious character and issue unconditional warning.
8604 -- Definitely dubious if not in character range.
8606 if not In_Character_Range (C)
8608 -- Commas, spaces and (back)slashes are dubious
8610 or else Get_Character (C) = ','
8611 or else Get_Character (C) = '\'
8612 or else Get_Character (C) = ' '
8613 or else Get_Character (C) = '/'
8616 ("??interface name contains illegal character",
8617 Sloc (SN) + Source_Ptr (J));
8620 end Check_Form_Of_Interface_Name;
8622 -- Start of processing for Process_Interface_Name
8625 if No (Link_Arg) then
8626 if No (Ext_Arg) then
8629 elsif Chars (Ext_Arg) = Name_Link_Name then
8631 Link_Nam := Expression (Ext_Arg);
8634 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8635 Ext_Nam := Expression (Ext_Arg);
8640 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8641 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8642 Ext_Nam := Expression (Ext_Arg);
8643 Link_Nam := Expression (Link_Arg);
8646 -- Check expressions for external name and link name are static
8648 if Present (Ext_Nam) then
8649 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8650 Check_Form_Of_Interface_Name (Ext_Nam);
8652 -- Verify that external name is not the name of a local entity,
8653 -- which would hide the imported one and could lead to run-time
8654 -- surprises. The problem can only arise for entities declared in
8655 -- a package body (otherwise the external name is fully qualified
8656 -- and will not conflict).
8664 if Prag_Id = Pragma_Import then
8665 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8667 E := Entity_Id (Get_Name_Table_Int (Nam));
8669 if Nam /= Chars (Subprogram_Def)
8670 and then Present (E)
8671 and then not Is_Overloadable (E)
8672 and then Is_Immediately_Visible (E)
8673 and then not Is_Imported (E)
8674 and then Ekind (Scope (E)) = E_Package
8677 while Present (Par) loop
8678 if Nkind (Par) = N_Package_Body then
8679 Error_Msg_Sloc := Sloc (E);
8681 ("imported entity is hidden by & declared#",
8686 Par := Parent (Par);
8693 if Present (Link_Nam) then
8694 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8695 Check_Form_Of_Interface_Name (Link_Nam);
8698 -- If there is no link name, just set the external name
8700 if No (Link_Nam) then
8701 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8703 -- For the Link_Name case, the given literal is preceded by an
8704 -- asterisk, which indicates to GCC that the given name should be
8705 -- taken literally, and in particular that no prepending of
8706 -- underlines should occur, even in systems where this is the
8711 Store_String_Char (Get_Char_Code ('*'));
8712 String_Val := Strval (Expr_Value_S (Link_Nam));
8713 Store_String_Chars (String_Val);
8715 Make_String_Literal (Sloc (Link_Nam),
8716 Strval => End_String);
8719 -- Set the interface name. If the entity is a generic instance, use
8720 -- its alias, which is the callable entity.
8722 if Is_Generic_Instance (Subprogram_Def) then
8723 Set_Encoded_Interface_Name
8724 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8726 Set_Encoded_Interface_Name
8727 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
8730 Check_Duplicated_Export_Name (Link_Nam);
8731 end Process_Interface_Name;
8733 -----------------------------------------
8734 -- Process_Interrupt_Or_Attach_Handler --
8735 -----------------------------------------
8737 procedure Process_Interrupt_Or_Attach_Handler is
8738 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
8739 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
8740 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
8743 -- A pragma that applies to a Ghost entity becomes Ghost for the
8744 -- purposes of legality checks and removal of ignored Ghost code.
8746 Mark_Pragma_As_Ghost (N, Handler_Proc);
8747 Set_Is_Interrupt_Handler (Handler_Proc);
8749 -- If the pragma is not associated with a handler procedure within a
8750 -- protected type, then it must be for a nonprotected procedure for
8751 -- the AAMP target, in which case we don't associate a representation
8752 -- item with the procedure's scope.
8754 if Ekind (Proc_Scope) = E_Protected_Type then
8755 if Prag_Id = Pragma_Interrupt_Handler
8757 Prag_Id = Pragma_Attach_Handler
8759 Record_Rep_Item (Proc_Scope, N);
8762 end Process_Interrupt_Or_Attach_Handler;
8764 --------------------------------------------------
8765 -- Process_Restrictions_Or_Restriction_Warnings --
8766 --------------------------------------------------
8768 -- Note: some of the simple identifier cases were handled in par-prag,
8769 -- but it is harmless (and more straightforward) to simply handle all
8770 -- cases here, even if it means we repeat a bit of work in some cases.
8772 procedure Process_Restrictions_Or_Restriction_Warnings
8776 R_Id : Restriction_Id;
8782 -- Ignore all Restrictions pragmas in CodePeer mode
8784 if CodePeer_Mode then
8788 Check_Ada_83_Warning;
8789 Check_At_Least_N_Arguments (1);
8790 Check_Valid_Configuration_Pragma;
8793 while Present (Arg) loop
8795 Expr := Get_Pragma_Arg (Arg);
8797 -- Case of no restriction identifier present
8799 if Id = No_Name then
8800 if Nkind (Expr) /= N_Identifier then
8802 ("invalid form for restriction", Arg);
8807 (Process_Restriction_Synonyms (Expr));
8809 if R_Id not in All_Boolean_Restrictions then
8810 Error_Msg_Name_1 := Pname;
8812 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8814 -- Check for possible misspelling
8816 for J in Restriction_Id loop
8818 Rnm : constant String := Restriction_Id'Image (J);
8821 Name_Buffer (1 .. Rnm'Length) := Rnm;
8822 Name_Len := Rnm'Length;
8823 Set_Casing (All_Lower_Case);
8825 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8827 (Identifier_Casing (Current_Source_File));
8828 Error_Msg_String (1 .. Rnm'Length) :=
8829 Name_Buffer (1 .. Name_Len);
8830 Error_Msg_Strlen := Rnm'Length;
8831 Error_Msg_N -- CODEFIX
8832 ("\possible misspelling of ""~""",
8833 Get_Pragma_Arg (Arg));
8842 if Implementation_Restriction (R_Id) then
8843 Check_Restriction (No_Implementation_Restrictions, Arg);
8846 -- Special processing for No_Elaboration_Code restriction
8848 if R_Id = No_Elaboration_Code then
8850 -- Restriction is only recognized within a configuration
8851 -- pragma file, or within a unit of the main extended
8852 -- program. Note: the test for Main_Unit is needed to
8853 -- properly include the case of configuration pragma files.
8855 if not (Current_Sem_Unit = Main_Unit
8856 or else In_Extended_Main_Source_Unit (N))
8860 -- Don't allow in a subunit unless already specified in
8863 elsif Nkind (Parent (N)) = N_Compilation_Unit
8864 and then Nkind (Unit (Parent (N))) = N_Subunit
8865 and then not Restriction_Active (No_Elaboration_Code)
8868 ("invalid specification of ""No_Elaboration_Code""",
8871 ("\restriction cannot be specified in a subunit", N);
8873 ("\unless also specified in body or spec", N);
8876 -- If we accept a No_Elaboration_Code restriction, then it
8877 -- needs to be added to the configuration restriction set so
8878 -- that we get proper application to other units in the main
8879 -- extended source as required.
8882 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
8886 -- If this is a warning, then set the warning unless we already
8887 -- have a real restriction active (we never want a warning to
8888 -- override a real restriction).
8891 if not Restriction_Active (R_Id) then
8892 Set_Restriction (R_Id, N);
8893 Restriction_Warnings (R_Id) := True;
8896 -- If real restriction case, then set it and make sure that the
8897 -- restriction warning flag is off, since a real restriction
8898 -- always overrides a warning.
8901 Set_Restriction (R_Id, N);
8902 Restriction_Warnings (R_Id) := False;
8905 -- Check for obsolescent restrictions in Ada 2005 mode
8908 and then Ada_Version >= Ada_2005
8909 and then (R_Id = No_Asynchronous_Control
8911 R_Id = No_Unchecked_Deallocation
8913 R_Id = No_Unchecked_Conversion)
8915 Check_Restriction (No_Obsolescent_Features, N);
8918 -- A very special case that must be processed here: pragma
8919 -- Restrictions (No_Exceptions) turns off all run-time
8920 -- checking. This is a bit dubious in terms of the formal
8921 -- language definition, but it is what is intended by RM
8922 -- H.4(12). Restriction_Warnings never affects generated code
8923 -- so this is done only in the real restriction case.
8925 -- Atomic_Synchronization is not a real check, so it is not
8926 -- affected by this processing).
8928 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8929 -- run-time checks in CodePeer and GNATprove modes: we want to
8930 -- generate checks for analysis purposes, as set respectively
8931 -- by -gnatC and -gnatd.F
8934 and then not (CodePeer_Mode or GNATprove_Mode)
8935 and then R_Id = No_Exceptions
8937 for J in Scope_Suppress.Suppress'Range loop
8938 if J /= Atomic_Synchronization then
8939 Scope_Suppress.Suppress (J) := True;
8944 -- Case of No_Dependence => unit-name. Note that the parser
8945 -- already made the necessary entry in the No_Dependence table.
8947 elsif Id = Name_No_Dependence then
8948 if not OK_No_Dependence_Unit_Name (Expr) then
8952 -- Case of No_Specification_Of_Aspect => aspect-identifier
8954 elsif Id = Name_No_Specification_Of_Aspect then
8959 if Nkind (Expr) /= N_Identifier then
8962 A_Id := Get_Aspect_Id (Chars (Expr));
8965 if A_Id = No_Aspect then
8966 Error_Pragma_Arg ("invalid restriction name", Arg);
8968 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
8972 -- Case of No_Use_Of_Attribute => attribute-identifier
8974 elsif Id = Name_No_Use_Of_Attribute then
8975 if Nkind (Expr) /= N_Identifier
8976 or else not Is_Attribute_Name (Chars (Expr))
8978 Error_Msg_N ("unknown attribute name??", Expr);
8981 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
8984 -- Case of No_Use_Of_Entity => fully-qualified-name
8986 elsif Id = Name_No_Use_Of_Entity then
8988 -- Restriction is only recognized within a configuration
8989 -- pragma file, or within a unit of the main extended
8990 -- program. Note: the test for Main_Unit is needed to
8991 -- properly include the case of configuration pragma files.
8993 if Current_Sem_Unit = Main_Unit
8994 or else In_Extended_Main_Source_Unit (N)
8996 if not OK_No_Dependence_Unit_Name (Expr) then
8997 Error_Msg_N ("wrong form for entity name", Expr);
8999 Set_Restriction_No_Use_Of_Entity
9000 (Expr, Warn, No_Profile);
9004 -- Case of No_Use_Of_Pragma => pragma-identifier
9006 elsif Id = Name_No_Use_Of_Pragma then
9007 if Nkind (Expr) /= N_Identifier
9008 or else not Is_Pragma_Name (Chars (Expr))
9010 Error_Msg_N ("unknown pragma name??", Expr);
9012 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9015 -- All other cases of restriction identifier present
9018 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9019 Analyze_And_Resolve (Expr, Any_Integer);
9021 if R_Id not in All_Parameter_Restrictions then
9023 ("invalid restriction parameter identifier", Arg);
9025 elsif not Is_OK_Static_Expression (Expr) then
9026 Flag_Non_Static_Expr
9027 ("value must be static expression!", Expr);
9030 elsif not Is_Integer_Type (Etype (Expr))
9031 or else Expr_Value (Expr) < 0
9034 ("value must be non-negative integer", Arg);
9037 -- Restriction pragma is active
9039 Val := Expr_Value (Expr);
9041 if not UI_Is_In_Int_Range (Val) then
9043 ("pragma ignored, value too large??", Arg);
9046 -- Warning case. If the real restriction is active, then we
9047 -- ignore the request, since warning never overrides a real
9048 -- restriction. Otherwise we set the proper warning. Note that
9049 -- this circuit sets the warning again if it is already set,
9050 -- which is what we want, since the constant may have changed.
9053 if not Restriction_Active (R_Id) then
9055 (R_Id, N, Integer (UI_To_Int (Val)));
9056 Restriction_Warnings (R_Id) := True;
9059 -- Real restriction case, set restriction and make sure warning
9060 -- flag is off since real restriction always overrides warning.
9063 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9064 Restriction_Warnings (R_Id) := False;
9070 end Process_Restrictions_Or_Restriction_Warnings;
9072 ---------------------------------
9073 -- Process_Suppress_Unsuppress --
9074 ---------------------------------
9076 -- Note: this procedure makes entries in the check suppress data
9077 -- structures managed by Sem. See spec of package Sem for full
9078 -- details on how we handle recording of check suppression.
9080 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9085 In_Package_Spec : constant Boolean :=
9086 Is_Package_Or_Generic_Package (Current_Scope)
9087 and then not In_Package_Body (Current_Scope);
9089 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9090 -- Used to suppress a single check on the given entity
9092 --------------------------------
9093 -- Suppress_Unsuppress_Echeck --
9094 --------------------------------
9096 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9098 -- Check for error of trying to set atomic synchronization for
9099 -- a non-atomic variable.
9101 if C = Atomic_Synchronization
9102 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9105 ("pragma & requires atomic type or variable",
9106 Pragma_Identifier (Original_Node (N)));
9109 Set_Checks_May_Be_Suppressed (E);
9111 if In_Package_Spec then
9112 Push_Global_Suppress_Stack_Entry
9115 Suppress => Suppress_Case);
9117 Push_Local_Suppress_Stack_Entry
9120 Suppress => Suppress_Case);
9123 -- If this is a first subtype, and the base type is distinct,
9124 -- then also set the suppress flags on the base type.
9126 if Is_First_Subtype (E) and then Etype (E) /= E then
9127 Suppress_Unsuppress_Echeck (Etype (E), C);
9129 end Suppress_Unsuppress_Echeck;
9131 -- Start of processing for Process_Suppress_Unsuppress
9134 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9135 -- on user code: we want to generate checks for analysis purposes, as
9136 -- set respectively by -gnatC and -gnatd.F
9138 if Comes_From_Source (N)
9139 and then (CodePeer_Mode or GNATprove_Mode)
9144 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9145 -- declarative part or a package spec (RM 11.5(5)).
9147 if not Is_Configuration_Pragma then
9148 Check_Is_In_Decl_Part_Or_Package_Spec;
9151 Check_At_Least_N_Arguments (1);
9152 Check_At_Most_N_Arguments (2);
9153 Check_No_Identifier (Arg1);
9154 Check_Arg_Is_Identifier (Arg1);
9156 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9158 if C = No_Check_Id then
9160 ("argument of pragma% is not valid check name", Arg1);
9163 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9165 if C = Elaboration_Check and then SPARK_Mode = On then
9167 ("Suppress of Elaboration_Check ignored in SPARK??",
9168 "\elaboration checking rules are statically enforced "
9169 & "(SPARK RM 7.7)", Arg1);
9172 -- One-argument case
9174 if Arg_Count = 1 then
9176 -- Make an entry in the local scope suppress table. This is the
9177 -- table that directly shows the current value of the scope
9178 -- suppress check for any check id value.
9180 if C = All_Checks then
9182 -- For All_Checks, we set all specific predefined checks with
9183 -- the exception of Elaboration_Check, which is handled
9184 -- specially because of not wanting All_Checks to have the
9185 -- effect of deactivating static elaboration order processing.
9186 -- Atomic_Synchronization is also not affected, since this is
9187 -- not a real check.
9189 for J in Scope_Suppress.Suppress'Range loop
9190 if J /= Elaboration_Check
9192 J /= Atomic_Synchronization
9194 Scope_Suppress.Suppress (J) := Suppress_Case;
9198 -- If not All_Checks, and predefined check, then set appropriate
9199 -- scope entry. Note that we will set Elaboration_Check if this
9200 -- is explicitly specified. Atomic_Synchronization is allowed
9201 -- only if internally generated and entity is atomic.
9203 elsif C in Predefined_Check_Id
9204 and then (not Comes_From_Source (N)
9205 or else C /= Atomic_Synchronization)
9207 Scope_Suppress.Suppress (C) := Suppress_Case;
9210 -- Also make an entry in the Local_Entity_Suppress table
9212 Push_Local_Suppress_Stack_Entry
9215 Suppress => Suppress_Case);
9217 -- Case of two arguments present, where the check is suppressed for
9218 -- a specified entity (given as the second argument of the pragma)
9221 -- This is obsolescent in Ada 2005 mode
9223 if Ada_Version >= Ada_2005 then
9224 Check_Restriction (No_Obsolescent_Features, Arg2);
9227 Check_Optional_Identifier (Arg2, Name_On);
9228 E_Id := Get_Pragma_Arg (Arg2);
9231 if not Is_Entity_Name (E_Id) then
9233 ("second argument of pragma% must be entity name", Arg2);
9242 -- A pragma that applies to a Ghost entity becomes Ghost for the
9243 -- purposes of legality checks and removal of ignored Ghost code.
9245 Mark_Pragma_As_Ghost (N, E);
9247 -- Enforce RM 11.5(7) which requires that for a pragma that
9248 -- appears within a package spec, the named entity must be
9249 -- within the package spec. We allow the package name itself
9250 -- to be mentioned since that makes sense, although it is not
9251 -- strictly allowed by 11.5(7).
9254 and then E /= Current_Scope
9255 and then Scope (E) /= Current_Scope
9258 ("entity in pragma% is not in package spec (RM 11.5(7))",
9262 -- Loop through homonyms. As noted below, in the case of a package
9263 -- spec, only homonyms within the package spec are considered.
9266 Suppress_Unsuppress_Echeck (E, C);
9268 if Is_Generic_Instance (E)
9269 and then Is_Subprogram (E)
9270 and then Present (Alias (E))
9272 Suppress_Unsuppress_Echeck (Alias (E), C);
9275 -- Move to next homonym if not aspect spec case
9277 exit when From_Aspect_Specification (N);
9281 -- If we are within a package specification, the pragma only
9282 -- applies to homonyms in the same scope.
9284 exit when In_Package_Spec
9285 and then Scope (E) /= Current_Scope;
9288 end Process_Suppress_Unsuppress;
9290 -------------------------------
9291 -- Record_Independence_Check --
9292 -------------------------------
9294 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9296 -- For GCC back ends the validation is done a priori
9298 if not AAMP_On_Target then
9302 Independence_Checks.Append ((N, E));
9303 end Record_Independence_Check;
9309 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9311 if Is_Imported (E) then
9313 ("cannot export entity& that was previously imported", Arg);
9315 elsif Present (Address_Clause (E))
9316 and then not Relaxed_RM_Semantics
9319 ("cannot export entity& that has an address clause", Arg);
9322 Set_Is_Exported (E);
9324 -- Generate a reference for entity explicitly, because the
9325 -- identifier may be overloaded and name resolution will not
9328 Generate_Reference (E, Arg);
9330 -- Deal with exporting non-library level entity
9332 if not Is_Library_Level_Entity (E) then
9334 -- Not allowed at all for subprograms
9336 if Is_Subprogram (E) then
9337 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9339 -- Otherwise set public and statically allocated
9343 Set_Is_Statically_Allocated (E);
9345 -- Warn if the corresponding W flag is set
9347 if Warn_On_Export_Import
9349 -- Only do this for something that was in the source. Not
9350 -- clear if this can be False now (there used for sure to be
9351 -- cases on some systems where it was False), but anyway the
9352 -- test is harmless if not needed, so it is retained.
9354 and then Comes_From_Source (Arg)
9357 ("?x?& has been made static as a result of Export",
9360 ("\?x?this usage is non-standard and non-portable",
9366 if Warn_On_Export_Import and then Is_Type (E) then
9367 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9370 if Warn_On_Export_Import and Inside_A_Generic then
9372 ("all instances of& will have the same external name?x?",
9377 ----------------------------------------------
9378 -- Set_Extended_Import_Export_External_Name --
9379 ----------------------------------------------
9381 procedure Set_Extended_Import_Export_External_Name
9382 (Internal_Ent : Entity_Id;
9383 Arg_External : Node_Id)
9385 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9389 if No (Arg_External) then
9393 Check_Arg_Is_External_Name (Arg_External);
9395 if Nkind (Arg_External) = N_String_Literal then
9396 if String_Length (Strval (Arg_External)) = 0 then
9399 New_Name := Adjust_External_Name_Case (Arg_External);
9402 elsif Nkind (Arg_External) = N_Identifier then
9403 New_Name := Get_Default_External_Name (Arg_External);
9405 -- Check_Arg_Is_External_Name should let through only identifiers and
9406 -- string literals or static string expressions (which are folded to
9407 -- string literals).
9410 raise Program_Error;
9413 -- If we already have an external name set (by a prior normal Import
9414 -- or Export pragma), then the external names must match
9416 if Present (Interface_Name (Internal_Ent)) then
9418 -- Ignore mismatching names in CodePeer mode, to support some
9419 -- old compilers which would export the same procedure under
9420 -- different names, e.g:
9422 -- pragma Export_Procedure (P, "a");
9423 -- pragma Export_Procedure (P, "b");
9425 if CodePeer_Mode then
9429 Check_Matching_Internal_Names : declare
9430 S1 : constant String_Id := Strval (Old_Name);
9431 S2 : constant String_Id := Strval (New_Name);
9434 pragma No_Return (Mismatch);
9435 -- Called if names do not match
9441 procedure Mismatch is
9443 Error_Msg_Sloc := Sloc (Old_Name);
9445 ("external name does not match that given #",
9449 -- Start of processing for Check_Matching_Internal_Names
9452 if String_Length (S1) /= String_Length (S2) then
9456 for J in 1 .. String_Length (S1) loop
9457 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9462 end Check_Matching_Internal_Names;
9464 -- Otherwise set the given name
9467 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9468 Check_Duplicated_Export_Name (New_Name);
9470 end Set_Extended_Import_Export_External_Name;
9476 procedure Set_Imported (E : Entity_Id) is
9478 -- Error message if already imported or exported
9480 if Is_Exported (E) or else Is_Imported (E) then
9482 -- Error if being set Exported twice
9484 if Is_Exported (E) then
9485 Error_Msg_NE ("entity& was previously exported", N, E);
9487 -- Ignore error in CodePeer mode where we treat all imported
9488 -- subprograms as unknown.
9490 elsif CodePeer_Mode then
9493 -- OK if Import/Interface case
9495 elsif Import_Interface_Present (N) then
9498 -- Error if being set Imported twice
9501 Error_Msg_NE ("entity& was previously imported", N, E);
9504 Error_Msg_Name_1 := Pname;
9506 ("\(pragma% applies to all previous entities)", N);
9508 Error_Msg_Sloc := Sloc (E);
9509 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9511 -- Here if not previously imported or exported, OK to import
9514 Set_Is_Imported (E);
9516 -- For subprogram, set Import_Pragma field
9518 if Is_Subprogram (E) then
9519 Set_Import_Pragma (E, N);
9522 -- If the entity is an object that is not at the library level,
9523 -- then it is statically allocated. We do not worry about objects
9524 -- with address clauses in this context since they are not really
9525 -- imported in the linker sense.
9528 and then not Is_Library_Level_Entity (E)
9529 and then No (Address_Clause (E))
9531 Set_Is_Statically_Allocated (E);
9538 -------------------------
9539 -- Set_Mechanism_Value --
9540 -------------------------
9542 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9543 -- analyzed, since it is semantic nonsense), so we get it in the exact
9544 -- form created by the parser.
9546 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9547 procedure Bad_Mechanism;
9548 pragma No_Return (Bad_Mechanism);
9549 -- Signal bad mechanism name
9551 -------------------------
9552 -- Bad_Mechanism_Value --
9553 -------------------------
9555 procedure Bad_Mechanism is
9557 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9560 -- Start of processing for Set_Mechanism_Value
9563 if Mechanism (Ent) /= Default_Mechanism then
9565 ("mechanism for & has already been set", Mech_Name, Ent);
9568 -- MECHANISM_NAME ::= value | reference
9570 if Nkind (Mech_Name) = N_Identifier then
9571 if Chars (Mech_Name) = Name_Value then
9572 Set_Mechanism (Ent, By_Copy);
9575 elsif Chars (Mech_Name) = Name_Reference then
9576 Set_Mechanism (Ent, By_Reference);
9579 elsif Chars (Mech_Name) = Name_Copy then
9581 ("bad mechanism name, Value assumed", Mech_Name);
9590 end Set_Mechanism_Value;
9592 --------------------------
9593 -- Set_Rational_Profile --
9594 --------------------------
9596 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9597 -- extension to the semantics of renaming declarations.
9599 procedure Set_Rational_Profile is
9601 Implicit_Packing := True;
9602 Overriding_Renamings := True;
9603 Use_VADS_Size := True;
9604 end Set_Rational_Profile;
9606 ---------------------------
9607 -- Set_Ravenscar_Profile --
9608 ---------------------------
9610 -- The tasks to be done here are
9612 -- Set required policies
9614 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9615 -- pragma Locking_Policy (Ceiling_Locking)
9617 -- Set Detect_Blocking mode
9619 -- Set required restrictions (see System.Rident for detailed list)
9621 -- Set the No_Dependence rules
9622 -- No_Dependence => Ada.Asynchronous_Task_Control
9623 -- No_Dependence => Ada.Calendar
9624 -- No_Dependence => Ada.Execution_Time.Group_Budget
9625 -- No_Dependence => Ada.Execution_Time.Timers
9626 -- No_Dependence => Ada.Task_Attributes
9627 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9629 procedure Set_Ravenscar_Profile (N : Node_Id) is
9630 Prefix_Entity : Entity_Id;
9631 Selector_Entity : Entity_Id;
9632 Prefix_Node : Node_Id;
9636 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9638 if Task_Dispatching_Policy /= ' '
9639 and then Task_Dispatching_Policy /= 'F'
9641 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9642 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9644 -- Set the FIFO_Within_Priorities policy, but always preserve
9645 -- System_Location since we like the error message with the run time
9649 Task_Dispatching_Policy := 'F';
9651 if Task_Dispatching_Policy_Sloc /= System_Location then
9652 Task_Dispatching_Policy_Sloc := Loc;
9656 -- pragma Locking_Policy (Ceiling_Locking)
9658 if Locking_Policy /= ' '
9659 and then Locking_Policy /= 'C'
9661 Error_Msg_Sloc := Locking_Policy_Sloc;
9662 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9664 -- Set the Ceiling_Locking policy, but preserve System_Location since
9665 -- we like the error message with the run time name.
9668 Locking_Policy := 'C';
9670 if Locking_Policy_Sloc /= System_Location then
9671 Locking_Policy_Sloc := Loc;
9675 -- pragma Detect_Blocking
9677 Detect_Blocking := True;
9679 -- Set the corresponding restrictions
9681 Set_Profile_Restrictions
9682 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9684 -- Set the No_Dependence restrictions
9686 -- The following No_Dependence restrictions:
9687 -- No_Dependence => Ada.Asynchronous_Task_Control
9688 -- No_Dependence => Ada.Calendar
9689 -- No_Dependence => Ada.Task_Attributes
9690 -- are already set by previous call to Set_Profile_Restrictions.
9692 -- Set the following restrictions which were added to Ada 2005:
9693 -- No_Dependence => Ada.Execution_Time.Group_Budget
9694 -- No_Dependence => Ada.Execution_Time.Timers
9696 if Ada_Version >= Ada_2005 then
9697 Name_Buffer (1 .. 3) := "ada";
9700 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9702 Name_Buffer (1 .. 14) := "execution_time";
9705 Selector_Entity := Make_Identifier (Loc, Name_Find);
9708 Make_Selected_Component
9710 Prefix => Prefix_Entity,
9711 Selector_Name => Selector_Entity);
9713 Name_Buffer (1 .. 13) := "group_budgets";
9716 Selector_Entity := Make_Identifier (Loc, Name_Find);
9719 Make_Selected_Component
9721 Prefix => Prefix_Node,
9722 Selector_Name => Selector_Entity);
9724 Set_Restriction_No_Dependence
9726 Warn => Treat_Restrictions_As_Warnings,
9727 Profile => Ravenscar);
9729 Name_Buffer (1 .. 6) := "timers";
9732 Selector_Entity := Make_Identifier (Loc, Name_Find);
9735 Make_Selected_Component
9737 Prefix => Prefix_Node,
9738 Selector_Name => Selector_Entity);
9740 Set_Restriction_No_Dependence
9742 Warn => Treat_Restrictions_As_Warnings,
9743 Profile => Ravenscar);
9746 -- Set the following restriction which was added to Ada 2012 (see
9748 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9750 if Ada_Version >= Ada_2012 then
9751 Name_Buffer (1 .. 6) := "system";
9754 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9756 Name_Buffer (1 .. 15) := "multiprocessors";
9759 Selector_Entity := Make_Identifier (Loc, Name_Find);
9762 Make_Selected_Component
9764 Prefix => Prefix_Entity,
9765 Selector_Name => Selector_Entity);
9767 Name_Buffer (1 .. 19) := "dispatching_domains";
9770 Selector_Entity := Make_Identifier (Loc, Name_Find);
9773 Make_Selected_Component
9775 Prefix => Prefix_Node,
9776 Selector_Name => Selector_Entity);
9778 Set_Restriction_No_Dependence
9780 Warn => Treat_Restrictions_As_Warnings,
9781 Profile => Ravenscar);
9783 end Set_Ravenscar_Profile;
9785 -- Start of processing for Analyze_Pragma
9788 -- The following code is a defense against recursion. Not clear that
9789 -- this can happen legitimately, but perhaps some error situations can
9790 -- cause it, and we did see this recursion during testing.
9792 if Analyzed (N) then
9798 -- Deal with unrecognized pragma
9800 Pname := Pragma_Name (N);
9802 if not Is_Pragma_Name (Pname) then
9803 if Warn_On_Unrecognized_Pragma then
9804 Error_Msg_Name_1 := Pname;
9805 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
9807 for PN in First_Pragma_Name .. Last_Pragma_Name loop
9808 if Is_Bad_Spelling_Of (Pname, PN) then
9809 Error_Msg_Name_1 := PN;
9810 Error_Msg_N -- CODEFIX
9811 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
9820 -- Ignore pragma if Ignore_Pragma applies
9822 if Get_Name_Table_Boolean3 (Pname) then
9826 -- Here to start processing for recognized pragma
9828 Prag_Id := Get_Pragma_Id (Pname);
9829 Pname := Original_Aspect_Pragma_Name (N);
9831 -- Capture setting of Opt.Uneval_Old
9833 case Opt.Uneval_Old is
9835 Set_Uneval_Old_Accept (N);
9839 Set_Uneval_Old_Warn (N);
9841 raise Program_Error;
9844 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9845 -- is already set, indicating that we have already checked the policy
9846 -- at the right point. This happens for example in the case of a pragma
9847 -- that is derived from an Aspect.
9849 if Is_Ignored (N) or else Is_Checked (N) then
9852 -- For a pragma that is a rewriting of another pragma, copy the
9853 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9855 elsif Is_Rewrite_Substitution (N)
9856 and then Nkind (Original_Node (N)) = N_Pragma
9857 and then Original_Node (N) /= N
9859 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
9860 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
9862 -- Otherwise query the applicable policy at this point
9865 Check_Applicable_Policy (N);
9867 -- If pragma is disabled, rewrite as NULL and skip analysis
9869 if Is_Disabled (N) then
9870 Rewrite (N, Make_Null_Statement (Loc));
9884 if Present (Pragma_Argument_Associations (N)) then
9885 Arg_Count := List_Length (Pragma_Argument_Associations (N));
9886 Arg1 := First (Pragma_Argument_Associations (N));
9888 if Present (Arg1) then
9889 Arg2 := Next (Arg1);
9891 if Present (Arg2) then
9892 Arg3 := Next (Arg2);
9894 if Present (Arg3) then
9895 Arg4 := Next (Arg3);
9901 Check_Restriction_No_Use_Of_Pragma (N);
9903 -- An enumeration type defines the pragmas that are supported by the
9904 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9905 -- into the corresponding enumeration value for the following case.
9913 -- pragma Abort_Defer;
9915 when Pragma_Abort_Defer =>
9917 Check_Arg_Count (0);
9919 -- The only required semantic processing is to check the
9920 -- placement. This pragma must appear at the start of the
9921 -- statement sequence of a handled sequence of statements.
9923 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
9924 or else N /= First (Statements (Parent (N)))
9929 --------------------
9930 -- Abstract_State --
9931 --------------------
9933 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9935 -- ABSTRACT_STATE_LIST ::=
9937 -- | STATE_NAME_WITH_OPTIONS
9938 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9940 -- STATE_NAME_WITH_OPTIONS ::=
9942 -- | (STATE_NAME with OPTION_LIST)
9944 -- OPTION_LIST ::= OPTION {, OPTION}
9948 -- | NAME_VALUE_OPTION
9950 -- SIMPLE_OPTION ::= Ghost | Synchronous
9952 -- NAME_VALUE_OPTION ::=
9953 -- Part_Of => ABSTRACT_STATE
9954 -- | External [=> EXTERNAL_PROPERTY_LIST]
9956 -- EXTERNAL_PROPERTY_LIST ::=
9957 -- EXTERNAL_PROPERTY
9958 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9960 -- EXTERNAL_PROPERTY ::=
9961 -- Async_Readers [=> boolean_EXPRESSION]
9962 -- | Async_Writers [=> boolean_EXPRESSION]
9963 -- | Effective_Reads [=> boolean_EXPRESSION]
9964 -- | Effective_Writes [=> boolean_EXPRESSION]
9965 -- others => boolean_EXPRESSION
9967 -- STATE_NAME ::= defining_identifier
9969 -- ABSTRACT_STATE ::= name
9973 -- * Analysis - The annotation is fully analyzed immediately upon
9974 -- elaboration as it cannot forward reference entities.
9976 -- * Expansion - None.
9978 -- * Template - The annotation utilizes the generic template of the
9979 -- related package declaration.
9981 -- * Globals - The annotation cannot reference global entities.
9983 -- * Instance - The annotation is instantiated automatically when
9984 -- the related generic package is instantiated.
9986 when Pragma_Abstract_State => Abstract_State : declare
9987 Missing_Parentheses : Boolean := False;
9988 -- Flag set when a state declaration with options is not properly
9991 -- Flags used to verify the consistency of states
9993 Non_Null_Seen : Boolean := False;
9994 Null_Seen : Boolean := False;
9996 procedure Analyze_Abstract_State
9998 Pack_Id : Entity_Id);
9999 -- Verify the legality of a single state declaration. Create and
10000 -- decorate a state abstraction entity and introduce it into the
10001 -- visibility chain. Pack_Id denotes the entity or the related
10002 -- package where pragma Abstract_State appears.
10004 procedure Malformed_State_Error (State : Node_Id);
10005 -- Emit an error concerning the illegal declaration of abstract
10006 -- state State. This routine diagnoses syntax errors that lead to
10007 -- a different parse tree. The error is issued regardless of the
10008 -- SPARK mode in effect.
10010 ----------------------------
10011 -- Analyze_Abstract_State --
10012 ----------------------------
10014 procedure Analyze_Abstract_State
10016 Pack_Id : Entity_Id)
10018 -- Flags used to verify the consistency of options
10020 AR_Seen : Boolean := False;
10021 AW_Seen : Boolean := False;
10022 ER_Seen : Boolean := False;
10023 EW_Seen : Boolean := False;
10024 External_Seen : Boolean := False;
10025 Ghost_Seen : Boolean := False;
10026 Others_Seen : Boolean := False;
10027 Part_Of_Seen : Boolean := False;
10028 Synchronous_Seen : Boolean := False;
10030 -- Flags used to store the static value of all external states'
10033 AR_Val : Boolean := False;
10034 AW_Val : Boolean := False;
10035 ER_Val : Boolean := False;
10036 EW_Val : Boolean := False;
10038 State_Id : Entity_Id := Empty;
10039 -- The entity to be generated for the current state declaration
10041 procedure Analyze_External_Option (Opt : Node_Id);
10042 -- Verify the legality of option External
10044 procedure Analyze_External_Property
10046 Expr : Node_Id := Empty);
10047 -- Verify the legailty of a single external property. Prop
10048 -- denotes the external property. Expr is the expression used
10049 -- to set the property.
10051 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10052 -- Verify the legality of option Part_Of
10054 procedure Check_Duplicate_Option
10056 Status : in out Boolean);
10057 -- Flag Status denotes whether a particular option has been
10058 -- seen while processing a state. This routine verifies that
10059 -- Opt is not a duplicate option and sets the flag Status
10060 -- (SPARK RM 7.1.4(1)).
10062 procedure Check_Duplicate_Property
10064 Status : in out Boolean);
10065 -- Flag Status denotes whether a particular property has been
10066 -- seen while processing option External. This routine verifies
10067 -- that Prop is not a duplicate property and sets flag Status.
10068 -- Opt is not a duplicate property and sets the flag Status.
10069 -- (SPARK RM 7.1.4(2))
10071 procedure Check_Ghost_Synchronous;
10072 -- Ensure that the abstract state is not subject to both Ghost
10073 -- and Synchronous simple options. Emit an error if this is the
10076 procedure Create_Abstract_State
10080 Is_Null : Boolean);
10081 -- Generate an abstract state entity with name Nam and enter it
10082 -- into visibility. Decl is the "declaration" of the state as
10083 -- it appears in pragma Abstract_State. Loc is the location of
10084 -- the related state "declaration". Flag Is_Null should be set
10085 -- when the associated Abstract_State pragma defines a null
10088 -----------------------------
10089 -- Analyze_External_Option --
10090 -----------------------------
10092 procedure Analyze_External_Option (Opt : Node_Id) is
10093 Errors : constant Nat := Serious_Errors_Detected;
10095 Props : Node_Id := Empty;
10098 if Nkind (Opt) = N_Component_Association then
10099 Props := Expression (Opt);
10102 -- External state with properties
10104 if Present (Props) then
10106 -- Multiple properties appear as an aggregate
10108 if Nkind (Props) = N_Aggregate then
10110 -- Simple property form
10112 Prop := First (Expressions (Props));
10113 while Present (Prop) loop
10114 Analyze_External_Property (Prop);
10118 -- Property with expression form
10120 Prop := First (Component_Associations (Props));
10121 while Present (Prop) loop
10122 Analyze_External_Property
10123 (Prop => First (Choices (Prop)),
10124 Expr => Expression (Prop));
10132 Analyze_External_Property (Props);
10135 -- An external state defined without any properties defaults
10136 -- all properties to True.
10145 -- Once all external properties have been processed, verify
10146 -- their mutual interaction. Do not perform the check when
10147 -- at least one of the properties is illegal as this will
10148 -- produce a bogus error.
10150 if Errors = Serious_Errors_Detected then
10151 Check_External_Properties
10152 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10154 end Analyze_External_Option;
10156 -------------------------------
10157 -- Analyze_External_Property --
10158 -------------------------------
10160 procedure Analyze_External_Property
10162 Expr : Node_Id := Empty)
10164 Expr_Val : Boolean;
10167 -- Check the placement of "others" (if available)
10169 if Nkind (Prop) = N_Others_Choice then
10170 if Others_Seen then
10172 ("only one others choice allowed in option External",
10175 Others_Seen := True;
10178 elsif Others_Seen then
10180 ("others must be the last property in option External",
10183 -- The only remaining legal options are the four predefined
10184 -- external properties.
10186 elsif Nkind (Prop) = N_Identifier
10187 and then Nam_In (Chars (Prop), Name_Async_Readers,
10188 Name_Async_Writers,
10189 Name_Effective_Reads,
10190 Name_Effective_Writes)
10194 -- Otherwise the construct is not a valid property
10197 SPARK_Msg_N ("invalid external state property", Prop);
10201 -- Ensure that the expression of the external state property
10202 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10204 if Present (Expr) then
10205 Analyze_And_Resolve (Expr, Standard_Boolean);
10207 if Is_OK_Static_Expression (Expr) then
10208 Expr_Val := Is_True (Expr_Value (Expr));
10211 ("expression of external state property must be "
10215 -- The lack of expression defaults the property to True
10221 -- Named properties
10223 if Nkind (Prop) = N_Identifier then
10224 if Chars (Prop) = Name_Async_Readers then
10225 Check_Duplicate_Property (Prop, AR_Seen);
10226 AR_Val := Expr_Val;
10228 elsif Chars (Prop) = Name_Async_Writers then
10229 Check_Duplicate_Property (Prop, AW_Seen);
10230 AW_Val := Expr_Val;
10232 elsif Chars (Prop) = Name_Effective_Reads then
10233 Check_Duplicate_Property (Prop, ER_Seen);
10234 ER_Val := Expr_Val;
10237 Check_Duplicate_Property (Prop, EW_Seen);
10238 EW_Val := Expr_Val;
10241 -- The handling of property "others" must take into account
10242 -- all other named properties that have been encountered so
10243 -- far. Only those that have not been seen are affected by
10247 if not AR_Seen then
10248 AR_Val := Expr_Val;
10251 if not AW_Seen then
10252 AW_Val := Expr_Val;
10255 if not ER_Seen then
10256 ER_Val := Expr_Val;
10259 if not EW_Seen then
10260 EW_Val := Expr_Val;
10263 end Analyze_External_Property;
10265 ----------------------------
10266 -- Analyze_Part_Of_Option --
10267 ----------------------------
10269 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10270 Encap : constant Node_Id := Expression (Opt);
10271 Encap_Id : Entity_Id;
10275 Check_Duplicate_Option (Opt, Part_Of_Seen);
10278 (Indic => First (Choices (Opt)),
10279 Item_Id => State_Id,
10281 Encap_Id => Encap_Id,
10284 -- The Part_Of indicator transforms the abstract state into
10285 -- a constituent of the encapsulating state or single
10286 -- concurrent type.
10289 pragma Assert (Present (Encap_Id));
10291 Append_Elmt (State_Id, Part_Of_Constituents (Encap_Id));
10292 Set_Encapsulating_State (State_Id, Encap_Id);
10294 end Analyze_Part_Of_Option;
10296 ----------------------------
10297 -- Check_Duplicate_Option --
10298 ----------------------------
10300 procedure Check_Duplicate_Option
10302 Status : in out Boolean)
10306 SPARK_Msg_N ("duplicate state option", Opt);
10310 end Check_Duplicate_Option;
10312 ------------------------------
10313 -- Check_Duplicate_Property --
10314 ------------------------------
10316 procedure Check_Duplicate_Property
10318 Status : in out Boolean)
10322 SPARK_Msg_N ("duplicate external property", Prop);
10326 end Check_Duplicate_Property;
10328 -----------------------------
10329 -- Check_Ghost_Synchronous --
10330 -----------------------------
10332 procedure Check_Ghost_Synchronous is
10334 -- A synchronized abstract state cannot be Ghost and vice
10335 -- versa (SPARK RM 6.9(19)).
10337 if Ghost_Seen and Synchronous_Seen then
10338 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10340 end Check_Ghost_Synchronous;
10342 ---------------------------
10343 -- Create_Abstract_State --
10344 ---------------------------
10346 procedure Create_Abstract_State
10353 -- The abstract state may be semi-declared when the related
10354 -- package was withed through a limited with clause. In that
10355 -- case reuse the entity to fully declare the state.
10357 if Present (Decl) and then Present (Entity (Decl)) then
10358 State_Id := Entity (Decl);
10360 -- Otherwise the elaboration of pragma Abstract_State
10361 -- declares the state.
10364 State_Id := Make_Defining_Identifier (Loc, Nam);
10366 if Present (Decl) then
10367 Set_Entity (Decl, State_Id);
10371 -- Null states never come from source
10373 Set_Comes_From_Source (State_Id, not Is_Null);
10374 Set_Parent (State_Id, State);
10375 Set_Ekind (State_Id, E_Abstract_State);
10376 Set_Etype (State_Id, Standard_Void_Type);
10377 Set_Encapsulating_State (State_Id, Empty);
10378 Set_Refinement_Constituents (State_Id, New_Elmt_List);
10379 Set_Part_Of_Constituents (State_Id, New_Elmt_List);
10381 -- An abstract state declared within a Ghost region becomes
10382 -- Ghost (SPARK RM 6.9(2)).
10384 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10385 Set_Is_Ghost_Entity (State_Id);
10388 -- Establish a link between the state declaration and the
10389 -- abstract state entity. Note that a null state remains as
10390 -- N_Null and does not carry any linkages.
10392 if not Is_Null then
10393 if Present (Decl) then
10394 Set_Entity (Decl, State_Id);
10395 Set_Etype (Decl, Standard_Void_Type);
10398 -- Every non-null state must be defined, nameable and
10401 Push_Scope (Pack_Id);
10402 Generate_Definition (State_Id);
10403 Enter_Name (State_Id);
10406 end Create_Abstract_State;
10413 -- Start of processing for Analyze_Abstract_State
10416 -- A package with a null abstract state is not allowed to
10417 -- declare additional states.
10421 ("package & has null abstract state", State, Pack_Id);
10423 -- Null states appear as internally generated entities
10425 elsif Nkind (State) = N_Null then
10426 Create_Abstract_State
10427 (Nam => New_Internal_Name ('S'),
10429 Loc => Sloc (State),
10433 -- Catch a case where a null state appears in a list of
10434 -- non-null states.
10436 if Non_Null_Seen then
10438 ("package & has non-null abstract state",
10442 -- Simple state declaration
10444 elsif Nkind (State) = N_Identifier then
10445 Create_Abstract_State
10446 (Nam => Chars (State),
10448 Loc => Sloc (State),
10450 Non_Null_Seen := True;
10452 -- State declaration with various options. This construct
10453 -- appears as an extension aggregate in the tree.
10455 elsif Nkind (State) = N_Extension_Aggregate then
10456 if Nkind (Ancestor_Part (State)) = N_Identifier then
10457 Create_Abstract_State
10458 (Nam => Chars (Ancestor_Part (State)),
10459 Decl => Ancestor_Part (State),
10460 Loc => Sloc (Ancestor_Part (State)),
10462 Non_Null_Seen := True;
10465 ("state name must be an identifier",
10466 Ancestor_Part (State));
10469 -- Options External, Ghost and Synchronous appear as
10472 Opt := First (Expressions (State));
10473 while Present (Opt) loop
10474 if Nkind (Opt) = N_Identifier then
10478 if Chars (Opt) = Name_External then
10479 Check_Duplicate_Option (Opt, External_Seen);
10480 Analyze_External_Option (Opt);
10484 elsif Chars (Opt) = Name_Ghost then
10485 Check_Duplicate_Option (Opt, Ghost_Seen);
10486 Check_Ghost_Synchronous;
10488 if Present (State_Id) then
10489 Set_Is_Ghost_Entity (State_Id);
10494 elsif Chars (Opt) = Name_Synchronous then
10495 Check_Duplicate_Option (Opt, Synchronous_Seen);
10496 Check_Ghost_Synchronous;
10498 -- Option Part_Of without an encapsulating state is
10499 -- illegal (SPARK RM 7.1.4(9)).
10501 elsif Chars (Opt) = Name_Part_Of then
10503 ("indicator Part_Of must denote abstract state, "
10504 & "single protected type or single task type",
10507 -- Do not emit an error message when a previous state
10508 -- declaration with options was not parenthesized as
10509 -- the option is actually another state declaration.
10511 -- with Abstract_State
10512 -- (State_1 with ..., -- missing parentheses
10513 -- (State_2 with ...),
10514 -- State_3) -- ok state declaration
10516 elsif Missing_Parentheses then
10519 -- Otherwise the option is not allowed. Note that it
10520 -- is not possible to distinguish between an option
10521 -- and a state declaration when a previous state with
10522 -- options not properly parentheses.
10524 -- with Abstract_State
10525 -- (State_1 with ..., -- missing parentheses
10526 -- State_2); -- could be an option
10530 ("simple option not allowed in state declaration",
10534 -- Catch a case where missing parentheses around a state
10535 -- declaration with options cause a subsequent state
10536 -- declaration with options to be treated as an option.
10538 -- with Abstract_State
10539 -- (State_1 with ..., -- missing parentheses
10540 -- (State_2 with ...))
10542 elsif Nkind (Opt) = N_Extension_Aggregate then
10543 Missing_Parentheses := True;
10545 ("state declaration must be parenthesized",
10546 Ancestor_Part (State));
10548 -- Otherwise the option is malformed
10551 SPARK_Msg_N ("malformed option", Opt);
10557 -- Options External and Part_Of appear as component
10560 Opt := First (Component_Associations (State));
10561 while Present (Opt) loop
10562 Opt_Nam := First (Choices (Opt));
10564 if Nkind (Opt_Nam) = N_Identifier then
10565 if Chars (Opt_Nam) = Name_External then
10566 Analyze_External_Option (Opt);
10568 elsif Chars (Opt_Nam) = Name_Part_Of then
10569 Analyze_Part_Of_Option (Opt);
10572 SPARK_Msg_N ("invalid state option", Opt);
10575 SPARK_Msg_N ("invalid state option", Opt);
10581 -- Any other attempt to declare a state is illegal
10584 Malformed_State_Error (State);
10588 -- Guard against a junk state. In such cases no entity is
10589 -- generated and the subsequent checks cannot be applied.
10591 if Present (State_Id) then
10593 -- Verify whether the state does not introduce an illegal
10594 -- hidden state within a package subject to a null abstract
10597 Check_No_Hidden_State (State_Id);
10599 -- Check whether the lack of option Part_Of agrees with the
10600 -- placement of the abstract state with respect to the state
10603 if not Part_Of_Seen then
10604 Check_Missing_Part_Of (State_Id);
10607 -- Associate the state with its related package
10609 if No (Abstract_States (Pack_Id)) then
10610 Set_Abstract_States (Pack_Id, New_Elmt_List);
10613 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10615 end Analyze_Abstract_State;
10617 ---------------------------
10618 -- Malformed_State_Error --
10619 ---------------------------
10621 procedure Malformed_State_Error (State : Node_Id) is
10623 Error_Msg_N ("malformed abstract state declaration", State);
10625 -- An abstract state with a simple option is being declared
10626 -- with "=>" rather than the legal "with". The state appears
10627 -- as a component association.
10629 if Nkind (State) = N_Component_Association then
10630 Error_Msg_N ("\use WITH to specify simple option", State);
10632 end Malformed_State_Error;
10636 Pack_Decl : Node_Id;
10637 Pack_Id : Entity_Id;
10641 -- Start of processing for Abstract_State
10645 Check_No_Identifiers;
10646 Check_Arg_Count (1);
10648 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
10650 -- Ensure the proper placement of the pragma. Abstract states must
10651 -- be associated with a package declaration.
10653 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
10654 N_Package_Declaration)
10658 -- Otherwise the pragma is associated with an illegal construct
10665 Pack_Id := Defining_Entity (Pack_Decl);
10667 -- Chain the pragma on the contract for completeness
10669 Add_Contract_Item (N, Pack_Id);
10671 -- The legality checks of pragmas Abstract_State, Initializes, and
10672 -- Initial_Condition are affected by the SPARK mode in effect. In
10673 -- addition, these three pragmas are subject to an inherent order:
10675 -- 1) Abstract_State
10677 -- 3) Initial_Condition
10679 -- Analyze all these pragmas in the order outlined above
10681 Analyze_If_Present (Pragma_SPARK_Mode);
10683 -- A pragma that applies to a Ghost entity becomes Ghost for the
10684 -- purposes of legality checks and removal of ignored Ghost code.
10686 Mark_Pragma_As_Ghost (N, Pack_Id);
10687 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
10689 States := Expression (Get_Argument (N, Pack_Id));
10691 -- Multiple non-null abstract states appear as an aggregate
10693 if Nkind (States) = N_Aggregate then
10694 State := First (Expressions (States));
10695 while Present (State) loop
10696 Analyze_Abstract_State (State, Pack_Id);
10700 -- An abstract state with a simple option is being illegaly
10701 -- declared with "=>" rather than "with". In this case the
10702 -- state declaration appears as a component association.
10704 if Present (Component_Associations (States)) then
10705 State := First (Component_Associations (States));
10706 while Present (State) loop
10707 Malformed_State_Error (State);
10712 -- Various forms of a single abstract state. Note that these may
10713 -- include malformed state declarations.
10716 Analyze_Abstract_State (States, Pack_Id);
10719 Analyze_If_Present (Pragma_Initializes);
10720 Analyze_If_Present (Pragma_Initial_Condition);
10721 end Abstract_State;
10729 -- Note: this pragma also has some specific processing in Par.Prag
10730 -- because we want to set the Ada version mode during parsing.
10732 when Pragma_Ada_83 =>
10734 Check_Arg_Count (0);
10736 -- We really should check unconditionally for proper configuration
10737 -- pragma placement, since we really don't want mixed Ada modes
10738 -- within a single unit, and the GNAT reference manual has always
10739 -- said this was a configuration pragma, but we did not check and
10740 -- are hesitant to add the check now.
10742 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10743 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10744 -- or Ada 2012 mode.
10746 if Ada_Version >= Ada_2005 then
10747 Check_Valid_Configuration_Pragma;
10750 -- Now set Ada 83 mode
10752 Ada_Version := Ada_83;
10753 Ada_Version_Explicit := Ada_83;
10754 Ada_Version_Pragma := N;
10762 -- Note: this pragma also has some specific processing in Par.Prag
10763 -- because we want to set the Ada 83 version mode during parsing.
10765 when Pragma_Ada_95 =>
10767 Check_Arg_Count (0);
10769 -- We really should check unconditionally for proper configuration
10770 -- pragma placement, since we really don't want mixed Ada modes
10771 -- within a single unit, and the GNAT reference manual has always
10772 -- said this was a configuration pragma, but we did not check and
10773 -- are hesitant to add the check now.
10775 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10776 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10778 if Ada_Version >= Ada_2005 then
10779 Check_Valid_Configuration_Pragma;
10782 -- Now set Ada 95 mode
10784 Ada_Version := Ada_95;
10785 Ada_Version_Explicit := Ada_95;
10786 Ada_Version_Pragma := N;
10788 ---------------------
10789 -- Ada_05/Ada_2005 --
10790 ---------------------
10793 -- pragma Ada_05 (LOCAL_NAME);
10795 -- pragma Ada_2005;
10796 -- pragma Ada_2005 (LOCAL_NAME):
10798 -- Note: these pragmas also have some specific processing in Par.Prag
10799 -- because we want to set the Ada 2005 version mode during parsing.
10801 -- The one argument form is used for managing the transition from
10802 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10803 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10804 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10805 -- mode, a preference rule is established which does not choose
10806 -- such an entity unless it is unambiguously specified. This avoids
10807 -- extra subprograms marked this way from generating ambiguities in
10808 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10809 -- intended for exclusive use in the GNAT run-time library.
10811 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
10817 if Arg_Count = 1 then
10818 Check_Arg_Is_Local_Name (Arg1);
10819 E_Id := Get_Pragma_Arg (Arg1);
10821 if Etype (E_Id) = Any_Type then
10825 Set_Is_Ada_2005_Only (Entity (E_Id));
10826 Record_Rep_Item (Entity (E_Id), N);
10829 Check_Arg_Count (0);
10831 -- For Ada_2005 we unconditionally enforce the documented
10832 -- configuration pragma placement, since we do not want to
10833 -- tolerate mixed modes in a unit involving Ada 2005. That
10834 -- would cause real difficulties for those cases where there
10835 -- are incompatibilities between Ada 95 and Ada 2005.
10837 Check_Valid_Configuration_Pragma;
10839 -- Now set appropriate Ada mode
10841 Ada_Version := Ada_2005;
10842 Ada_Version_Explicit := Ada_2005;
10843 Ada_Version_Pragma := N;
10847 ---------------------
10848 -- Ada_12/Ada_2012 --
10849 ---------------------
10852 -- pragma Ada_12 (LOCAL_NAME);
10854 -- pragma Ada_2012;
10855 -- pragma Ada_2012 (LOCAL_NAME):
10857 -- Note: these pragmas also have some specific processing in Par.Prag
10858 -- because we want to set the Ada 2012 version mode during parsing.
10860 -- The one argument form is used for managing the transition from Ada
10861 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10862 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10863 -- mode will generate a warning. In addition, in any pre-Ada_2012
10864 -- mode, a preference rule is established which does not choose
10865 -- such an entity unless it is unambiguously specified. This avoids
10866 -- extra subprograms marked this way from generating ambiguities in
10867 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10868 -- intended for exclusive use in the GNAT run-time library.
10870 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
10876 if Arg_Count = 1 then
10877 Check_Arg_Is_Local_Name (Arg1);
10878 E_Id := Get_Pragma_Arg (Arg1);
10880 if Etype (E_Id) = Any_Type then
10884 Set_Is_Ada_2012_Only (Entity (E_Id));
10885 Record_Rep_Item (Entity (E_Id), N);
10888 Check_Arg_Count (0);
10890 -- For Ada_2012 we unconditionally enforce the documented
10891 -- configuration pragma placement, since we do not want to
10892 -- tolerate mixed modes in a unit involving Ada 2012. That
10893 -- would cause real difficulties for those cases where there
10894 -- are incompatibilities between Ada 95 and Ada 2012. We could
10895 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10897 Check_Valid_Configuration_Pragma;
10899 -- Now set appropriate Ada mode
10901 Ada_Version := Ada_2012;
10902 Ada_Version_Explicit := Ada_2012;
10903 Ada_Version_Pragma := N;
10907 ----------------------
10908 -- All_Calls_Remote --
10909 ----------------------
10911 -- pragma All_Calls_Remote [(library_package_NAME)];
10913 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
10914 Lib_Entity : Entity_Id;
10917 Check_Ada_83_Warning;
10918 Check_Valid_Library_Unit_Pragma;
10920 if Nkind (N) = N_Null_Statement then
10924 Lib_Entity := Find_Lib_Unit_Name;
10926 -- A pragma that applies to a Ghost entity becomes Ghost for the
10927 -- purposes of legality checks and removal of ignored Ghost code.
10929 Mark_Pragma_As_Ghost (N, Lib_Entity);
10931 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10933 if Present (Lib_Entity) and then not Debug_Flag_U then
10934 if not Is_Remote_Call_Interface (Lib_Entity) then
10935 Error_Pragma ("pragma% only apply to rci unit");
10937 -- Set flag for entity of the library unit
10940 Set_Has_All_Calls_Remote (Lib_Entity);
10943 end All_Calls_Remote;
10945 ---------------------------
10946 -- Allow_Integer_Address --
10947 ---------------------------
10949 -- pragma Allow_Integer_Address;
10951 when Pragma_Allow_Integer_Address =>
10953 Check_Valid_Configuration_Pragma;
10954 Check_Arg_Count (0);
10956 -- If Address is a private type, then set the flag to allow
10957 -- integer address values. If Address is not private, then this
10958 -- pragma has no purpose, so it is simply ignored. Not clear if
10959 -- there are any such targets now.
10961 if Opt.Address_Is_Private then
10962 Opt.Allow_Integer_Address := True;
10970 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10971 -- ARG ::= NAME | EXPRESSION
10973 -- The first two arguments are by convention intended to refer to an
10974 -- external tool and a tool-specific function. These arguments are
10977 when Pragma_Annotate => Annotate : declare
10984 Check_At_Least_N_Arguments (1);
10986 Nam_Arg := Last (Pragma_Argument_Associations (N));
10988 -- Determine whether the last argument is "Entity => local_NAME"
10989 -- and if it is, perform the required semantic checks. Remove the
10990 -- argument from further processing.
10992 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
10993 and then Chars (Nam_Arg) = Name_Entity
10995 Check_Arg_Is_Local_Name (Nam_Arg);
10996 Arg_Count := Arg_Count - 1;
10998 -- A pragma that applies to a Ghost entity becomes Ghost for
10999 -- the purposes of legality checks and removal of ignored Ghost
11002 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11003 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11005 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11008 -- Not allowed in compiler units (bootstrap issues)
11010 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11013 -- Continue the processing with last argument removed for now
11015 Check_Arg_Is_Identifier (Arg1);
11016 Check_No_Identifiers;
11019 -- The second parameter is optional, it is never analyzed
11024 -- Otherwise there is a second parameter
11027 -- The second parameter must be an identifier
11029 Check_Arg_Is_Identifier (Arg2);
11031 -- Process the remaining parameters (if any)
11033 Arg := Next (Arg2);
11034 while Present (Arg) loop
11035 Expr := Get_Pragma_Arg (Arg);
11038 if Is_Entity_Name (Expr) then
11041 -- For string literals, we assume Standard_String as the
11042 -- type, unless the string contains wide or wide_wide
11045 elsif Nkind (Expr) = N_String_Literal then
11046 if Has_Wide_Wide_Character (Expr) then
11047 Resolve (Expr, Standard_Wide_Wide_String);
11048 elsif Has_Wide_Character (Expr) then
11049 Resolve (Expr, Standard_Wide_String);
11051 Resolve (Expr, Standard_String);
11054 elsif Is_Overloaded (Expr) then
11055 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11066 -------------------------------------------------
11067 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11068 -------------------------------------------------
11071 -- ( [Check => ] Boolean_EXPRESSION
11072 -- [, [Message =>] Static_String_EXPRESSION]);
11074 -- pragma Assert_And_Cut
11075 -- ( [Check => ] Boolean_EXPRESSION
11076 -- [, [Message =>] Static_String_EXPRESSION]);
11079 -- ( [Check => ] Boolean_EXPRESSION
11080 -- [, [Message =>] Static_String_EXPRESSION]);
11082 -- pragma Loop_Invariant
11083 -- ( [Check => ] Boolean_EXPRESSION
11084 -- [, [Message =>] Static_String_EXPRESSION]);
11086 when Pragma_Assert |
11087 Pragma_Assert_And_Cut |
11089 Pragma_Loop_Invariant =>
11091 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11092 -- Determine whether expression Expr contains a Loop_Entry
11093 -- attribute reference.
11095 -------------------------
11096 -- Contains_Loop_Entry --
11097 -------------------------
11099 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11100 Has_Loop_Entry : Boolean := False;
11102 function Process (N : Node_Id) return Traverse_Result;
11103 -- Process function for traversal to look for Loop_Entry
11109 function Process (N : Node_Id) return Traverse_Result is
11111 if Nkind (N) = N_Attribute_Reference
11112 and then Attribute_Name (N) = Name_Loop_Entry
11114 Has_Loop_Entry := True;
11121 procedure Traverse is new Traverse_Proc (Process);
11123 -- Start of processing for Contains_Loop_Entry
11127 return Has_Loop_Entry;
11128 end Contains_Loop_Entry;
11133 New_Args : List_Id;
11135 -- Start of processing for Assert
11138 -- Assert is an Ada 2005 RM-defined pragma
11140 if Prag_Id = Pragma_Assert then
11143 -- The remaining ones are GNAT pragmas
11149 Check_At_Least_N_Arguments (1);
11150 Check_At_Most_N_Arguments (2);
11151 Check_Arg_Order ((Name_Check, Name_Message));
11152 Check_Optional_Identifier (Arg1, Name_Check);
11153 Expr := Get_Pragma_Arg (Arg1);
11155 -- Special processing for Loop_Invariant, Loop_Variant or for
11156 -- other cases where a Loop_Entry attribute is present. If the
11157 -- assertion pragma contains attribute Loop_Entry, ensure that
11158 -- the related pragma is within a loop.
11160 if Prag_Id = Pragma_Loop_Invariant
11161 or else Prag_Id = Pragma_Loop_Variant
11162 or else Contains_Loop_Entry (Expr)
11164 Check_Loop_Pragma_Placement;
11166 -- Perform preanalysis to deal with embedded Loop_Entry
11169 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11172 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11173 -- a corresponding Check pragma:
11175 -- pragma Check (name, condition [, msg]);
11177 -- Where name is the identifier matching the pragma name. So
11178 -- rewrite pragma in this manner, transfer the message argument
11179 -- if present, and analyze the result
11181 -- Note: When dealing with a semantically analyzed tree, the
11182 -- information that a Check node N corresponds to a source Assert,
11183 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11184 -- pragma kind of Original_Node(N).
11186 New_Args := New_List (
11187 Make_Pragma_Argument_Association (Loc,
11188 Expression => Make_Identifier (Loc, Pname)),
11189 Make_Pragma_Argument_Association (Sloc (Expr),
11190 Expression => Expr));
11192 if Arg_Count > 1 then
11193 Check_Optional_Identifier (Arg2, Name_Message);
11195 -- Provide semantic annnotations for optional argument, for
11196 -- ASIS use, before rewriting.
11198 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11199 Append_To (New_Args, New_Copy_Tree (Arg2));
11202 -- Rewrite as Check pragma
11206 Chars => Name_Check,
11207 Pragma_Argument_Associations => New_Args));
11212 ----------------------
11213 -- Assertion_Policy --
11214 ----------------------
11216 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11218 -- The following form is Ada 2012 only, but we allow it in all modes
11220 -- Pragma Assertion_Policy (
11221 -- ASSERTION_KIND => POLICY_IDENTIFIER
11222 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11224 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11226 -- RM_ASSERTION_KIND ::= Assert |
11227 -- Static_Predicate |
11228 -- Dynamic_Predicate |
11233 -- Type_Invariant |
11234 -- Type_Invariant'Class
11236 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11238 -- Contract_Cases |
11240 -- Default_Initial_Condition |
11242 -- Initial_Condition |
11243 -- Loop_Invariant |
11249 -- Statement_Assertions
11251 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11252 -- ID_ASSERTION_KIND list contains implementation-defined additions
11253 -- recognized by GNAT. The effect is to control the behavior of
11254 -- identically named aspects and pragmas, depending on the specified
11255 -- policy identifier:
11257 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11259 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11260 -- implementation-defined addition that results in totally ignoring
11261 -- the corresponding assertion. If Disable is specified, then the
11262 -- argument of the assertion is not even analyzed. This is useful
11263 -- when the aspect/pragma argument references entities in a with'ed
11264 -- package that is replaced by a dummy package in the final build.
11266 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11267 -- and Type_Invariant'Class were recognized by the parser and
11268 -- transformed into references to the special internal identifiers
11269 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11270 -- processing is required here.
11272 when Pragma_Assertion_Policy => Assertion_Policy : declare
11281 -- This can always appear as a configuration pragma
11283 if Is_Configuration_Pragma then
11286 -- It can also appear in a declarative part or package spec in Ada
11287 -- 2012 mode. We allow this in other modes, but in that case we
11288 -- consider that we have an Ada 2012 pragma on our hands.
11291 Check_Is_In_Decl_Part_Or_Package_Spec;
11295 -- One argument case with no identifier (first form above)
11298 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11299 or else Chars (Arg1) = No_Name)
11301 Check_Arg_Is_One_Of
11302 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11304 -- Treat one argument Assertion_Policy as equivalent to:
11306 -- pragma Check_Policy (Assertion, policy)
11308 -- So rewrite pragma in that manner and link on to the chain
11309 -- of Check_Policy pragmas, marking the pragma as analyzed.
11311 Policy := Get_Pragma_Arg (Arg1);
11315 Chars => Name_Check_Policy,
11316 Pragma_Argument_Associations => New_List (
11317 Make_Pragma_Argument_Association (Loc,
11318 Expression => Make_Identifier (Loc, Name_Assertion)),
11320 Make_Pragma_Argument_Association (Loc,
11322 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11325 -- Here if we have two or more arguments
11328 Check_At_Least_N_Arguments (1);
11331 -- Loop through arguments
11334 while Present (Arg) loop
11335 LocP := Sloc (Arg);
11337 -- Kind must be specified
11339 if Nkind (Arg) /= N_Pragma_Argument_Association
11340 or else Chars (Arg) = No_Name
11343 ("missing assertion kind for pragma%", Arg);
11346 -- Check Kind and Policy have allowed forms
11348 Kind := Chars (Arg);
11350 if not Is_Valid_Assertion_Kind (Kind) then
11352 ("invalid assertion kind for pragma%", Arg);
11355 Check_Arg_Is_One_Of
11356 (Arg, Name_Check, Name_Disable, Name_Ignore);
11358 -- Rewrite the Assertion_Policy pragma as a series of
11359 -- Check_Policy pragmas of the form:
11361 -- Check_Policy (Kind, Policy);
11363 -- Note: the insertion of the pragmas cannot be done with
11364 -- Insert_Action because in the configuration case, there
11365 -- are no scopes on the scope stack and the mechanism will
11368 Insert_Before_And_Analyze (N,
11370 Chars => Name_Check_Policy,
11371 Pragma_Argument_Associations => New_List (
11372 Make_Pragma_Argument_Association (LocP,
11373 Expression => Make_Identifier (LocP, Kind)),
11374 Make_Pragma_Argument_Association (LocP,
11375 Expression => Get_Pragma_Arg (Arg)))));
11380 -- Rewrite the Assertion_Policy pragma as null since we have
11381 -- now inserted all the equivalent Check pragmas.
11383 Rewrite (N, Make_Null_Statement (Loc));
11386 end Assertion_Policy;
11388 ------------------------------
11389 -- Assume_No_Invalid_Values --
11390 ------------------------------
11392 -- pragma Assume_No_Invalid_Values (On | Off);
11394 when Pragma_Assume_No_Invalid_Values =>
11396 Check_Valid_Configuration_Pragma;
11397 Check_Arg_Count (1);
11398 Check_No_Identifiers;
11399 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11401 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11402 Assume_No_Invalid_Values := True;
11404 Assume_No_Invalid_Values := False;
11407 --------------------------
11408 -- Attribute_Definition --
11409 --------------------------
11411 -- pragma Attribute_Definition
11412 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11413 -- [Entity =>] LOCAL_NAME,
11414 -- [Expression =>] EXPRESSION | NAME);
11416 when Pragma_Attribute_Definition => Attribute_Definition : declare
11417 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11422 Check_Arg_Count (3);
11423 Check_Optional_Identifier (Arg1, "attribute");
11424 Check_Optional_Identifier (Arg2, "entity");
11425 Check_Optional_Identifier (Arg3, "expression");
11427 if Nkind (Attribute_Designator) /= N_Identifier then
11428 Error_Msg_N ("attribute name expected", Attribute_Designator);
11432 Check_Arg_Is_Local_Name (Arg2);
11434 -- If the attribute is not recognized, then issue a warning (not
11435 -- an error), and ignore the pragma.
11437 Aname := Chars (Attribute_Designator);
11439 if not Is_Attribute_Name (Aname) then
11440 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11444 -- Otherwise, rewrite the pragma as an attribute definition clause
11447 Make_Attribute_Definition_Clause (Loc,
11448 Name => Get_Pragma_Arg (Arg2),
11450 Expression => Get_Pragma_Arg (Arg3)));
11452 end Attribute_Definition;
11454 ------------------------------------------------------------------
11455 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11456 ------------------------------------------------------------------
11458 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11459 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11460 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11461 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11463 when Pragma_Async_Readers |
11464 Pragma_Async_Writers |
11465 Pragma_Effective_Reads |
11466 Pragma_Effective_Writes =>
11467 Async_Effective : declare
11468 Obj_Decl : Node_Id;
11469 Obj_Id : Entity_Id;
11473 Check_No_Identifiers;
11474 Check_At_Most_N_Arguments (1);
11476 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
11478 -- Object declaration
11480 if Nkind (Obj_Decl) = N_Object_Declaration then
11483 -- Otherwise the pragma is associated with an illegal construact
11490 Obj_Id := Defining_Entity (Obj_Decl);
11492 -- Perform minimal verification to ensure that the argument is at
11493 -- least a variable. Subsequent finer grained checks will be done
11494 -- at the end of the declarative region the contains the pragma.
11496 if Ekind (Obj_Id) = E_Variable then
11498 -- Chain the pragma on the contract for further processing by
11499 -- Analyze_External_Property_In_Decl_Part.
11501 Add_Contract_Item (N, Obj_Id);
11503 -- A pragma that applies to a Ghost entity becomes Ghost for
11504 -- the purposes of legality checks and removal of ignored Ghost
11507 Mark_Pragma_As_Ghost (N, Obj_Id);
11509 -- Analyze the Boolean expression (if any)
11511 if Present (Arg1) then
11512 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
11515 -- Otherwise the external property applies to a constant
11518 Error_Pragma ("pragma % must apply to a volatile object");
11520 end Async_Effective;
11526 -- pragma Asynchronous (LOCAL_NAME);
11528 when Pragma_Asynchronous => Asynchronous : declare
11531 Formal : Entity_Id;
11536 procedure Process_Async_Pragma;
11537 -- Common processing for procedure and access-to-procedure case
11539 --------------------------
11540 -- Process_Async_Pragma --
11541 --------------------------
11543 procedure Process_Async_Pragma is
11546 Set_Is_Asynchronous (Nm);
11550 -- The formals should be of mode IN (RM E.4.1(6))
11553 while Present (S) loop
11554 Formal := Defining_Identifier (S);
11556 if Nkind (Formal) = N_Defining_Identifier
11557 and then Ekind (Formal) /= E_In_Parameter
11560 ("pragma% procedure can only have IN parameter",
11567 Set_Is_Asynchronous (Nm);
11568 end Process_Async_Pragma;
11570 -- Start of processing for pragma Asynchronous
11573 Check_Ada_83_Warning;
11574 Check_No_Identifiers;
11575 Check_Arg_Count (1);
11576 Check_Arg_Is_Local_Name (Arg1);
11578 if Debug_Flag_U then
11582 C_Ent := Cunit_Entity (Current_Sem_Unit);
11583 Analyze (Get_Pragma_Arg (Arg1));
11584 Nm := Entity (Get_Pragma_Arg (Arg1));
11586 -- A pragma that applies to a Ghost entity becomes Ghost for the
11587 -- purposes of legality checks and removal of ignored Ghost code.
11589 Mark_Pragma_As_Ghost (N, Nm);
11591 if not Is_Remote_Call_Interface (C_Ent)
11592 and then not Is_Remote_Types (C_Ent)
11594 -- This pragma should only appear in an RCI or Remote Types
11595 -- unit (RM E.4.1(4)).
11598 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11601 if Ekind (Nm) = E_Procedure
11602 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11604 if not Is_Remote_Call_Interface (Nm) then
11606 ("pragma% cannot be applied on non-remote procedure",
11610 L := Parameter_Specifications (Parent (Nm));
11611 Process_Async_Pragma;
11614 elsif Ekind (Nm) = E_Function then
11616 ("pragma% cannot be applied to function", Arg1);
11618 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11619 if Is_Record_Type (Nm) then
11621 -- A record type that is the Equivalent_Type for a remote
11622 -- access-to-subprogram type.
11624 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
11627 -- A non-expanded RAS type (distribution is not enabled)
11629 Decl := Declaration_Node (Nm);
11632 if Nkind (Decl) = N_Full_Type_Declaration
11633 and then Nkind (Type_Definition (Decl)) =
11634 N_Access_Procedure_Definition
11636 L := Parameter_Specifications (Type_Definition (Decl));
11637 Process_Async_Pragma;
11639 if Is_Asynchronous (Nm)
11640 and then Expander_Active
11641 and then Get_PCS_Name /= Name_No_DSA
11643 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11648 ("pragma% cannot reference access-to-function type",
11652 -- Only other possibility is Access-to-class-wide type
11654 elsif Is_Access_Type (Nm)
11655 and then Is_Class_Wide_Type (Designated_Type (Nm))
11657 Check_First_Subtype (Arg1);
11658 Set_Is_Asynchronous (Nm);
11659 if Expander_Active then
11660 RACW_Type_Is_Asynchronous (Nm);
11664 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
11672 -- pragma Atomic (LOCAL_NAME);
11674 when Pragma_Atomic =>
11675 Process_Atomic_Independent_Shared_Volatile;
11677 -----------------------
11678 -- Atomic_Components --
11679 -----------------------
11681 -- pragma Atomic_Components (array_LOCAL_NAME);
11683 -- This processing is shared by Volatile_Components
11685 when Pragma_Atomic_Components |
11686 Pragma_Volatile_Components =>
11687 Atomic_Components : declare
11694 Check_Ada_83_Warning;
11695 Check_No_Identifiers;
11696 Check_Arg_Count (1);
11697 Check_Arg_Is_Local_Name (Arg1);
11698 E_Id := Get_Pragma_Arg (Arg1);
11700 if Etype (E_Id) = Any_Type then
11704 E := Entity (E_Id);
11706 -- A pragma that applies to a Ghost entity becomes Ghost for the
11707 -- purposes of legality checks and removal of ignored Ghost code.
11709 Mark_Pragma_As_Ghost (N, E);
11710 Check_Duplicate_Pragma (E);
11712 if Rep_Item_Too_Early (E, N)
11714 Rep_Item_Too_Late (E, N)
11719 D := Declaration_Node (E);
11722 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
11724 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
11725 and then Nkind (D) = N_Object_Declaration
11726 and then Nkind (Object_Definition (D)) =
11727 N_Constrained_Array_Definition)
11729 -- The flag is set on the object, or on the base type
11731 if Nkind (D) /= N_Object_Declaration then
11732 E := Base_Type (E);
11735 -- Atomic implies both Independent and Volatile
11737 if Prag_Id = Pragma_Atomic_Components then
11738 Set_Has_Atomic_Components (E);
11739 Set_Has_Independent_Components (E);
11742 Set_Has_Volatile_Components (E);
11745 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
11747 end Atomic_Components;
11749 --------------------
11750 -- Attach_Handler --
11751 --------------------
11753 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11755 when Pragma_Attach_Handler =>
11756 Check_Ada_83_Warning;
11757 Check_No_Identifiers;
11758 Check_Arg_Count (2);
11760 if No_Run_Time_Mode then
11761 Error_Msg_CRT ("Attach_Handler pragma", N);
11763 Check_Interrupt_Or_Attach_Handler;
11765 -- The expression that designates the attribute may depend on a
11766 -- discriminant, and is therefore a per-object expression, to
11767 -- be expanded in the init proc. If expansion is enabled, then
11768 -- perform semantic checks on a copy only.
11773 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
11776 -- In Relaxed_RM_Semantics mode, we allow any static
11777 -- integer value, for compatibility with other compilers.
11779 if Relaxed_RM_Semantics
11780 and then Nkind (Parg2) = N_Integer_Literal
11782 Typ := Standard_Integer;
11784 Typ := RTE (RE_Interrupt_ID);
11787 if Expander_Active then
11788 Temp := New_Copy_Tree (Parg2);
11789 Set_Parent (Temp, N);
11790 Preanalyze_And_Resolve (Temp, Typ);
11793 Resolve (Parg2, Typ);
11797 Process_Interrupt_Or_Attach_Handler;
11800 --------------------
11801 -- C_Pass_By_Copy --
11802 --------------------
11804 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11806 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
11812 Check_Valid_Configuration_Pragma;
11813 Check_Arg_Count (1);
11814 Check_Optional_Identifier (Arg1, "max_size");
11816 Arg := Get_Pragma_Arg (Arg1);
11817 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
11819 Val := Expr_Value (Arg);
11823 ("maximum size for pragma% must be positive", Arg1);
11825 elsif UI_Is_In_Int_Range (Val) then
11826 Default_C_Record_Mechanism := UI_To_Int (Val);
11828 -- If a giant value is given, Int'Last will do well enough.
11829 -- If sometime someone complains that a record larger than
11830 -- two gigabytes is not copied, we will worry about it then.
11833 Default_C_Record_Mechanism := Mechanism_Type'Last;
11835 end C_Pass_By_Copy;
11841 -- pragma Check ([Name =>] CHECK_KIND,
11842 -- [Check =>] Boolean_EXPRESSION
11843 -- [,[Message =>] String_EXPRESSION]);
11845 -- CHECK_KIND ::= IDENTIFIER |
11848 -- Invariant'Class |
11849 -- Type_Invariant'Class
11851 -- The identifiers Assertions and Statement_Assertions are not
11852 -- allowed, since they have special meaning for Check_Policy.
11854 when Pragma_Check => Check : declare
11860 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
11863 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
11864 -- the mode now to ensure that any nodes generated during analysis
11865 -- and expansion are marked as Ghost.
11867 Set_Ghost_Mode (N);
11870 Check_At_Least_N_Arguments (2);
11871 Check_At_Most_N_Arguments (3);
11872 Check_Optional_Identifier (Arg1, Name_Name);
11873 Check_Optional_Identifier (Arg2, Name_Check);
11875 if Arg_Count = 3 then
11876 Check_Optional_Identifier (Arg3, Name_Message);
11877 Str := Get_Pragma_Arg (Arg3);
11880 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
11881 Check_Arg_Is_Identifier (Arg1);
11882 Cname := Chars (Get_Pragma_Arg (Arg1));
11884 -- Check forbidden name Assertions or Statement_Assertions
11887 when Name_Assertions =>
11889 ("""Assertions"" is not allowed as a check kind for "
11890 & "pragma%", Arg1);
11892 when Name_Statement_Assertions =>
11894 ("""Statement_Assertions"" is not allowed as a check kind "
11895 & "for pragma%", Arg1);
11901 -- Check applicable policy. We skip this if Checked/Ignored status
11902 -- is already set (e.g. in the case of a pragma from an aspect).
11904 if Is_Checked (N) or else Is_Ignored (N) then
11907 -- For a non-source pragma that is a rewriting of another pragma,
11908 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11910 elsif Is_Rewrite_Substitution (N)
11911 and then Nkind (Original_Node (N)) = N_Pragma
11912 and then Original_Node (N) /= N
11914 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11915 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11917 -- Otherwise query the applicable policy at this point
11920 case Check_Kind (Cname) is
11921 when Name_Ignore =>
11922 Set_Is_Ignored (N, True);
11923 Set_Is_Checked (N, False);
11926 Set_Is_Ignored (N, False);
11927 Set_Is_Checked (N, True);
11929 -- For disable, rewrite pragma as null statement and skip
11930 -- rest of the analysis of the pragma.
11932 when Name_Disable =>
11933 Rewrite (N, Make_Null_Statement (Loc));
11937 -- No other possibilities
11940 raise Program_Error;
11944 -- If check kind was not Disable, then continue pragma analysis
11946 Expr := Get_Pragma_Arg (Arg2);
11948 -- Deal with SCO generation
11952 -- Nothing to do for invariants and predicates as the checks
11953 -- occur in the client units. The SCO for the aspect in the
11954 -- declaration unit is conservatively always enabled.
11956 when Name_Invariant | Name_Predicate =>
11959 -- Otherwise mark aspect/pragma SCO as enabled
11962 if Is_Checked (N) and then not Split_PPC (N) then
11963 Set_SCO_Pragma_Enabled (Loc);
11967 -- Deal with analyzing the string argument
11969 if Arg_Count = 3 then
11971 -- If checks are not on we don't want any expansion (since
11972 -- such expansion would not get properly deleted) but
11973 -- we do want to analyze (to get proper references).
11974 -- The Preanalyze_And_Resolve routine does just what we want
11976 if Is_Ignored (N) then
11977 Preanalyze_And_Resolve (Str, Standard_String);
11979 -- Otherwise we need a proper analysis and expansion
11982 Analyze_And_Resolve (Str, Standard_String);
11986 -- Now you might think we could just do the same with the Boolean
11987 -- expression if checks are off (and expansion is on) and then
11988 -- rewrite the check as a null statement. This would work but we
11989 -- would lose the useful warnings about an assertion being bound
11990 -- to fail even if assertions are turned off.
11992 -- So instead we wrap the boolean expression in an if statement
11993 -- that looks like:
11995 -- if False and then condition then
11999 -- The reason we do this rewriting during semantic analysis rather
12000 -- than as part of normal expansion is that we cannot analyze and
12001 -- expand the code for the boolean expression directly, or it may
12002 -- cause insertion of actions that would escape the attempt to
12003 -- suppress the check code.
12005 -- Note that the Sloc for the if statement corresponds to the
12006 -- argument condition, not the pragma itself. The reason for
12007 -- this is that we may generate a warning if the condition is
12008 -- False at compile time, and we do not want to delete this
12009 -- warning when we delete the if statement.
12011 if Expander_Active and Is_Ignored (N) then
12012 Eloc := Sloc (Expr);
12015 Make_If_Statement (Eloc,
12017 Make_And_Then (Eloc,
12018 Left_Opnd => Make_Identifier (Eloc, Name_False),
12019 Right_Opnd => Expr),
12020 Then_Statements => New_List (
12021 Make_Null_Statement (Eloc))));
12023 -- Now go ahead and analyze the if statement
12025 In_Assertion_Expr := In_Assertion_Expr + 1;
12027 -- One rather special treatment. If we are now in Eliminated
12028 -- overflow mode, then suppress overflow checking since we do
12029 -- not want to drag in the bignum stuff if we are in Ignore
12030 -- mode anyway. This is particularly important if we are using
12031 -- a configurable run time that does not support bignum ops.
12033 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12035 Svo : constant Boolean :=
12036 Scope_Suppress.Suppress (Overflow_Check);
12038 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12039 Scope_Suppress.Suppress (Overflow_Check) := True;
12041 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12042 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12045 -- Not that special case
12051 -- All done with this check
12053 In_Assertion_Expr := In_Assertion_Expr - 1;
12055 -- Check is active or expansion not active. In these cases we can
12056 -- just go ahead and analyze the boolean with no worries.
12059 In_Assertion_Expr := In_Assertion_Expr + 1;
12060 Analyze_And_Resolve (Expr, Any_Boolean);
12061 In_Assertion_Expr := In_Assertion_Expr - 1;
12064 Ghost_Mode := Save_Ghost_Mode;
12067 --------------------------
12068 -- Check_Float_Overflow --
12069 --------------------------
12071 -- pragma Check_Float_Overflow;
12073 when Pragma_Check_Float_Overflow =>
12075 Check_Valid_Configuration_Pragma;
12076 Check_Arg_Count (0);
12077 Check_Float_Overflow := not Machine_Overflows_On_Target;
12083 -- pragma Check_Name (check_IDENTIFIER);
12085 when Pragma_Check_Name =>
12087 Check_No_Identifiers;
12088 Check_Valid_Configuration_Pragma;
12089 Check_Arg_Count (1);
12090 Check_Arg_Is_Identifier (Arg1);
12093 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12096 for J in Check_Names.First .. Check_Names.Last loop
12097 if Check_Names.Table (J) = Nam then
12102 Check_Names.Append (Nam);
12109 -- This is the old style syntax, which is still allowed in all modes:
12111 -- pragma Check_Policy ([Name =>] CHECK_KIND
12112 -- [Policy =>] POLICY_IDENTIFIER);
12114 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12116 -- CHECK_KIND ::= IDENTIFIER |
12119 -- Type_Invariant'Class |
12122 -- This is the new style syntax, compatible with Assertion_Policy
12123 -- and also allowed in all modes.
12125 -- Pragma Check_Policy (
12126 -- CHECK_KIND => POLICY_IDENTIFIER
12127 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12129 -- Note: the identifiers Name and Policy are not allowed as
12130 -- Check_Kind values. This avoids ambiguities between the old and
12131 -- new form syntax.
12133 when Pragma_Check_Policy => Check_Policy : declare
12139 Check_At_Least_N_Arguments (1);
12141 -- A Check_Policy pragma can appear either as a configuration
12142 -- pragma, or in a declarative part or a package spec (see RM
12143 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12144 -- followed for Check_Policy).
12146 if not Is_Configuration_Pragma then
12147 Check_Is_In_Decl_Part_Or_Package_Spec;
12150 -- Figure out if we have the old or new syntax. We have the
12151 -- old syntax if the first argument has no identifier, or the
12152 -- identifier is Name.
12154 if Nkind (Arg1) /= N_Pragma_Argument_Association
12155 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12159 Check_Arg_Count (2);
12160 Check_Optional_Identifier (Arg1, Name_Name);
12161 Kind := Get_Pragma_Arg (Arg1);
12162 Rewrite_Assertion_Kind (Kind);
12163 Check_Arg_Is_Identifier (Arg1);
12165 -- Check forbidden check kind
12167 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12168 Error_Msg_Name_2 := Chars (Kind);
12170 ("pragma% does not allow% as check name", Arg1);
12175 Check_Optional_Identifier (Arg2, Name_Policy);
12176 Check_Arg_Is_One_Of
12178 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12179 Ident := Get_Pragma_Arg (Arg2);
12181 if Chars (Kind) = Name_Ghost then
12183 -- Pragma Check_Policy specifying a Ghost policy cannot
12184 -- occur within a ghost subprogram or package.
12186 if Ghost_Mode > None then
12188 ("pragma % cannot appear within ghost subprogram or "
12191 -- The policy identifier of pragma Ghost must be either
12192 -- Check or Ignore (SPARK RM 6.9(7)).
12194 elsif not Nam_In (Chars (Ident), Name_Check,
12198 ("argument of pragma % Ghost must be Check or Ignore",
12203 -- And chain pragma on the Check_Policy_List for search
12205 Set_Next_Pragma (N, Opt.Check_Policy_List);
12206 Opt.Check_Policy_List := N;
12208 -- For the new syntax, what we do is to convert each argument to
12209 -- an old syntax equivalent. We do that because we want to chain
12210 -- old style Check_Policy pragmas for the search (we don't want
12211 -- to have to deal with multiple arguments in the search).
12221 while Present (Arg) loop
12222 LocP := Sloc (Arg);
12223 Argx := Get_Pragma_Arg (Arg);
12225 -- Kind must be specified
12227 if Nkind (Arg) /= N_Pragma_Argument_Association
12228 or else Chars (Arg) = No_Name
12231 ("missing assertion kind for pragma%", Arg);
12234 -- Construct equivalent old form syntax Check_Policy
12235 -- pragma and insert it to get remaining checks.
12239 Chars => Name_Check_Policy,
12240 Pragma_Argument_Associations => New_List (
12241 Make_Pragma_Argument_Association (LocP,
12243 Make_Identifier (LocP, Chars (Arg))),
12244 Make_Pragma_Argument_Association (Sloc (Argx),
12245 Expression => Argx))));
12250 -- Rewrite original Check_Policy pragma to null, since we
12251 -- have converted it into a series of old syntax pragmas.
12253 Rewrite (N, Make_Null_Statement (Loc));
12263 -- pragma Comment (static_string_EXPRESSION)
12265 -- Processing for pragma Comment shares the circuitry for pragma
12266 -- Ident. The only differences are that Ident enforces a limit of 31
12267 -- characters on its argument, and also enforces limitations on
12268 -- placement for DEC compatibility. Pragma Comment shares neither of
12269 -- these restrictions.
12271 -------------------
12272 -- Common_Object --
12273 -------------------
12275 -- pragma Common_Object (
12276 -- [Internal =>] LOCAL_NAME
12277 -- [, [External =>] EXTERNAL_SYMBOL]
12278 -- [, [Size =>] EXTERNAL_SYMBOL]);
12280 -- Processing for this pragma is shared with Psect_Object
12282 ------------------------
12283 -- Compile_Time_Error --
12284 ------------------------
12286 -- pragma Compile_Time_Error
12287 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12289 when Pragma_Compile_Time_Error =>
12291 Process_Compile_Time_Warning_Or_Error;
12293 --------------------------
12294 -- Compile_Time_Warning --
12295 --------------------------
12297 -- pragma Compile_Time_Warning
12298 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12300 when Pragma_Compile_Time_Warning =>
12302 Process_Compile_Time_Warning_Or_Error;
12304 ---------------------------
12305 -- Compiler_Unit_Warning --
12306 ---------------------------
12308 -- pragma Compiler_Unit_Warning;
12312 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12313 -- errors not warnings. This means that we had introduced a big extra
12314 -- inertia to compiler changes, since even if we implemented a new
12315 -- feature, and even if all versions to be used for bootstrapping
12316 -- implemented this new feature, we could not use it, since old
12317 -- compilers would give errors for using this feature in units
12318 -- having Compiler_Unit pragmas.
12320 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12321 -- problem. We no longer have any units mentioning Compiler_Unit,
12322 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12323 -- and thus generates a warning which can be ignored. So that deals
12324 -- with the problem of old compilers not implementing the newer form
12327 -- Newer compilers recognize the new pragma, but generate warning
12328 -- messages instead of errors, which again can be ignored in the
12329 -- case of an old compiler which implements a wanted new feature
12330 -- but at the time felt like warning about it for older compilers.
12332 -- We retain Compiler_Unit so that new compilers can be used to build
12333 -- older run-times that use this pragma. That's an unusual case, but
12334 -- it's easy enough to handle, so why not?
12336 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12338 Check_Arg_Count (0);
12340 -- Only recognized in main unit
12342 if Current_Sem_Unit = Main_Unit then
12343 Compiler_Unit := True;
12346 -----------------------------
12347 -- Complete_Representation --
12348 -----------------------------
12350 -- pragma Complete_Representation;
12352 when Pragma_Complete_Representation =>
12354 Check_Arg_Count (0);
12356 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12358 ("pragma & must appear within record representation clause");
12361 ----------------------------
12362 -- Complex_Representation --
12363 ----------------------------
12365 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12367 when Pragma_Complex_Representation => Complex_Representation : declare
12374 Check_Arg_Count (1);
12375 Check_Optional_Identifier (Arg1, Name_Entity);
12376 Check_Arg_Is_Local_Name (Arg1);
12377 E_Id := Get_Pragma_Arg (Arg1);
12379 if Etype (E_Id) = Any_Type then
12383 E := Entity (E_Id);
12385 if not Is_Record_Type (E) then
12387 ("argument for pragma% must be record type", Arg1);
12390 Ent := First_Entity (E);
12393 or else No (Next_Entity (Ent))
12394 or else Present (Next_Entity (Next_Entity (Ent)))
12395 or else not Is_Floating_Point_Type (Etype (Ent))
12396 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12399 ("record for pragma% must have two fields of the same "
12400 & "floating-point type", Arg1);
12403 Set_Has_Complex_Representation (Base_Type (E));
12405 -- We need to treat the type has having a non-standard
12406 -- representation, for back-end purposes, even though in
12407 -- general a complex will have the default representation
12408 -- of a record with two real components.
12410 Set_Has_Non_Standard_Rep (Base_Type (E));
12412 end Complex_Representation;
12414 -------------------------
12415 -- Component_Alignment --
12416 -------------------------
12418 -- pragma Component_Alignment (
12419 -- [Form =>] ALIGNMENT_CHOICE
12420 -- [, [Name =>] type_LOCAL_NAME]);
12422 -- ALIGNMENT_CHOICE ::=
12424 -- | Component_Size_4
12428 when Pragma_Component_Alignment => Component_AlignmentP : declare
12429 Args : Args_List (1 .. 2);
12430 Names : constant Name_List (1 .. 2) := (
12434 Form : Node_Id renames Args (1);
12435 Name : Node_Id renames Args (2);
12437 Atype : Component_Alignment_Kind;
12442 Gather_Associations (Names, Args);
12445 Error_Pragma ("missing Form argument for pragma%");
12448 Check_Arg_Is_Identifier (Form);
12450 -- Get proper alignment, note that Default = Component_Size on all
12451 -- machines we have so far, and we want to set this value rather
12452 -- than the default value to indicate that it has been explicitly
12453 -- set (and thus will not get overridden by the default component
12454 -- alignment for the current scope)
12456 if Chars (Form) = Name_Component_Size then
12457 Atype := Calign_Component_Size;
12459 elsif Chars (Form) = Name_Component_Size_4 then
12460 Atype := Calign_Component_Size_4;
12462 elsif Chars (Form) = Name_Default then
12463 Atype := Calign_Component_Size;
12465 elsif Chars (Form) = Name_Storage_Unit then
12466 Atype := Calign_Storage_Unit;
12470 ("invalid Form parameter for pragma%", Form);
12473 -- Case with no name, supplied, affects scope table entry
12477 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12479 -- Case of name supplied
12482 Check_Arg_Is_Local_Name (Name);
12484 Typ := Entity (Name);
12487 or else Rep_Item_Too_Early (Typ, N)
12491 Typ := Underlying_Type (Typ);
12494 if not Is_Record_Type (Typ)
12495 and then not Is_Array_Type (Typ)
12498 ("Name parameter of pragma% must identify record or "
12499 & "array type", Name);
12502 -- An explicit Component_Alignment pragma overrides an
12503 -- implicit pragma Pack, but not an explicit one.
12505 if not Has_Pragma_Pack (Base_Type (Typ)) then
12506 Set_Is_Packed (Base_Type (Typ), False);
12507 Set_Component_Alignment (Base_Type (Typ), Atype);
12510 end Component_AlignmentP;
12512 --------------------------------
12513 -- Constant_After_Elaboration --
12514 --------------------------------
12516 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12518 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
12520 Obj_Decl : Node_Id;
12521 Obj_Id : Entity_Id;
12525 Check_No_Identifiers;
12526 Check_At_Most_N_Arguments (1);
12528 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12530 -- Object declaration
12532 if Nkind (Obj_Decl) = N_Object_Declaration then
12535 -- Otherwise the pragma is associated with an illegal construct
12542 Obj_Id := Defining_Entity (Obj_Decl);
12544 -- The object declaration must be a library-level variable with
12545 -- an initialization expression. The expression must depend on
12546 -- a variable, parameter, or another constant_after_elaboration,
12547 -- but the compiler cannot detect this property, as this requires
12548 -- full flow analysis (SPARK RM 3.3.1).
12550 if Ekind (Obj_Id) = E_Variable then
12551 if not Is_Library_Level_Entity (Obj_Id) then
12553 ("pragma % must apply to a library level variable");
12556 elsif not Has_Init_Expression (Obj_Decl) then
12558 ("pragma % must apply to a variable with initialization "
12562 -- Otherwise the pragma applies to a constant, which is illegal
12565 Error_Pragma ("pragma % must apply to a variable declaration");
12569 -- Chain the pragma on the contract for completeness
12571 Add_Contract_Item (N, Obj_Id);
12573 -- A pragma that applies to a Ghost entity becomes Ghost for the
12574 -- purposes of legality checks and removal of ignored Ghost code.
12576 Mark_Pragma_As_Ghost (N, Obj_Id);
12578 -- Analyze the Boolean expression (if any)
12580 if Present (Arg1) then
12581 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12583 end Constant_After_Elaboration;
12585 --------------------
12586 -- Contract_Cases --
12587 --------------------
12589 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12591 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12593 -- CASE_GUARD ::= boolean_EXPRESSION | others
12595 -- CONSEQUENCE ::= boolean_EXPRESSION
12597 -- Characteristics:
12599 -- * Analysis - The annotation undergoes initial checks to verify
12600 -- the legal placement and context. Secondary checks preanalyze the
12603 -- Analyze_Contract_Cases_In_Decl_Part
12605 -- * Expansion - The annotation is expanded during the expansion of
12606 -- the related subprogram [body] contract as performed in:
12608 -- Expand_Subprogram_Contract
12610 -- * Template - The annotation utilizes the generic template of the
12611 -- related subprogram [body] when it is:
12613 -- aspect on subprogram declaration
12614 -- aspect on stand alone subprogram body
12615 -- pragma on stand alone subprogram body
12617 -- The annotation must prepare its own template when it is:
12619 -- pragma on subprogram declaration
12621 -- * Globals - Capture of global references must occur after full
12624 -- * Instance - The annotation is instantiated automatically when
12625 -- the related generic subprogram [body] is instantiated except for
12626 -- the "pragma on subprogram declaration" case. In that scenario
12627 -- the annotation must instantiate itself.
12629 when Pragma_Contract_Cases => Contract_Cases : declare
12630 Spec_Id : Entity_Id;
12631 Subp_Decl : Node_Id;
12635 Check_No_Identifiers;
12636 Check_Arg_Count (1);
12638 -- Ensure the proper placement of the pragma. Contract_Cases must
12639 -- be associated with a subprogram declaration or a body that acts
12643 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
12645 -- Generic subprogram
12647 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
12650 -- Body acts as spec
12652 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12653 and then No (Corresponding_Spec (Subp_Decl))
12657 -- Body stub acts as spec
12659 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12660 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12666 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
12674 Spec_Id := Unique_Defining_Entity (Subp_Decl);
12676 -- Chain the pragma on the contract for further processing by
12677 -- Analyze_Contract_Cases_In_Decl_Part.
12679 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12681 -- A pragma that applies to a Ghost entity becomes Ghost for the
12682 -- purposes of legality checks and removal of ignored Ghost code.
12684 Mark_Pragma_As_Ghost (N, Spec_Id);
12685 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
12687 -- Fully analyze the pragma when it appears inside an entry
12688 -- or subprogram body because it cannot benefit from forward
12691 if Nkind_In (Subp_Decl, N_Entry_Body,
12693 N_Subprogram_Body_Stub)
12695 -- The legality checks of pragma Contract_Cases are affected by
12696 -- the SPARK mode in effect and the volatility of the context.
12697 -- Analyze all pragmas in a specific order.
12699 Analyze_If_Present (Pragma_SPARK_Mode);
12700 Analyze_If_Present (Pragma_Volatile_Function);
12701 Analyze_Contract_Cases_In_Decl_Part (N);
12703 end Contract_Cases;
12709 -- pragma Controlled (first_subtype_LOCAL_NAME);
12711 when Pragma_Controlled => Controlled : declare
12715 Check_No_Identifiers;
12716 Check_Arg_Count (1);
12717 Check_Arg_Is_Local_Name (Arg1);
12718 Arg := Get_Pragma_Arg (Arg1);
12720 if not Is_Entity_Name (Arg)
12721 or else not Is_Access_Type (Entity (Arg))
12723 Error_Pragma_Arg ("pragma% requires access type", Arg1);
12725 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
12733 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12734 -- [Entity =>] LOCAL_NAME);
12736 when Pragma_Convention => Convention : declare
12739 pragma Warnings (Off, C);
12740 pragma Warnings (Off, E);
12742 Check_Arg_Order ((Name_Convention, Name_Entity));
12743 Check_Ada_83_Warning;
12744 Check_Arg_Count (2);
12745 Process_Convention (C, E);
12747 -- A pragma that applies to a Ghost entity becomes Ghost for the
12748 -- purposes of legality checks and removal of ignored Ghost code.
12750 Mark_Pragma_As_Ghost (N, E);
12753 ---------------------------
12754 -- Convention_Identifier --
12755 ---------------------------
12757 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12758 -- [Convention =>] convention_IDENTIFIER);
12760 when Pragma_Convention_Identifier => Convention_Identifier : declare
12766 Check_Arg_Order ((Name_Name, Name_Convention));
12767 Check_Arg_Count (2);
12768 Check_Optional_Identifier (Arg1, Name_Name);
12769 Check_Optional_Identifier (Arg2, Name_Convention);
12770 Check_Arg_Is_Identifier (Arg1);
12771 Check_Arg_Is_Identifier (Arg2);
12772 Idnam := Chars (Get_Pragma_Arg (Arg1));
12773 Cname := Chars (Get_Pragma_Arg (Arg2));
12775 if Is_Convention_Name (Cname) then
12776 Record_Convention_Identifier
12777 (Idnam, Get_Convention_Id (Cname));
12780 ("second arg for % pragma must be convention", Arg2);
12782 end Convention_Identifier;
12788 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12790 when Pragma_CPP_Class => CPP_Class : declare
12794 if Warn_On_Obsolescent_Feature then
12796 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12797 & "effect; replace it by pragma import?j?", N);
12800 Check_Arg_Count (1);
12804 Chars => Name_Import,
12805 Pragma_Argument_Associations => New_List (
12806 Make_Pragma_Argument_Association (Loc,
12807 Expression => Make_Identifier (Loc, Name_CPP)),
12808 New_Copy (First (Pragma_Argument_Associations (N))))));
12812 ---------------------
12813 -- CPP_Constructor --
12814 ---------------------
12816 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12817 -- [, [External_Name =>] static_string_EXPRESSION ]
12818 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12820 when Pragma_CPP_Constructor => CPP_Constructor : declare
12823 Def_Id : Entity_Id;
12824 Tag_Typ : Entity_Id;
12828 Check_At_Least_N_Arguments (1);
12829 Check_At_Most_N_Arguments (3);
12830 Check_Optional_Identifier (Arg1, Name_Entity);
12831 Check_Arg_Is_Local_Name (Arg1);
12833 Id := Get_Pragma_Arg (Arg1);
12834 Find_Program_Unit_Name (Id);
12836 -- If we did not find the name, we are done
12838 if Etype (Id) = Any_Type then
12842 Def_Id := Entity (Id);
12844 -- Check if already defined as constructor
12846 if Is_Constructor (Def_Id) then
12848 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
12852 if Ekind (Def_Id) = E_Function
12853 and then (Is_CPP_Class (Etype (Def_Id))
12854 or else (Is_Class_Wide_Type (Etype (Def_Id))
12856 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
12858 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
12860 ("'C'P'P constructor must be defined in the scope of "
12861 & "its returned type", Arg1);
12864 if Arg_Count >= 2 then
12865 Set_Imported (Def_Id);
12866 Set_Is_Public (Def_Id);
12867 Process_Interface_Name (Def_Id, Arg2, Arg3);
12870 Set_Has_Completion (Def_Id);
12871 Set_Is_Constructor (Def_Id);
12872 Set_Convention (Def_Id, Convention_CPP);
12874 -- Imported C++ constructors are not dispatching primitives
12875 -- because in C++ they don't have a dispatch table slot.
12876 -- However, in Ada the constructor has the profile of a
12877 -- function that returns a tagged type and therefore it has
12878 -- been treated as a primitive operation during semantic
12879 -- analysis. We now remove it from the list of primitive
12880 -- operations of the type.
12882 if Is_Tagged_Type (Etype (Def_Id))
12883 and then not Is_Class_Wide_Type (Etype (Def_Id))
12884 and then Is_Dispatching_Operation (Def_Id)
12886 Tag_Typ := Etype (Def_Id);
12888 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
12889 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
12893 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
12894 Set_Is_Dispatching_Operation (Def_Id, False);
12897 -- For backward compatibility, if the constructor returns a
12898 -- class wide type, and we internally change the return type to
12899 -- the corresponding root type.
12901 if Is_Class_Wide_Type (Etype (Def_Id)) then
12902 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
12906 ("pragma% requires function returning a 'C'P'P_Class type",
12909 end CPP_Constructor;
12915 when Pragma_CPP_Virtual => CPP_Virtual : declare
12919 if Warn_On_Obsolescent_Feature then
12921 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12930 when Pragma_CPP_Vtable => CPP_Vtable : declare
12934 if Warn_On_Obsolescent_Feature then
12936 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12945 -- pragma CPU (EXPRESSION);
12947 when Pragma_CPU => CPU : declare
12948 P : constant Node_Id := Parent (N);
12954 Check_No_Identifiers;
12955 Check_Arg_Count (1);
12959 if Nkind (P) = N_Subprogram_Body then
12960 Check_In_Main_Program;
12962 Arg := Get_Pragma_Arg (Arg1);
12963 Analyze_And_Resolve (Arg, Any_Integer);
12965 Ent := Defining_Unit_Name (Specification (P));
12967 if Nkind (Ent) = N_Defining_Program_Unit_Name then
12968 Ent := Defining_Identifier (Ent);
12973 if not Is_OK_Static_Expression (Arg) then
12974 Flag_Non_Static_Expr
12975 ("main subprogram affinity is not static!", Arg);
12978 -- If constraint error, then we already signalled an error
12980 elsif Raises_Constraint_Error (Arg) then
12983 -- Otherwise check in range
12987 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
12988 -- This is the entity System.Multiprocessors.CPU_Range;
12990 Val : constant Uint := Expr_Value (Arg);
12993 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
12995 Val > Expr_Value (Type_High_Bound (CPU_Id))
12998 ("main subprogram CPU is out of range", Arg1);
13004 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13008 elsif Nkind (P) = N_Task_Definition then
13009 Arg := Get_Pragma_Arg (Arg1);
13010 Ent := Defining_Identifier (Parent (P));
13012 -- The expression must be analyzed in the special manner
13013 -- described in "Handling of Default and Per-Object
13014 -- Expressions" in sem.ads.
13016 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13018 -- Anything else is incorrect
13024 -- Check duplicate pragma before we chain the pragma in the Rep
13025 -- Item chain of Ent.
13027 Check_Duplicate_Pragma (Ent);
13028 Record_Rep_Item (Ent, N);
13035 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13037 when Pragma_Debug => Debug : declare
13044 -- The condition for executing the call is that the expander
13045 -- is active and that we are not ignoring this debug pragma.
13050 (Expander_Active and then not Is_Ignored (N)),
13053 if not Is_Ignored (N) then
13054 Set_SCO_Pragma_Enabled (Loc);
13057 if Arg_Count = 2 then
13059 Make_And_Then (Loc,
13060 Left_Opnd => Relocate_Node (Cond),
13061 Right_Opnd => Get_Pragma_Arg (Arg1));
13062 Call := Get_Pragma_Arg (Arg2);
13064 Call := Get_Pragma_Arg (Arg1);
13068 N_Indexed_Component,
13072 N_Selected_Component)
13074 -- If this pragma Debug comes from source, its argument was
13075 -- parsed as a name form (which is syntactically identical).
13076 -- In a generic context a parameterless call will be left as
13077 -- an expanded name (if global) or selected_component if local.
13078 -- Change it to a procedure call statement now.
13080 Change_Name_To_Procedure_Call_Statement (Call);
13082 elsif Nkind (Call) = N_Procedure_Call_Statement then
13084 -- Already in the form of a procedure call statement: nothing
13085 -- to do (could happen in case of an internally generated
13091 -- All other cases: diagnose error
13094 ("argument of pragma ""Debug"" is not procedure call",
13099 -- Rewrite into a conditional with an appropriate condition. We
13100 -- wrap the procedure call in a block so that overhead from e.g.
13101 -- use of the secondary stack does not generate execution overhead
13102 -- for suppressed conditions.
13104 -- Normally the analysis that follows will freeze the subprogram
13105 -- being called. However, if the call is to a null procedure,
13106 -- we want to freeze it before creating the block, because the
13107 -- analysis that follows may be done with expansion disabled, in
13108 -- which case the body will not be generated, leading to spurious
13111 if Nkind (Call) = N_Procedure_Call_Statement
13112 and then Is_Entity_Name (Name (Call))
13114 Analyze (Name (Call));
13115 Freeze_Before (N, Entity (Name (Call)));
13119 Make_Implicit_If_Statement (N,
13121 Then_Statements => New_List (
13122 Make_Block_Statement (Loc,
13123 Handled_Statement_Sequence =>
13124 Make_Handled_Sequence_Of_Statements (Loc,
13125 Statements => New_List (Relocate_Node (Call)))))));
13128 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13129 -- after analysis of the normally rewritten node, to capture all
13130 -- references to entities, which avoids issuing wrong warnings
13131 -- about unused entities.
13133 if GNATprove_Mode then
13134 Rewrite (N, Make_Null_Statement (Loc));
13142 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13144 when Pragma_Debug_Policy =>
13146 Check_Arg_Count (1);
13147 Check_No_Identifiers;
13148 Check_Arg_Is_Identifier (Arg1);
13150 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13151 -- rewrite it that way, and let the rest of the checking come
13152 -- from analyzing the rewritten pragma.
13156 Chars => Name_Check_Policy,
13157 Pragma_Argument_Associations => New_List (
13158 Make_Pragma_Argument_Association (Loc,
13159 Expression => Make_Identifier (Loc, Name_Debug)),
13161 Make_Pragma_Argument_Association (Loc,
13162 Expression => Get_Pragma_Arg (Arg1)))));
13165 -------------------------------
13166 -- Default_Initial_Condition --
13167 -------------------------------
13169 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13171 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13178 Check_No_Identifiers;
13179 Check_At_Most_N_Arguments (1);
13182 while Present (Stmt) loop
13184 -- Skip prior pragmas, but check for duplicates
13186 if Nkind (Stmt) = N_Pragma then
13187 if Pragma_Name (Stmt) = Pname then
13188 Error_Msg_Name_1 := Pname;
13189 Error_Msg_Sloc := Sloc (Stmt);
13190 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13193 -- Skip internally generated code
13195 elsif not Comes_From_Source (Stmt) then
13198 -- The associated private type [extension] has been found, stop
13201 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13202 N_Private_Type_Declaration)
13204 Typ := Defining_Entity (Stmt);
13207 -- The pragma does not apply to a legal construct, issue an
13208 -- error and stop the analysis.
13215 Stmt := Prev (Stmt);
13218 -- A pragma that applies to a Ghost entity becomes Ghost for the
13219 -- purposes of legality checks and removal of ignored Ghost code.
13221 Mark_Pragma_As_Ghost (N, Typ);
13222 Set_Has_Default_Init_Cond (Typ);
13223 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13225 -- Chain the pragma on the rep item chain for further processing
13227 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13228 end Default_Init_Cond;
13230 ----------------------------------
13231 -- Default_Scalar_Storage_Order --
13232 ----------------------------------
13234 -- pragma Default_Scalar_Storage_Order
13235 -- (High_Order_First | Low_Order_First);
13237 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13238 Default : Character;
13242 Check_Arg_Count (1);
13244 -- Default_Scalar_Storage_Order can appear as a configuration
13245 -- pragma, or in a declarative part of a package spec.
13247 if not Is_Configuration_Pragma then
13248 Check_Is_In_Decl_Part_Or_Package_Spec;
13251 Check_No_Identifiers;
13252 Check_Arg_Is_One_Of
13253 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13254 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13255 Default := Fold_Upper (Name_Buffer (1));
13257 if not Support_Nondefault_SSO_On_Target
13258 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13260 if Warn_On_Unrecognized_Pragma then
13262 ("non-default Scalar_Storage_Order not supported "
13263 & "on target?g?", N);
13265 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13268 -- Here set the specified default
13271 Opt.Default_SSO := Default;
13275 --------------------------
13276 -- Default_Storage_Pool --
13277 --------------------------
13279 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13281 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13286 Check_Arg_Count (1);
13288 -- Default_Storage_Pool can appear as a configuration pragma, or
13289 -- in a declarative part of a package spec.
13291 if not Is_Configuration_Pragma then
13292 Check_Is_In_Decl_Part_Or_Package_Spec;
13295 if Present (Arg1) then
13296 Pool := Get_Pragma_Arg (Arg1);
13298 -- Case of Default_Storage_Pool (null);
13300 if Nkind (Pool) = N_Null then
13303 -- This is an odd case, this is not really an expression,
13304 -- so we don't have a type for it. So just set the type to
13307 Set_Etype (Pool, Empty);
13309 -- Case of Default_Storage_Pool (storage_pool_NAME);
13312 -- If it's a configuration pragma, then the only allowed
13313 -- argument is "null".
13315 if Is_Configuration_Pragma then
13316 Error_Pragma_Arg ("NULL expected", Arg1);
13319 -- The expected type for a non-"null" argument is
13320 -- Root_Storage_Pool'Class, and the pool must be a variable.
13322 Analyze_And_Resolve
13323 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13325 if Is_Variable (Pool) then
13327 -- A pragma that applies to a Ghost entity becomes Ghost
13328 -- for the purposes of legality checks and removal of
13329 -- ignored Ghost code.
13331 Mark_Pragma_As_Ghost (N, Entity (Pool));
13335 ("default storage pool must be a variable", Arg1);
13339 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13340 -- access type will use this information to set the appropriate
13341 -- attributes of the access type.
13343 Default_Pool := Pool;
13345 end Default_Storage_Pool;
13351 -- pragma Depends (DEPENDENCY_RELATION);
13353 -- DEPENDENCY_RELATION ::=
13355 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13357 -- DEPENDENCY_CLAUSE ::=
13358 -- OUTPUT_LIST =>[+] INPUT_LIST
13359 -- | NULL_DEPENDENCY_CLAUSE
13361 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13363 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13365 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13367 -- OUTPUT ::= NAME | FUNCTION_RESULT
13370 -- where FUNCTION_RESULT is a function Result attribute_reference
13372 -- Characteristics:
13374 -- * Analysis - The annotation undergoes initial checks to verify
13375 -- the legal placement and context. Secondary checks fully analyze
13376 -- the dependency clauses in:
13378 -- Analyze_Depends_In_Decl_Part
13380 -- * Expansion - None.
13382 -- * Template - The annotation utilizes the generic template of the
13383 -- related subprogram [body] when it is:
13385 -- aspect on subprogram declaration
13386 -- aspect on stand alone subprogram body
13387 -- pragma on stand alone subprogram body
13389 -- The annotation must prepare its own template when it is:
13391 -- pragma on subprogram declaration
13393 -- * Globals - Capture of global references must occur after full
13396 -- * Instance - The annotation is instantiated automatically when
13397 -- the related generic subprogram [body] is instantiated except for
13398 -- the "pragma on subprogram declaration" case. In that scenario
13399 -- the annotation must instantiate itself.
13401 when Pragma_Depends => Depends : declare
13403 Spec_Id : Entity_Id;
13404 Subp_Decl : Node_Id;
13407 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
13411 -- Chain the pragma on the contract for further processing by
13412 -- Analyze_Depends_In_Decl_Part.
13414 Add_Contract_Item (N, Spec_Id);
13416 -- Fully analyze the pragma when it appears inside an entry
13417 -- or subprogram body because it cannot benefit from forward
13420 if Nkind_In (Subp_Decl, N_Entry_Body,
13422 N_Subprogram_Body_Stub)
13424 -- The legality checks of pragmas Depends and Global are
13425 -- affected by the SPARK mode in effect and the volatility
13426 -- of the context. In addition these two pragmas are subject
13427 -- to an inherent order:
13432 -- Analyze all these pragmas in the order outlined above
13434 Analyze_If_Present (Pragma_SPARK_Mode);
13435 Analyze_If_Present (Pragma_Volatile_Function);
13436 Analyze_If_Present (Pragma_Global);
13437 Analyze_Depends_In_Decl_Part (N);
13442 ---------------------
13443 -- Detect_Blocking --
13444 ---------------------
13446 -- pragma Detect_Blocking;
13448 when Pragma_Detect_Blocking =>
13450 Check_Arg_Count (0);
13451 Check_Valid_Configuration_Pragma;
13452 Detect_Blocking := True;
13454 ------------------------------------
13455 -- Disable_Atomic_Synchronization --
13456 ------------------------------------
13458 -- pragma Disable_Atomic_Synchronization [(Entity)];
13460 when Pragma_Disable_Atomic_Synchronization =>
13462 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13464 -------------------
13465 -- Discard_Names --
13466 -------------------
13468 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13470 when Pragma_Discard_Names => Discard_Names : declare
13475 Check_Ada_83_Warning;
13477 -- Deal with configuration pragma case
13479 if Arg_Count = 0 and then Is_Configuration_Pragma then
13480 Global_Discard_Names := True;
13483 -- Otherwise, check correct appropriate context
13486 Check_Is_In_Decl_Part_Or_Package_Spec;
13488 if Arg_Count = 0 then
13490 -- If there is no parameter, then from now on this pragma
13491 -- applies to any enumeration, exception or tagged type
13492 -- defined in the current declarative part, and recursively
13493 -- to any nested scope.
13495 Set_Discard_Names (Current_Scope);
13499 Check_Arg_Count (1);
13500 Check_Optional_Identifier (Arg1, Name_On);
13501 Check_Arg_Is_Local_Name (Arg1);
13503 E_Id := Get_Pragma_Arg (Arg1);
13505 if Etype (E_Id) = Any_Type then
13508 E := Entity (E_Id);
13511 -- A pragma that applies to a Ghost entity becomes Ghost for
13512 -- the purposes of legality checks and removal of ignored
13515 Mark_Pragma_As_Ghost (N, E);
13517 if (Is_First_Subtype (E)
13519 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13520 or else Ekind (E) = E_Exception
13522 Set_Discard_Names (E);
13523 Record_Rep_Item (E, N);
13527 ("inappropriate entity for pragma%", Arg1);
13533 ------------------------
13534 -- Dispatching_Domain --
13535 ------------------------
13537 -- pragma Dispatching_Domain (EXPRESSION);
13539 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13540 P : constant Node_Id := Parent (N);
13546 Check_No_Identifiers;
13547 Check_Arg_Count (1);
13549 -- This pragma is born obsolete, but not the aspect
13551 if not From_Aspect_Specification (N) then
13553 (No_Obsolescent_Features, Pragma_Identifier (N));
13556 if Nkind (P) = N_Task_Definition then
13557 Arg := Get_Pragma_Arg (Arg1);
13558 Ent := Defining_Identifier (Parent (P));
13560 -- A pragma that applies to a Ghost entity becomes Ghost for
13561 -- the purposes of legality checks and removal of ignored Ghost
13564 Mark_Pragma_As_Ghost (N, Ent);
13566 -- The expression must be analyzed in the special manner
13567 -- described in "Handling of Default and Per-Object
13568 -- Expressions" in sem.ads.
13570 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13572 -- Check duplicate pragma before we chain the pragma in the Rep
13573 -- Item chain of Ent.
13575 Check_Duplicate_Pragma (Ent);
13576 Record_Rep_Item (Ent, N);
13578 -- Anything else is incorrect
13583 end Dispatching_Domain;
13589 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13591 when Pragma_Elaborate => Elaborate : declare
13596 -- Pragma must be in context items list of a compilation unit
13598 if not Is_In_Context_Clause then
13602 -- Must be at least one argument
13604 if Arg_Count = 0 then
13605 Error_Pragma ("pragma% requires at least one argument");
13608 -- In Ada 83 mode, there can be no items following it in the
13609 -- context list except other pragmas and implicit with clauses
13610 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13611 -- placement rule does not apply.
13613 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13615 while Present (Citem) loop
13616 if Nkind (Citem) = N_Pragma
13617 or else (Nkind (Citem) = N_With_Clause
13618 and then Implicit_With (Citem))
13623 ("(Ada 83) pragma% must be at end of context clause");
13630 -- Finally, the arguments must all be units mentioned in a with
13631 -- clause in the same context clause. Note we already checked (in
13632 -- Par.Prag) that the arguments are all identifiers or selected
13636 Outer : while Present (Arg) loop
13637 Citem := First (List_Containing (N));
13638 Inner : while Citem /= N loop
13639 if Nkind (Citem) = N_With_Clause
13640 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13642 Set_Elaborate_Present (Citem, True);
13643 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13645 -- With the pragma present, elaboration calls on
13646 -- subprograms from the named unit need no further
13647 -- checks, as long as the pragma appears in the current
13648 -- compilation unit. If the pragma appears in some unit
13649 -- in the context, there might still be a need for an
13650 -- Elaborate_All_Desirable from the current compilation
13651 -- to the named unit, so we keep the check enabled.
13653 if In_Extended_Main_Source_Unit (N) then
13655 -- This does not apply in SPARK mode, where we allow
13656 -- pragma Elaborate, but we don't trust it to be right
13657 -- so we will still insist on the Elaborate_All.
13659 if SPARK_Mode /= On then
13660 Set_Suppress_Elaboration_Warnings
13661 (Entity (Name (Citem)));
13673 ("argument of pragma% is not withed unit", Arg);
13679 -- Give a warning if operating in static mode with one of the
13680 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13683 and not Dynamic_Elaboration_Checks
13685 -- pragma Elaborate not allowed in SPARK mode anyway. We
13686 -- already complained about it, no point in generating any
13687 -- further complaint.
13689 and SPARK_Mode /= On
13692 ("?l?use of pragma Elaborate may not be safe", N);
13694 ("?l?use pragma Elaborate_All instead if possible", N);
13698 -------------------
13699 -- Elaborate_All --
13700 -------------------
13702 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13704 when Pragma_Elaborate_All => Elaborate_All : declare
13709 Check_Ada_83_Warning;
13711 -- Pragma must be in context items list of a compilation unit
13713 if not Is_In_Context_Clause then
13717 -- Must be at least one argument
13719 if Arg_Count = 0 then
13720 Error_Pragma ("pragma% requires at least one argument");
13723 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13724 -- have to appear at the end of the context clause, but may
13725 -- appear mixed in with other items, even in Ada 83 mode.
13727 -- Final check: the arguments must all be units mentioned in
13728 -- a with clause in the same context clause. Note that we
13729 -- already checked (in Par.Prag) that all the arguments are
13730 -- either identifiers or selected components.
13733 Outr : while Present (Arg) loop
13734 Citem := First (List_Containing (N));
13735 Innr : while Citem /= N loop
13736 if Nkind (Citem) = N_With_Clause
13737 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13739 Set_Elaborate_All_Present (Citem, True);
13740 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13742 -- Suppress warnings and elaboration checks on the named
13743 -- unit if the pragma is in the current compilation, as
13744 -- for pragma Elaborate.
13746 if In_Extended_Main_Source_Unit (N) then
13747 Set_Suppress_Elaboration_Warnings
13748 (Entity (Name (Citem)));
13757 Set_Error_Posted (N);
13759 ("argument of pragma% is not withed unit", Arg);
13766 --------------------
13767 -- Elaborate_Body --
13768 --------------------
13770 -- pragma Elaborate_Body [( library_unit_NAME )];
13772 when Pragma_Elaborate_Body => Elaborate_Body : declare
13773 Cunit_Node : Node_Id;
13774 Cunit_Ent : Entity_Id;
13777 Check_Ada_83_Warning;
13778 Check_Valid_Library_Unit_Pragma;
13780 if Nkind (N) = N_Null_Statement then
13784 Cunit_Node := Cunit (Current_Sem_Unit);
13785 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
13787 -- A pragma that applies to a Ghost entity becomes Ghost for the
13788 -- purposes of legality checks and removal of ignored Ghost code.
13790 Mark_Pragma_As_Ghost (N, Cunit_Ent);
13792 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
13795 Error_Pragma ("pragma% must refer to a spec, not a body");
13797 Set_Body_Required (Cunit_Node, True);
13798 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
13800 -- If we are in dynamic elaboration mode, then we suppress
13801 -- elaboration warnings for the unit, since it is definitely
13802 -- fine NOT to do dynamic checks at the first level (and such
13803 -- checks will be suppressed because no elaboration boolean
13804 -- is created for Elaborate_Body packages).
13806 -- But in the static model of elaboration, Elaborate_Body is
13807 -- definitely NOT good enough to ensure elaboration safety on
13808 -- its own, since the body may WITH other units that are not
13809 -- safe from an elaboration point of view, so a client must
13810 -- still do an Elaborate_All on such units.
13812 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13813 -- Elaborate_Body always suppressed elab warnings.
13815 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
13816 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
13819 end Elaborate_Body;
13821 ------------------------
13822 -- Elaboration_Checks --
13823 ------------------------
13825 -- pragma Elaboration_Checks (Static | Dynamic);
13827 when Pragma_Elaboration_Checks =>
13829 Check_Arg_Count (1);
13830 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
13832 -- Set flag accordingly (ignore attempt at dynamic elaboration
13833 -- checks in SPARK mode).
13835 Dynamic_Elaboration_Checks :=
13836 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
13837 and then SPARK_Mode /= On;
13843 -- pragma Eliminate (
13844 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13845 -- [,[Entity =>] IDENTIFIER |
13846 -- SELECTED_COMPONENT |
13848 -- [, OVERLOADING_RESOLUTION]);
13850 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13853 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13854 -- FUNCTION_PROFILE
13856 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13858 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13859 -- Result_Type => result_SUBTYPE_NAME]
13861 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13862 -- SUBTYPE_NAME ::= STRING_LITERAL
13864 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13865 -- SOURCE_TRACE ::= STRING_LITERAL
13867 when Pragma_Eliminate => Eliminate : declare
13868 Args : Args_List (1 .. 5);
13869 Names : constant Name_List (1 .. 5) := (
13872 Name_Parameter_Types,
13874 Name_Source_Location);
13876 Unit_Name : Node_Id renames Args (1);
13877 Entity : Node_Id renames Args (2);
13878 Parameter_Types : Node_Id renames Args (3);
13879 Result_Type : Node_Id renames Args (4);
13880 Source_Location : Node_Id renames Args (5);
13884 Check_Valid_Configuration_Pragma;
13885 Gather_Associations (Names, Args);
13887 if No (Unit_Name) then
13888 Error_Pragma ("missing Unit_Name argument for pragma%");
13892 and then (Present (Parameter_Types)
13894 Present (Result_Type)
13896 Present (Source_Location))
13898 Error_Pragma ("missing Entity argument for pragma%");
13901 if (Present (Parameter_Types)
13903 Present (Result_Type))
13905 Present (Source_Location)
13908 ("parameter profile and source location cannot be used "
13909 & "together in pragma%");
13912 Process_Eliminate_Pragma
13921 -----------------------------------
13922 -- Enable_Atomic_Synchronization --
13923 -----------------------------------
13925 -- pragma Enable_Atomic_Synchronization [(Entity)];
13927 when Pragma_Enable_Atomic_Synchronization =>
13929 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
13936 -- [ Convention =>] convention_IDENTIFIER,
13937 -- [ Entity =>] LOCAL_NAME
13938 -- [, [External_Name =>] static_string_EXPRESSION ]
13939 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13941 when Pragma_Export => Export : declare
13943 Def_Id : Entity_Id;
13945 pragma Warnings (Off, C);
13948 Check_Ada_83_Warning;
13952 Name_External_Name,
13955 Check_At_Least_N_Arguments (2);
13956 Check_At_Most_N_Arguments (4);
13958 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13959 -- pragma Export (Entity, "external name");
13961 if Relaxed_RM_Semantics
13962 and then Arg_Count = 2
13963 and then Nkind (Expression (Arg2)) = N_String_Literal
13966 Def_Id := Get_Pragma_Arg (Arg1);
13969 if not Is_Entity_Name (Def_Id) then
13970 Error_Pragma_Arg ("entity name required", Arg1);
13973 Def_Id := Entity (Def_Id);
13974 Set_Exported (Def_Id, Arg1);
13977 Process_Convention (C, Def_Id);
13979 -- A pragma that applies to a Ghost entity becomes Ghost for
13980 -- the purposes of legality checks and removal of ignored Ghost
13983 Mark_Pragma_As_Ghost (N, Def_Id);
13985 if Ekind (Def_Id) /= E_Constant then
13986 Note_Possible_Modification
13987 (Get_Pragma_Arg (Arg2), Sure => False);
13990 Process_Interface_Name (Def_Id, Arg3, Arg4);
13991 Set_Exported (Def_Id, Arg2);
13994 -- If the entity is a deferred constant, propagate the information
13995 -- to the full view, because gigi elaborates the full view only.
13997 if Ekind (Def_Id) = E_Constant
13998 and then Present (Full_View (Def_Id))
14001 Id2 : constant Entity_Id := Full_View (Def_Id);
14003 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14004 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14005 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14010 ---------------------
14011 -- Export_Function --
14012 ---------------------
14014 -- pragma Export_Function (
14015 -- [Internal =>] LOCAL_NAME
14016 -- [, [External =>] EXTERNAL_SYMBOL]
14017 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14018 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14019 -- [, [Mechanism =>] MECHANISM]
14020 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14022 -- EXTERNAL_SYMBOL ::=
14024 -- | static_string_EXPRESSION
14026 -- PARAMETER_TYPES ::=
14028 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14030 -- TYPE_DESIGNATOR ::=
14032 -- | subtype_Name ' Access
14036 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14038 -- MECHANISM_ASSOCIATION ::=
14039 -- [formal_parameter_NAME =>] MECHANISM_NAME
14041 -- MECHANISM_NAME ::=
14045 when Pragma_Export_Function => Export_Function : declare
14046 Args : Args_List (1 .. 6);
14047 Names : constant Name_List (1 .. 6) := (
14050 Name_Parameter_Types,
14053 Name_Result_Mechanism);
14055 Internal : Node_Id renames Args (1);
14056 External : Node_Id renames Args (2);
14057 Parameter_Types : Node_Id renames Args (3);
14058 Result_Type : Node_Id renames Args (4);
14059 Mechanism : Node_Id renames Args (5);
14060 Result_Mechanism : Node_Id renames Args (6);
14064 Gather_Associations (Names, Args);
14065 Process_Extended_Import_Export_Subprogram_Pragma (
14066 Arg_Internal => Internal,
14067 Arg_External => External,
14068 Arg_Parameter_Types => Parameter_Types,
14069 Arg_Result_Type => Result_Type,
14070 Arg_Mechanism => Mechanism,
14071 Arg_Result_Mechanism => Result_Mechanism);
14072 end Export_Function;
14074 -------------------
14075 -- Export_Object --
14076 -------------------
14078 -- pragma Export_Object (
14079 -- [Internal =>] LOCAL_NAME
14080 -- [, [External =>] EXTERNAL_SYMBOL]
14081 -- [, [Size =>] EXTERNAL_SYMBOL]);
14083 -- EXTERNAL_SYMBOL ::=
14085 -- | static_string_EXPRESSION
14087 -- PARAMETER_TYPES ::=
14089 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14091 -- TYPE_DESIGNATOR ::=
14093 -- | subtype_Name ' Access
14097 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14099 -- MECHANISM_ASSOCIATION ::=
14100 -- [formal_parameter_NAME =>] MECHANISM_NAME
14102 -- MECHANISM_NAME ::=
14106 when Pragma_Export_Object => Export_Object : declare
14107 Args : Args_List (1 .. 3);
14108 Names : constant Name_List (1 .. 3) := (
14113 Internal : Node_Id renames Args (1);
14114 External : Node_Id renames Args (2);
14115 Size : Node_Id renames Args (3);
14119 Gather_Associations (Names, Args);
14120 Process_Extended_Import_Export_Object_Pragma (
14121 Arg_Internal => Internal,
14122 Arg_External => External,
14126 ----------------------
14127 -- Export_Procedure --
14128 ----------------------
14130 -- pragma Export_Procedure (
14131 -- [Internal =>] LOCAL_NAME
14132 -- [, [External =>] EXTERNAL_SYMBOL]
14133 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14134 -- [, [Mechanism =>] MECHANISM]);
14136 -- EXTERNAL_SYMBOL ::=
14138 -- | static_string_EXPRESSION
14140 -- PARAMETER_TYPES ::=
14142 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14144 -- TYPE_DESIGNATOR ::=
14146 -- | subtype_Name ' Access
14150 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14152 -- MECHANISM_ASSOCIATION ::=
14153 -- [formal_parameter_NAME =>] MECHANISM_NAME
14155 -- MECHANISM_NAME ::=
14159 when Pragma_Export_Procedure => Export_Procedure : declare
14160 Args : Args_List (1 .. 4);
14161 Names : constant Name_List (1 .. 4) := (
14164 Name_Parameter_Types,
14167 Internal : Node_Id renames Args (1);
14168 External : Node_Id renames Args (2);
14169 Parameter_Types : Node_Id renames Args (3);
14170 Mechanism : Node_Id renames Args (4);
14174 Gather_Associations (Names, Args);
14175 Process_Extended_Import_Export_Subprogram_Pragma (
14176 Arg_Internal => Internal,
14177 Arg_External => External,
14178 Arg_Parameter_Types => Parameter_Types,
14179 Arg_Mechanism => Mechanism);
14180 end Export_Procedure;
14186 -- pragma Export_Value (
14187 -- [Value =>] static_integer_EXPRESSION,
14188 -- [Link_Name =>] static_string_EXPRESSION);
14190 when Pragma_Export_Value =>
14192 Check_Arg_Order ((Name_Value, Name_Link_Name));
14193 Check_Arg_Count (2);
14195 Check_Optional_Identifier (Arg1, Name_Value);
14196 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14198 Check_Optional_Identifier (Arg2, Name_Link_Name);
14199 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14201 -----------------------------
14202 -- Export_Valued_Procedure --
14203 -----------------------------
14205 -- pragma Export_Valued_Procedure (
14206 -- [Internal =>] LOCAL_NAME
14207 -- [, [External =>] EXTERNAL_SYMBOL,]
14208 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14209 -- [, [Mechanism =>] MECHANISM]);
14211 -- EXTERNAL_SYMBOL ::=
14213 -- | static_string_EXPRESSION
14215 -- PARAMETER_TYPES ::=
14217 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14219 -- TYPE_DESIGNATOR ::=
14221 -- | subtype_Name ' Access
14225 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14227 -- MECHANISM_ASSOCIATION ::=
14228 -- [formal_parameter_NAME =>] MECHANISM_NAME
14230 -- MECHANISM_NAME ::=
14234 when Pragma_Export_Valued_Procedure =>
14235 Export_Valued_Procedure : declare
14236 Args : Args_List (1 .. 4);
14237 Names : constant Name_List (1 .. 4) := (
14240 Name_Parameter_Types,
14243 Internal : Node_Id renames Args (1);
14244 External : Node_Id renames Args (2);
14245 Parameter_Types : Node_Id renames Args (3);
14246 Mechanism : Node_Id renames Args (4);
14250 Gather_Associations (Names, Args);
14251 Process_Extended_Import_Export_Subprogram_Pragma (
14252 Arg_Internal => Internal,
14253 Arg_External => External,
14254 Arg_Parameter_Types => Parameter_Types,
14255 Arg_Mechanism => Mechanism);
14256 end Export_Valued_Procedure;
14258 -------------------
14259 -- Extend_System --
14260 -------------------
14262 -- pragma Extend_System ([Name =>] Identifier);
14264 when Pragma_Extend_System => Extend_System : declare
14267 Check_Valid_Configuration_Pragma;
14268 Check_Arg_Count (1);
14269 Check_Optional_Identifier (Arg1, Name_Name);
14270 Check_Arg_Is_Identifier (Arg1);
14272 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14275 and then Name_Buffer (1 .. 4) = "aux_"
14277 if Present (System_Extend_Pragma_Arg) then
14278 if Chars (Get_Pragma_Arg (Arg1)) =
14279 Chars (Expression (System_Extend_Pragma_Arg))
14283 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14284 Error_Pragma ("pragma% conflicts with that #");
14288 System_Extend_Pragma_Arg := Arg1;
14290 if not GNAT_Mode then
14291 System_Extend_Unit := Arg1;
14295 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14299 ------------------------
14300 -- Extensions_Allowed --
14301 ------------------------
14303 -- pragma Extensions_Allowed (ON | OFF);
14305 when Pragma_Extensions_Allowed =>
14307 Check_Arg_Count (1);
14308 Check_No_Identifiers;
14309 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14311 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14312 Extensions_Allowed := True;
14313 Ada_Version := Ada_Version_Type'Last;
14316 Extensions_Allowed := False;
14317 Ada_Version := Ada_Version_Explicit;
14318 Ada_Version_Pragma := Empty;
14321 ------------------------
14322 -- Extensions_Visible --
14323 ------------------------
14325 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14327 -- Characteristics:
14329 -- * Analysis - The annotation is fully analyzed immediately upon
14330 -- elaboration as its expression must be static.
14332 -- * Expansion - None.
14334 -- * Template - The annotation utilizes the generic template of the
14335 -- related subprogram [body] when it is:
14337 -- aspect on subprogram declaration
14338 -- aspect on stand alone subprogram body
14339 -- pragma on stand alone subprogram body
14341 -- The annotation must prepare its own template when it is:
14343 -- pragma on subprogram declaration
14345 -- * Globals - Capture of global references must occur after full
14348 -- * Instance - The annotation is instantiated automatically when
14349 -- the related generic subprogram [body] is instantiated except for
14350 -- the "pragma on subprogram declaration" case. In that scenario
14351 -- the annotation must instantiate itself.
14353 when Pragma_Extensions_Visible => Extensions_Visible : declare
14354 Formal : Entity_Id;
14355 Has_OK_Formal : Boolean := False;
14356 Spec_Id : Entity_Id;
14357 Subp_Decl : Node_Id;
14361 Check_No_Identifiers;
14362 Check_At_Most_N_Arguments (1);
14365 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14367 -- Abstract subprogram declaration
14369 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
14372 -- Generic subprogram declaration
14374 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14377 -- Body acts as spec
14379 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14380 and then No (Corresponding_Spec (Subp_Decl))
14384 -- Body stub acts as spec
14386 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14387 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14391 -- Subprogram declaration
14393 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14396 -- Otherwise the pragma is associated with an illegal construct
14399 Error_Pragma ("pragma % must apply to a subprogram");
14403 -- Chain the pragma on the contract for completeness
14405 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14407 -- The legality checks of pragma Extension_Visible are affected
14408 -- by the SPARK mode in effect. Analyze all pragmas in specific
14411 Analyze_If_Present (Pragma_SPARK_Mode);
14413 -- Mark the pragma as Ghost if the related subprogram is also
14414 -- Ghost. This also ensures that any expansion performed further
14415 -- below will produce Ghost nodes.
14417 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14418 Mark_Pragma_As_Ghost (N, Spec_Id);
14420 -- Examine the formals of the related subprogram
14422 Formal := First_Formal (Spec_Id);
14423 while Present (Formal) loop
14425 -- At least one of the formals is of a specific tagged type,
14426 -- the pragma is legal.
14428 if Is_Specific_Tagged_Type (Etype (Formal)) then
14429 Has_OK_Formal := True;
14432 -- A generic subprogram with at least one formal of a private
14433 -- type ensures the legality of the pragma because the actual
14434 -- may be specifically tagged. Note that this is verified by
14435 -- the check above at instantiation time.
14437 elsif Is_Private_Type (Etype (Formal))
14438 and then Is_Generic_Type (Etype (Formal))
14440 Has_OK_Formal := True;
14444 Next_Formal (Formal);
14447 if not Has_OK_Formal then
14448 Error_Msg_Name_1 := Pname;
14449 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
14451 ("\subprogram & lacks parameter of specific tagged or "
14452 & "generic private type", N, Spec_Id);
14457 -- Analyze the Boolean expression (if any)
14459 if Present (Arg1) then
14460 Check_Static_Boolean_Expression
14461 (Expression (Get_Argument (N, Spec_Id)));
14463 end Extensions_Visible;
14469 -- pragma External (
14470 -- [ Convention =>] convention_IDENTIFIER,
14471 -- [ Entity =>] LOCAL_NAME
14472 -- [, [External_Name =>] static_string_EXPRESSION ]
14473 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14475 when Pragma_External => External : declare
14478 pragma Warnings (Off, C);
14485 Name_External_Name,
14487 Check_At_Least_N_Arguments (2);
14488 Check_At_Most_N_Arguments (4);
14489 Process_Convention (C, E);
14491 -- A pragma that applies to a Ghost entity becomes Ghost for the
14492 -- purposes of legality checks and removal of ignored Ghost code.
14494 Mark_Pragma_As_Ghost (N, E);
14496 Note_Possible_Modification
14497 (Get_Pragma_Arg (Arg2), Sure => False);
14498 Process_Interface_Name (E, Arg3, Arg4);
14499 Set_Exported (E, Arg2);
14502 --------------------------
14503 -- External_Name_Casing --
14504 --------------------------
14506 -- pragma External_Name_Casing (
14507 -- UPPERCASE | LOWERCASE
14508 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14510 when Pragma_External_Name_Casing => External_Name_Casing : declare
14513 Check_No_Identifiers;
14515 if Arg_Count = 2 then
14516 Check_Arg_Is_One_Of
14517 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14519 case Chars (Get_Pragma_Arg (Arg2)) is
14521 Opt.External_Name_Exp_Casing := As_Is;
14523 when Name_Uppercase =>
14524 Opt.External_Name_Exp_Casing := Uppercase;
14526 when Name_Lowercase =>
14527 Opt.External_Name_Exp_Casing := Lowercase;
14534 Check_Arg_Count (1);
14537 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14539 case Chars (Get_Pragma_Arg (Arg1)) is
14540 when Name_Uppercase =>
14541 Opt.External_Name_Imp_Casing := Uppercase;
14543 when Name_Lowercase =>
14544 Opt.External_Name_Imp_Casing := Lowercase;
14549 end External_Name_Casing;
14555 -- pragma Fast_Math;
14557 when Pragma_Fast_Math =>
14559 Check_No_Identifiers;
14560 Check_Valid_Configuration_Pragma;
14563 --------------------------
14564 -- Favor_Top_Level --
14565 --------------------------
14567 -- pragma Favor_Top_Level (type_NAME);
14569 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14574 Check_No_Identifiers;
14575 Check_Arg_Count (1);
14576 Check_Arg_Is_Local_Name (Arg1);
14577 Typ := Entity (Get_Pragma_Arg (Arg1));
14579 -- A pragma that applies to a Ghost entity becomes Ghost for the
14580 -- purposes of legality checks and removal of ignored Ghost code.
14582 Mark_Pragma_As_Ghost (N, Typ);
14584 -- If it's an access-to-subprogram type (in particular, not a
14585 -- subtype), set the flag on that type.
14587 if Is_Access_Subprogram_Type (Typ) then
14588 Set_Can_Use_Internal_Rep (Typ, False);
14590 -- Otherwise it's an error (name denotes the wrong sort of entity)
14594 ("access-to-subprogram type expected",
14595 Get_Pragma_Arg (Arg1));
14597 end Favor_Top_Level;
14599 ---------------------------
14600 -- Finalize_Storage_Only --
14601 ---------------------------
14603 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14605 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14606 Assoc : constant Node_Id := Arg1;
14607 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14612 Check_No_Identifiers;
14613 Check_Arg_Count (1);
14614 Check_Arg_Is_Local_Name (Arg1);
14616 Find_Type (Type_Id);
14617 Typ := Entity (Type_Id);
14620 or else Rep_Item_Too_Early (Typ, N)
14624 Typ := Underlying_Type (Typ);
14627 if not Is_Controlled (Typ) then
14628 Error_Pragma ("pragma% must specify controlled type");
14631 Check_First_Subtype (Arg1);
14633 if Finalize_Storage_Only (Typ) then
14634 Error_Pragma ("duplicate pragma%, only one allowed");
14636 elsif not Rep_Item_Too_Late (Typ, N) then
14637 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14639 end Finalize_Storage;
14645 -- pragma Ghost [ (boolean_EXPRESSION) ];
14647 when Pragma_Ghost => Ghost : declare
14651 Orig_Stmt : Node_Id;
14652 Prev_Id : Entity_Id;
14657 Check_No_Identifiers;
14658 Check_At_Most_N_Arguments (1);
14662 while Present (Stmt) loop
14664 -- Skip prior pragmas, but check for duplicates
14666 if Nkind (Stmt) = N_Pragma then
14667 if Pragma_Name (Stmt) = Pname then
14668 Error_Msg_Name_1 := Pname;
14669 Error_Msg_Sloc := Sloc (Stmt);
14670 Error_Msg_N ("pragma % duplicates pragma declared#", N);
14673 -- Task unit declared without a definition cannot be subject to
14674 -- pragma Ghost (SPARK RM 6.9(19)).
14676 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
14677 N_Task_Type_Declaration)
14679 Error_Pragma ("pragma % cannot apply to a task type");
14682 -- Skip internally generated code
14684 elsif not Comes_From_Source (Stmt) then
14685 Orig_Stmt := Original_Node (Stmt);
14687 -- When pragma Ghost applies to an untagged derivation, the
14688 -- derivation is transformed into a [sub]type declaration.
14690 if Nkind_In (Stmt, N_Full_Type_Declaration,
14691 N_Subtype_Declaration)
14692 and then Comes_From_Source (Orig_Stmt)
14693 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
14694 and then Nkind (Type_Definition (Orig_Stmt)) =
14695 N_Derived_Type_Definition
14697 Id := Defining_Entity (Stmt);
14700 -- When pragma Ghost applies to an expression function, the
14701 -- expression function is transformed into a subprogram.
14703 elsif Nkind (Stmt) = N_Subprogram_Declaration
14704 and then Comes_From_Source (Orig_Stmt)
14705 and then Nkind (Orig_Stmt) = N_Expression_Function
14707 Id := Defining_Entity (Stmt);
14711 -- The pragma applies to a legal construct, stop the traversal
14713 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
14714 N_Full_Type_Declaration,
14715 N_Generic_Subprogram_Declaration,
14716 N_Object_Declaration,
14717 N_Private_Extension_Declaration,
14718 N_Private_Type_Declaration,
14719 N_Subprogram_Declaration,
14720 N_Subtype_Declaration)
14722 Id := Defining_Entity (Stmt);
14725 -- The pragma does not apply to a legal construct, issue an
14726 -- error and stop the analysis.
14730 ("pragma % must apply to an object, package, subprogram "
14735 Stmt := Prev (Stmt);
14738 Context := Parent (N);
14740 -- Handle compilation units
14742 if Nkind (Context) = N_Compilation_Unit_Aux then
14743 Context := Unit (Parent (Context));
14746 -- Protected and task types cannot be subject to pragma Ghost
14747 -- (SPARK RM 6.9(19)).
14749 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
14751 Error_Pragma ("pragma % cannot apply to a protected type");
14754 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
14755 Error_Pragma ("pragma % cannot apply to a task type");
14761 -- When pragma Ghost is associated with a [generic] package, it
14762 -- appears in the visible declarations.
14764 if Nkind (Context) = N_Package_Specification
14765 and then Present (Visible_Declarations (Context))
14766 and then List_Containing (N) = Visible_Declarations (Context)
14768 Id := Defining_Entity (Context);
14770 -- Pragma Ghost applies to a stand alone subprogram body
14772 elsif Nkind (Context) = N_Subprogram_Body
14773 and then No (Corresponding_Spec (Context))
14775 Id := Defining_Entity (Context);
14781 ("pragma % must apply to an object, package, subprogram or "
14786 -- A derived type or type extension cannot be subject to pragma
14787 -- Ghost if either the parent type or one of the progenitor types
14788 -- is not Ghost (SPARK RM 6.9(9)).
14790 if Is_Derived_Type (Id) then
14791 Check_Ghost_Derivation (Id);
14794 -- Handle completions of types and constants that are subject to
14797 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
14798 Prev_Id := Incomplete_Or_Partial_View (Id);
14800 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
14801 Error_Msg_Name_1 := Pname;
14803 -- The full declaration of a deferred constant cannot be
14804 -- subject to pragma Ghost unless the deferred declaration
14805 -- is also Ghost (SPARK RM 6.9(10)).
14807 if Ekind (Prev_Id) = E_Constant then
14808 Error_Msg_Name_1 := Pname;
14809 Error_Msg_NE (Fix_Error
14810 ("pragma % must apply to declaration of deferred "
14811 & "constant &"), N, Id);
14814 -- Pragma Ghost may appear on the full view of an incomplete
14815 -- type because the incomplete declaration lacks aspects and
14816 -- cannot be subject to pragma Ghost.
14818 elsif Ekind (Prev_Id) = E_Incomplete_Type then
14821 -- The full declaration of a type cannot be subject to
14822 -- pragma Ghost unless the partial view is also Ghost
14823 -- (SPARK RM 6.9(10)).
14826 Error_Msg_NE (Fix_Error
14827 ("pragma % must apply to partial view of type &"),
14833 -- A synchronized object cannot be subject to pragma Ghost
14834 -- (SPARK RM 6.9(19)).
14836 elsif Ekind (Id) = E_Variable then
14837 if Is_Protected_Type (Etype (Id)) then
14838 Error_Pragma ("pragma % cannot apply to a protected object");
14841 elsif Is_Task_Type (Etype (Id)) then
14842 Error_Pragma ("pragma % cannot apply to a task object");
14847 -- Analyze the Boolean expression (if any)
14849 if Present (Arg1) then
14850 Expr := Get_Pragma_Arg (Arg1);
14852 Analyze_And_Resolve (Expr, Standard_Boolean);
14854 if Is_OK_Static_Expression (Expr) then
14856 -- "Ghostness" cannot be turned off once enabled within a
14857 -- region (SPARK RM 6.9(7)).
14859 if Is_False (Expr_Value (Expr))
14860 and then Ghost_Mode > None
14863 ("pragma % with value False cannot appear in enabled "
14868 -- Otherwie the expression is not static
14872 ("expression of pragma % must be static", Expr);
14877 Set_Is_Ghost_Entity (Id);
14884 -- pragma Global (GLOBAL_SPECIFICATION);
14886 -- GLOBAL_SPECIFICATION ::=
14889 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14891 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14893 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14894 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14895 -- GLOBAL_ITEM ::= NAME
14897 -- Characteristics:
14899 -- * Analysis - The annotation undergoes initial checks to verify
14900 -- the legal placement and context. Secondary checks fully analyze
14901 -- the dependency clauses in:
14903 -- Analyze_Global_In_Decl_Part
14905 -- * Expansion - None.
14907 -- * Template - The annotation utilizes the generic template of the
14908 -- related subprogram [body] when it is:
14910 -- aspect on subprogram declaration
14911 -- aspect on stand alone subprogram body
14912 -- pragma on stand alone subprogram body
14914 -- The annotation must prepare its own template when it is:
14916 -- pragma on subprogram declaration
14918 -- * Globals - Capture of global references must occur after full
14921 -- * Instance - The annotation is instantiated automatically when
14922 -- the related generic subprogram [body] is instantiated except for
14923 -- the "pragma on subprogram declaration" case. In that scenario
14924 -- the annotation must instantiate itself.
14926 when Pragma_Global => Global : declare
14928 Spec_Id : Entity_Id;
14929 Subp_Decl : Node_Id;
14932 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14936 -- Chain the pragma on the contract for further processing by
14937 -- Analyze_Global_In_Decl_Part.
14939 Add_Contract_Item (N, Spec_Id);
14941 -- Fully analyze the pragma when it appears inside an entry
14942 -- or subprogram body because it cannot benefit from forward
14945 if Nkind_In (Subp_Decl, N_Entry_Body,
14947 N_Subprogram_Body_Stub)
14949 -- The legality checks of pragmas Depends and Global are
14950 -- affected by the SPARK mode in effect and the volatility
14951 -- of the context. In addition these two pragmas are subject
14952 -- to an inherent order:
14957 -- Analyze all these pragmas in the order outlined above
14959 Analyze_If_Present (Pragma_SPARK_Mode);
14960 Analyze_If_Present (Pragma_Volatile_Function);
14961 Analyze_Global_In_Decl_Part (N);
14962 Analyze_If_Present (Pragma_Depends);
14971 -- pragma Ident (static_string_EXPRESSION)
14973 -- Note: pragma Comment shares this processing. Pragma Ident is
14974 -- identical in effect to pragma Commment.
14976 when Pragma_Ident | Pragma_Comment => Ident : declare
14981 Check_Arg_Count (1);
14982 Check_No_Identifiers;
14983 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
14986 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
14993 GP := Parent (Parent (N));
14995 if Nkind_In (GP, N_Package_Declaration,
14996 N_Generic_Package_Declaration)
15001 -- If we have a compilation unit, then record the ident value,
15002 -- checking for improper duplication.
15004 if Nkind (GP) = N_Compilation_Unit then
15005 CS := Ident_String (Current_Sem_Unit);
15007 if Present (CS) then
15009 -- If we have multiple instances, concatenate them, but
15010 -- not in ASIS, where we want the original tree.
15012 if not ASIS_Mode then
15013 Start_String (Strval (CS));
15014 Store_String_Char (' ');
15015 Store_String_Chars (Strval (Str));
15016 Set_Strval (CS, End_String);
15020 Set_Ident_String (Current_Sem_Unit, Str);
15023 -- For subunits, we just ignore the Ident, since in GNAT these
15024 -- are not separate object files, and hence not separate units
15025 -- in the unit table.
15027 elsif Nkind (GP) = N_Subunit then
15033 -------------------
15034 -- Ignore_Pragma --
15035 -------------------
15037 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15039 -- Entirely handled in the parser, nothing to do here
15041 when Pragma_Ignore_Pragma =>
15044 ----------------------------
15045 -- Implementation_Defined --
15046 ----------------------------
15048 -- pragma Implementation_Defined (LOCAL_NAME);
15050 -- Marks previously declared entity as implementation defined. For
15051 -- an overloaded entity, applies to the most recent homonym.
15053 -- pragma Implementation_Defined;
15055 -- The form with no arguments appears anywhere within a scope, most
15056 -- typically a package spec, and indicates that all entities that are
15057 -- defined within the package spec are Implementation_Defined.
15059 when Pragma_Implementation_Defined => Implementation_Defined : declare
15064 Check_No_Identifiers;
15066 -- Form with no arguments
15068 if Arg_Count = 0 then
15069 Set_Is_Implementation_Defined (Current_Scope);
15071 -- Form with one argument
15074 Check_Arg_Count (1);
15075 Check_Arg_Is_Local_Name (Arg1);
15076 Ent := Entity (Get_Pragma_Arg (Arg1));
15077 Set_Is_Implementation_Defined (Ent);
15079 end Implementation_Defined;
15085 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15087 -- IMPLEMENTATION_KIND ::=
15088 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15090 -- "By_Any" and "Optional" are treated as synonyms in order to
15091 -- support Ada 2012 aspect Synchronization.
15093 when Pragma_Implemented => Implemented : declare
15094 Proc_Id : Entity_Id;
15099 Check_Arg_Count (2);
15100 Check_No_Identifiers;
15101 Check_Arg_Is_Identifier (Arg1);
15102 Check_Arg_Is_Local_Name (Arg1);
15103 Check_Arg_Is_One_Of (Arg2,
15106 Name_By_Protected_Procedure,
15109 -- Extract the name of the local procedure
15111 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15113 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15114 -- primitive procedure of a synchronized tagged type.
15116 if Ekind (Proc_Id) = E_Procedure
15117 and then Is_Primitive (Proc_Id)
15118 and then Present (First_Formal (Proc_Id))
15120 Typ := Etype (First_Formal (Proc_Id));
15122 if Is_Tagged_Type (Typ)
15125 -- Check for a protected, a synchronized or a task interface
15127 ((Is_Interface (Typ)
15128 and then Is_Synchronized_Interface (Typ))
15130 -- Check for a protected type or a task type that implements
15134 (Is_Concurrent_Record_Type (Typ)
15135 and then Present (Interfaces (Typ)))
15137 -- In analysis-only mode, examine original protected type
15140 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15141 and then Present (Interface_List (Parent (Typ))))
15143 -- Check for a private record extension with keyword
15147 (Ekind_In (Typ, E_Record_Type_With_Private,
15148 E_Record_Subtype_With_Private)
15149 and then Synchronized_Present (Parent (Typ))))
15154 ("controlling formal must be of synchronized tagged type",
15159 -- Procedures declared inside a protected type must be accepted
15161 elsif Ekind (Proc_Id) = E_Procedure
15162 and then Is_Protected_Type (Scope (Proc_Id))
15166 -- The first argument is not a primitive procedure
15170 ("pragma % must be applied to a primitive procedure", Arg1);
15174 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15175 -- By_Protected_Procedure to the primitive procedure of a task
15178 if Chars (Arg2) = Name_By_Protected_Procedure
15179 and then Is_Interface (Typ)
15180 and then Is_Task_Interface (Typ)
15183 ("implementation kind By_Protected_Procedure cannot be "
15184 & "applied to a task interface primitive", Arg2);
15188 Record_Rep_Item (Proc_Id, N);
15191 ----------------------
15192 -- Implicit_Packing --
15193 ----------------------
15195 -- pragma Implicit_Packing;
15197 when Pragma_Implicit_Packing =>
15199 Check_Arg_Count (0);
15200 Implicit_Packing := True;
15207 -- [Convention =>] convention_IDENTIFIER,
15208 -- [Entity =>] LOCAL_NAME
15209 -- [, [External_Name =>] static_string_EXPRESSION ]
15210 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15212 when Pragma_Import =>
15213 Check_Ada_83_Warning;
15217 Name_External_Name,
15220 Check_At_Least_N_Arguments (2);
15221 Check_At_Most_N_Arguments (4);
15222 Process_Import_Or_Interface;
15224 ---------------------
15225 -- Import_Function --
15226 ---------------------
15228 -- pragma Import_Function (
15229 -- [Internal =>] LOCAL_NAME,
15230 -- [, [External =>] EXTERNAL_SYMBOL]
15231 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15232 -- [, [Result_Type =>] SUBTYPE_MARK]
15233 -- [, [Mechanism =>] MECHANISM]
15234 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15236 -- EXTERNAL_SYMBOL ::=
15238 -- | static_string_EXPRESSION
15240 -- PARAMETER_TYPES ::=
15242 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15244 -- TYPE_DESIGNATOR ::=
15246 -- | subtype_Name ' Access
15250 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15252 -- MECHANISM_ASSOCIATION ::=
15253 -- [formal_parameter_NAME =>] MECHANISM_NAME
15255 -- MECHANISM_NAME ::=
15259 when Pragma_Import_Function => Import_Function : declare
15260 Args : Args_List (1 .. 6);
15261 Names : constant Name_List (1 .. 6) := (
15264 Name_Parameter_Types,
15267 Name_Result_Mechanism);
15269 Internal : Node_Id renames Args (1);
15270 External : Node_Id renames Args (2);
15271 Parameter_Types : Node_Id renames Args (3);
15272 Result_Type : Node_Id renames Args (4);
15273 Mechanism : Node_Id renames Args (5);
15274 Result_Mechanism : Node_Id renames Args (6);
15278 Gather_Associations (Names, Args);
15279 Process_Extended_Import_Export_Subprogram_Pragma (
15280 Arg_Internal => Internal,
15281 Arg_External => External,
15282 Arg_Parameter_Types => Parameter_Types,
15283 Arg_Result_Type => Result_Type,
15284 Arg_Mechanism => Mechanism,
15285 Arg_Result_Mechanism => Result_Mechanism);
15286 end Import_Function;
15288 -------------------
15289 -- Import_Object --
15290 -------------------
15292 -- pragma Import_Object (
15293 -- [Internal =>] LOCAL_NAME
15294 -- [, [External =>] EXTERNAL_SYMBOL]
15295 -- [, [Size =>] EXTERNAL_SYMBOL]);
15297 -- EXTERNAL_SYMBOL ::=
15299 -- | static_string_EXPRESSION
15301 when Pragma_Import_Object => Import_Object : declare
15302 Args : Args_List (1 .. 3);
15303 Names : constant Name_List (1 .. 3) := (
15308 Internal : Node_Id renames Args (1);
15309 External : Node_Id renames Args (2);
15310 Size : Node_Id renames Args (3);
15314 Gather_Associations (Names, Args);
15315 Process_Extended_Import_Export_Object_Pragma (
15316 Arg_Internal => Internal,
15317 Arg_External => External,
15321 ----------------------
15322 -- Import_Procedure --
15323 ----------------------
15325 -- pragma Import_Procedure (
15326 -- [Internal =>] LOCAL_NAME
15327 -- [, [External =>] EXTERNAL_SYMBOL]
15328 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15329 -- [, [Mechanism =>] MECHANISM]);
15331 -- EXTERNAL_SYMBOL ::=
15333 -- | static_string_EXPRESSION
15335 -- PARAMETER_TYPES ::=
15337 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15339 -- TYPE_DESIGNATOR ::=
15341 -- | subtype_Name ' Access
15345 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15347 -- MECHANISM_ASSOCIATION ::=
15348 -- [formal_parameter_NAME =>] MECHANISM_NAME
15350 -- MECHANISM_NAME ::=
15354 when Pragma_Import_Procedure => Import_Procedure : declare
15355 Args : Args_List (1 .. 4);
15356 Names : constant Name_List (1 .. 4) := (
15359 Name_Parameter_Types,
15362 Internal : Node_Id renames Args (1);
15363 External : Node_Id renames Args (2);
15364 Parameter_Types : Node_Id renames Args (3);
15365 Mechanism : Node_Id renames Args (4);
15369 Gather_Associations (Names, Args);
15370 Process_Extended_Import_Export_Subprogram_Pragma (
15371 Arg_Internal => Internal,
15372 Arg_External => External,
15373 Arg_Parameter_Types => Parameter_Types,
15374 Arg_Mechanism => Mechanism);
15375 end Import_Procedure;
15377 -----------------------------
15378 -- Import_Valued_Procedure --
15379 -----------------------------
15381 -- pragma Import_Valued_Procedure (
15382 -- [Internal =>] LOCAL_NAME
15383 -- [, [External =>] EXTERNAL_SYMBOL]
15384 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15385 -- [, [Mechanism =>] MECHANISM]);
15387 -- EXTERNAL_SYMBOL ::=
15389 -- | static_string_EXPRESSION
15391 -- PARAMETER_TYPES ::=
15393 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15395 -- TYPE_DESIGNATOR ::=
15397 -- | subtype_Name ' Access
15401 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15403 -- MECHANISM_ASSOCIATION ::=
15404 -- [formal_parameter_NAME =>] MECHANISM_NAME
15406 -- MECHANISM_NAME ::=
15410 when Pragma_Import_Valued_Procedure =>
15411 Import_Valued_Procedure : declare
15412 Args : Args_List (1 .. 4);
15413 Names : constant Name_List (1 .. 4) := (
15416 Name_Parameter_Types,
15419 Internal : Node_Id renames Args (1);
15420 External : Node_Id renames Args (2);
15421 Parameter_Types : Node_Id renames Args (3);
15422 Mechanism : Node_Id renames Args (4);
15426 Gather_Associations (Names, Args);
15427 Process_Extended_Import_Export_Subprogram_Pragma (
15428 Arg_Internal => Internal,
15429 Arg_External => External,
15430 Arg_Parameter_Types => Parameter_Types,
15431 Arg_Mechanism => Mechanism);
15432 end Import_Valued_Procedure;
15438 -- pragma Independent (LOCAL_NAME);
15440 when Pragma_Independent =>
15441 Process_Atomic_Independent_Shared_Volatile;
15443 ----------------------------
15444 -- Independent_Components --
15445 ----------------------------
15447 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15449 when Pragma_Independent_Components => Independent_Components : declare
15457 Check_Ada_83_Warning;
15459 Check_No_Identifiers;
15460 Check_Arg_Count (1);
15461 Check_Arg_Is_Local_Name (Arg1);
15462 E_Id := Get_Pragma_Arg (Arg1);
15464 if Etype (E_Id) = Any_Type then
15468 E := Entity (E_Id);
15470 -- A pragma that applies to a Ghost entity becomes Ghost for the
15471 -- purposes of legality checks and removal of ignored Ghost code.
15473 Mark_Pragma_As_Ghost (N, E);
15475 -- Check duplicate before we chain ourselves
15477 Check_Duplicate_Pragma (E);
15479 -- Check appropriate entity
15481 if Rep_Item_Too_Early (E, N)
15483 Rep_Item_Too_Late (E, N)
15488 D := Declaration_Node (E);
15491 -- The flag is set on the base type, or on the object
15493 if K = N_Full_Type_Declaration
15494 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15496 Set_Has_Independent_Components (Base_Type (E));
15497 Record_Independence_Check (N, Base_Type (E));
15499 -- For record type, set all components independent
15501 if Is_Record_Type (E) then
15502 C := First_Component (E);
15503 while Present (C) loop
15504 Set_Is_Independent (C);
15505 Next_Component (C);
15509 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15510 and then Nkind (D) = N_Object_Declaration
15511 and then Nkind (Object_Definition (D)) =
15512 N_Constrained_Array_Definition
15514 Set_Has_Independent_Components (E);
15515 Record_Independence_Check (N, E);
15518 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15520 end Independent_Components;
15522 -----------------------
15523 -- Initial_Condition --
15524 -----------------------
15526 -- pragma Initial_Condition (boolean_EXPRESSION);
15528 -- Characteristics:
15530 -- * Analysis - The annotation undergoes initial checks to verify
15531 -- the legal placement and context. Secondary checks preanalyze the
15534 -- Analyze_Initial_Condition_In_Decl_Part
15536 -- * Expansion - The annotation is expanded during the expansion of
15537 -- the package body whose declaration is subject to the annotation
15540 -- Expand_Pragma_Initial_Condition
15542 -- * Template - The annotation utilizes the generic template of the
15543 -- related package declaration.
15545 -- * Globals - Capture of global references must occur after full
15548 -- * Instance - The annotation is instantiated automatically when
15549 -- the related generic package is instantiated.
15551 when Pragma_Initial_Condition => Initial_Condition : declare
15552 Pack_Decl : Node_Id;
15553 Pack_Id : Entity_Id;
15557 Check_No_Identifiers;
15558 Check_Arg_Count (1);
15560 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15562 -- Ensure the proper placement of the pragma. Initial_Condition
15563 -- must be associated with a package declaration.
15565 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15566 N_Package_Declaration)
15570 -- Otherwise the pragma is associated with an illegal context
15577 Pack_Id := Defining_Entity (Pack_Decl);
15579 -- Chain the pragma on the contract for further processing by
15580 -- Analyze_Initial_Condition_In_Decl_Part.
15582 Add_Contract_Item (N, Pack_Id);
15584 -- The legality checks of pragmas Abstract_State, Initializes, and
15585 -- Initial_Condition are affected by the SPARK mode in effect. In
15586 -- addition, these three pragmas are subject to an inherent order:
15588 -- 1) Abstract_State
15590 -- 3) Initial_Condition
15592 -- Analyze all these pragmas in the order outlined above
15594 Analyze_If_Present (Pragma_SPARK_Mode);
15595 Analyze_If_Present (Pragma_Abstract_State);
15596 Analyze_If_Present (Pragma_Initializes);
15598 -- A pragma that applies to a Ghost entity becomes Ghost for the
15599 -- purposes of legality checks and removal of ignored Ghost code.
15601 Mark_Pragma_As_Ghost (N, Pack_Id);
15602 end Initial_Condition;
15604 ------------------------
15605 -- Initialize_Scalars --
15606 ------------------------
15608 -- pragma Initialize_Scalars;
15610 when Pragma_Initialize_Scalars =>
15612 Check_Arg_Count (0);
15613 Check_Valid_Configuration_Pragma;
15614 Check_Restriction (No_Initialize_Scalars, N);
15616 -- Initialize_Scalars creates false positives in CodePeer, and
15617 -- incorrect negative results in GNATprove mode, so ignore this
15618 -- pragma in these modes.
15620 if not Restriction_Active (No_Initialize_Scalars)
15621 and then not (CodePeer_Mode or GNATprove_Mode)
15623 Init_Or_Norm_Scalars := True;
15624 Initialize_Scalars := True;
15631 -- pragma Initializes (INITIALIZATION_SPEC);
15633 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15635 -- INITIALIZATION_LIST ::=
15636 -- INITIALIZATION_ITEM
15637 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15639 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15644 -- | (INPUT {, INPUT})
15648 -- Characteristics:
15650 -- * Analysis - The annotation undergoes initial checks to verify
15651 -- the legal placement and context. Secondary checks preanalyze the
15654 -- Analyze_Initializes_In_Decl_Part
15656 -- * Expansion - None.
15658 -- * Template - The annotation utilizes the generic template of the
15659 -- related package declaration.
15661 -- * Globals - Capture of global references must occur after full
15664 -- * Instance - The annotation is instantiated automatically when
15665 -- the related generic package is instantiated.
15667 when Pragma_Initializes => Initializes : declare
15668 Pack_Decl : Node_Id;
15669 Pack_Id : Entity_Id;
15673 Check_No_Identifiers;
15674 Check_Arg_Count (1);
15676 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15678 -- Ensure the proper placement of the pragma. Initializes must be
15679 -- associated with a package declaration.
15681 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15682 N_Package_Declaration)
15686 -- Otherwise the pragma is associated with an illegal construc
15693 Pack_Id := Defining_Entity (Pack_Decl);
15695 -- Chain the pragma on the contract for further processing by
15696 -- Analyze_Initializes_In_Decl_Part.
15698 Add_Contract_Item (N, Pack_Id);
15700 -- The legality checks of pragmas Abstract_State, Initializes, and
15701 -- Initial_Condition are affected by the SPARK mode in effect. In
15702 -- addition, these three pragmas are subject to an inherent order:
15704 -- 1) Abstract_State
15706 -- 3) Initial_Condition
15708 -- Analyze all these pragmas in the order outlined above
15710 Analyze_If_Present (Pragma_SPARK_Mode);
15711 Analyze_If_Present (Pragma_Abstract_State);
15713 -- A pragma that applies to a Ghost entity becomes Ghost for the
15714 -- purposes of legality checks and removal of ignored Ghost code.
15716 Mark_Pragma_As_Ghost (N, Pack_Id);
15717 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
15719 Analyze_If_Present (Pragma_Initial_Condition);
15726 -- pragma Inline ( NAME {, NAME} );
15728 when Pragma_Inline =>
15730 -- Pragma always active unless in GNATprove mode. It is disabled
15731 -- in GNATprove mode because frontend inlining is applied
15732 -- independently of pragmas Inline and Inline_Always for
15733 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15736 if not GNATprove_Mode then
15738 -- Inline status is Enabled if inlining option is active
15740 if Inline_Active then
15741 Process_Inline (Enabled);
15743 Process_Inline (Disabled);
15747 -------------------
15748 -- Inline_Always --
15749 -------------------
15751 -- pragma Inline_Always ( NAME {, NAME} );
15753 when Pragma_Inline_Always =>
15756 -- Pragma always active unless in CodePeer mode or GNATprove
15757 -- mode. It is disabled in CodePeer mode because inlining is
15758 -- not helpful, and enabling it caused walk order issues. It
15759 -- is disabled in GNATprove mode because frontend inlining is
15760 -- applied independently of pragmas Inline and Inline_Always for
15761 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15764 if not CodePeer_Mode and not GNATprove_Mode then
15765 Process_Inline (Enabled);
15768 --------------------
15769 -- Inline_Generic --
15770 --------------------
15772 -- pragma Inline_Generic (NAME {, NAME});
15774 when Pragma_Inline_Generic =>
15776 Process_Generic_List;
15778 ----------------------
15779 -- Inspection_Point --
15780 ----------------------
15782 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15784 when Pragma_Inspection_Point => Inspection_Point : declare
15791 if Arg_Count > 0 then
15794 Exp := Get_Pragma_Arg (Arg);
15797 if not Is_Entity_Name (Exp)
15798 or else not Is_Object (Entity (Exp))
15800 Error_Pragma_Arg ("object name required", Arg);
15804 exit when No (Arg);
15807 end Inspection_Point;
15813 -- pragma Interface (
15814 -- [ Convention =>] convention_IDENTIFIER,
15815 -- [ Entity =>] LOCAL_NAME
15816 -- [, [External_Name =>] static_string_EXPRESSION ]
15817 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15819 when Pragma_Interface =>
15824 Name_External_Name,
15826 Check_At_Least_N_Arguments (2);
15827 Check_At_Most_N_Arguments (4);
15828 Process_Import_Or_Interface;
15830 -- In Ada 2005, the permission to use Interface (a reserved word)
15831 -- as a pragma name is considered an obsolescent feature, and this
15832 -- pragma was already obsolescent in Ada 95.
15834 if Ada_Version >= Ada_95 then
15836 (No_Obsolescent_Features, Pragma_Identifier (N));
15838 if Warn_On_Obsolescent_Feature then
15840 ("pragma Interface is an obsolescent feature?j?", N);
15842 ("|use pragma Import instead?j?", N);
15846 --------------------
15847 -- Interface_Name --
15848 --------------------
15850 -- pragma Interface_Name (
15851 -- [ Entity =>] LOCAL_NAME
15852 -- [,[External_Name =>] static_string_EXPRESSION ]
15853 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15855 when Pragma_Interface_Name => Interface_Name : declare
15857 Def_Id : Entity_Id;
15858 Hom_Id : Entity_Id;
15864 ((Name_Entity, Name_External_Name, Name_Link_Name));
15865 Check_At_Least_N_Arguments (2);
15866 Check_At_Most_N_Arguments (3);
15867 Id := Get_Pragma_Arg (Arg1);
15870 -- This is obsolete from Ada 95 on, but it is an implementation
15871 -- defined pragma, so we do not consider that it violates the
15872 -- restriction (No_Obsolescent_Features).
15874 if Ada_Version >= Ada_95 then
15875 if Warn_On_Obsolescent_Feature then
15877 ("pragma Interface_Name is an obsolescent feature?j?", N);
15879 ("|use pragma Import instead?j?", N);
15883 if not Is_Entity_Name (Id) then
15885 ("first argument for pragma% must be entity name", Arg1);
15886 elsif Etype (Id) = Any_Type then
15889 Def_Id := Entity (Id);
15892 -- Special DEC-compatible processing for the object case, forces
15893 -- object to be imported.
15895 if Ekind (Def_Id) = E_Variable then
15896 Kill_Size_Check_Code (Def_Id);
15897 Note_Possible_Modification (Id, Sure => False);
15899 -- Initialization is not allowed for imported variable
15901 if Present (Expression (Parent (Def_Id)))
15902 and then Comes_From_Source (Expression (Parent (Def_Id)))
15904 Error_Msg_Sloc := Sloc (Def_Id);
15906 ("no initialization allowed for declaration of& #",
15910 -- For compatibility, support VADS usage of providing both
15911 -- pragmas Interface and Interface_Name to obtain the effect
15912 -- of a single Import pragma.
15914 if Is_Imported (Def_Id)
15915 and then Present (First_Rep_Item (Def_Id))
15916 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
15918 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
15922 Set_Imported (Def_Id);
15925 Set_Is_Public (Def_Id);
15926 Process_Interface_Name (Def_Id, Arg2, Arg3);
15929 -- Otherwise must be subprogram
15931 elsif not Is_Subprogram (Def_Id) then
15933 ("argument of pragma% is not subprogram", Arg1);
15936 Check_At_Most_N_Arguments (3);
15940 -- Loop through homonyms
15943 Def_Id := Get_Base_Subprogram (Hom_Id);
15945 if Is_Imported (Def_Id) then
15946 Process_Interface_Name (Def_Id, Arg2, Arg3);
15950 exit when From_Aspect_Specification (N);
15951 Hom_Id := Homonym (Hom_Id);
15953 exit when No (Hom_Id)
15954 or else Scope (Hom_Id) /= Current_Scope;
15959 ("argument of pragma% is not imported subprogram",
15963 end Interface_Name;
15965 -----------------------
15966 -- Interrupt_Handler --
15967 -----------------------
15969 -- pragma Interrupt_Handler (handler_NAME);
15971 when Pragma_Interrupt_Handler =>
15972 Check_Ada_83_Warning;
15973 Check_Arg_Count (1);
15974 Check_No_Identifiers;
15976 if No_Run_Time_Mode then
15977 Error_Msg_CRT ("Interrupt_Handler pragma", N);
15979 Check_Interrupt_Or_Attach_Handler;
15980 Process_Interrupt_Or_Attach_Handler;
15983 ------------------------
15984 -- Interrupt_Priority --
15985 ------------------------
15987 -- pragma Interrupt_Priority [(EXPRESSION)];
15989 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
15990 P : constant Node_Id := Parent (N);
15995 Check_Ada_83_Warning;
15997 if Arg_Count /= 0 then
15998 Arg := Get_Pragma_Arg (Arg1);
15999 Check_Arg_Count (1);
16000 Check_No_Identifiers;
16002 -- The expression must be analyzed in the special manner
16003 -- described in "Handling of Default and Per-Object
16004 -- Expressions" in sem.ads.
16006 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16009 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16014 Ent := Defining_Identifier (Parent (P));
16016 -- Check duplicate pragma before we chain the pragma in the Rep
16017 -- Item chain of Ent.
16019 Check_Duplicate_Pragma (Ent);
16020 Record_Rep_Item (Ent, N);
16022 -- Check the No_Task_At_Interrupt_Priority restriction
16024 if Nkind (P) = N_Task_Definition then
16025 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16028 end Interrupt_Priority;
16030 ---------------------
16031 -- Interrupt_State --
16032 ---------------------
16034 -- pragma Interrupt_State (
16035 -- [Name =>] INTERRUPT_ID,
16036 -- [State =>] INTERRUPT_STATE);
16038 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16039 -- INTERRUPT_STATE => System | Runtime | User
16041 -- Note: if the interrupt id is given as an identifier, then it must
16042 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16043 -- given as a static integer expression which must be in the range of
16044 -- Ada.Interrupts.Interrupt_ID.
16046 when Pragma_Interrupt_State => Interrupt_State : declare
16047 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16048 -- This is the entity Ada.Interrupts.Interrupt_ID;
16050 State_Type : Character;
16051 -- Set to 's'/'r'/'u' for System/Runtime/User
16054 -- Index to entry in Interrupt_States table
16057 -- Value of interrupt
16059 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16060 -- The first argument to the pragma
16062 Int_Ent : Entity_Id;
16063 -- Interrupt entity in Ada.Interrupts.Names
16067 Check_Arg_Order ((Name_Name, Name_State));
16068 Check_Arg_Count (2);
16070 Check_Optional_Identifier (Arg1, Name_Name);
16071 Check_Optional_Identifier (Arg2, Name_State);
16072 Check_Arg_Is_Identifier (Arg2);
16074 -- First argument is identifier
16076 if Nkind (Arg1X) = N_Identifier then
16078 -- Search list of names in Ada.Interrupts.Names
16080 Int_Ent := First_Entity (RTE (RE_Names));
16082 if No (Int_Ent) then
16083 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16085 elsif Chars (Int_Ent) = Chars (Arg1X) then
16086 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16090 Next_Entity (Int_Ent);
16093 -- First argument is not an identifier, so it must be a static
16094 -- expression of type Ada.Interrupts.Interrupt_ID.
16097 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16098 Int_Val := Expr_Value (Arg1X);
16100 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16102 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16105 ("value not in range of type "
16106 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16112 case Chars (Get_Pragma_Arg (Arg2)) is
16113 when Name_Runtime => State_Type := 'r';
16114 when Name_System => State_Type := 's';
16115 when Name_User => State_Type := 'u';
16118 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16121 -- Check if entry is already stored
16123 IST_Num := Interrupt_States.First;
16125 -- If entry not found, add it
16127 if IST_Num > Interrupt_States.Last then
16128 Interrupt_States.Append
16129 ((Interrupt_Number => UI_To_Int (Int_Val),
16130 Interrupt_State => State_Type,
16131 Pragma_Loc => Loc));
16134 -- Case of entry for the same entry
16136 elsif Int_Val = Interrupt_States.Table (IST_Num).
16139 -- If state matches, done, no need to make redundant entry
16142 State_Type = Interrupt_States.Table (IST_Num).
16145 -- Otherwise if state does not match, error
16148 Interrupt_States.Table (IST_Num).Pragma_Loc;
16150 ("state conflicts with that given #", Arg2);
16154 IST_Num := IST_Num + 1;
16156 end Interrupt_State;
16162 -- pragma Invariant
16163 -- ([Entity =>] type_LOCAL_NAME,
16164 -- [Check =>] EXPRESSION
16165 -- [,[Message =>] String_Expression]);
16167 when Pragma_Invariant => Invariant : declare
16174 Check_At_Least_N_Arguments (2);
16175 Check_At_Most_N_Arguments (3);
16176 Check_Optional_Identifier (Arg1, Name_Entity);
16177 Check_Optional_Identifier (Arg2, Name_Check);
16179 if Arg_Count = 3 then
16180 Check_Optional_Identifier (Arg3, Name_Message);
16181 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16184 Check_Arg_Is_Local_Name (Arg1);
16186 Type_Id := Get_Pragma_Arg (Arg1);
16187 Find_Type (Type_Id);
16188 Typ := Entity (Type_Id);
16190 if Typ = Any_Type then
16193 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16195 elsif Is_Interface (Typ) then
16198 -- An invariant must apply to a private type, or appear in the
16199 -- private part of a package spec and apply to a completion.
16200 -- a class-wide invariant can only appear on a private declaration
16201 -- or private extension, not a completion.
16203 elsif Ekind_In (Typ, E_Private_Type,
16204 E_Record_Type_With_Private,
16205 E_Limited_Private_Type)
16209 elsif In_Private_Part (Current_Scope)
16210 and then Has_Private_Declaration (Typ)
16211 and then not Class_Present (N)
16215 elsif In_Private_Part (Current_Scope) then
16217 ("pragma% only allowed for private type declared in "
16218 & "visible part", Arg1);
16222 ("pragma% only allowed for private type", Arg1);
16225 -- A pragma that applies to a Ghost entity becomes Ghost for the
16226 -- purposes of legality checks and removal of ignored Ghost code.
16228 Mark_Pragma_As_Ghost (N, Typ);
16230 -- Not allowed for abstract type in the non-class case (it is
16231 -- allowed to use Invariant'Class for abstract types).
16233 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16235 ("pragma% not allowed for abstract type", Arg1);
16238 -- Link the pragma on to the rep item chain, for processing when
16239 -- the type is frozen.
16241 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16243 -- Note that the type has at least one invariant, and also that
16244 -- it has inheritable invariants if we have Invariant'Class
16245 -- or Type_Invariant'Class. Build the corresponding invariant
16246 -- procedure declaration, so that calls to it can be generated
16247 -- before the body is built (e.g. within an expression function).
16249 -- Interface types have no invariant procedure; their invariants
16250 -- are propagated to the build invariant procedure of all the
16251 -- types covering the interface type.
16253 if not Is_Interface (Typ) then
16254 Insert_After_And_Analyze
16255 (N, Build_Invariant_Procedure_Declaration (Typ));
16258 if Class_Present (N) then
16259 Set_Has_Inheritable_Invariants (Typ);
16267 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16269 when Pragma_Keep_Names => Keep_Names : declare
16274 Check_Arg_Count (1);
16275 Check_Optional_Identifier (Arg1, Name_On);
16276 Check_Arg_Is_Local_Name (Arg1);
16278 Arg := Get_Pragma_Arg (Arg1);
16281 if Etype (Arg) = Any_Type then
16285 if not Is_Entity_Name (Arg)
16286 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16289 ("pragma% requires a local enumeration type", Arg1);
16292 Set_Discard_Names (Entity (Arg), False);
16299 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16301 when Pragma_License =>
16304 -- Do not analyze pragma any further in CodePeer mode, to avoid
16305 -- extraneous errors in this implementation-dependent pragma,
16306 -- which has a different profile on other compilers.
16308 if CodePeer_Mode then
16312 Check_Arg_Count (1);
16313 Check_No_Identifiers;
16314 Check_Valid_Configuration_Pragma;
16315 Check_Arg_Is_Identifier (Arg1);
16318 Sind : constant Source_File_Index :=
16319 Source_Index (Current_Sem_Unit);
16322 case Chars (Get_Pragma_Arg (Arg1)) is
16324 Set_License (Sind, GPL);
16326 when Name_Modified_GPL =>
16327 Set_License (Sind, Modified_GPL);
16329 when Name_Restricted =>
16330 Set_License (Sind, Restricted);
16332 when Name_Unrestricted =>
16333 Set_License (Sind, Unrestricted);
16336 Error_Pragma_Arg ("invalid license name", Arg1);
16344 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16346 when Pragma_Link_With => Link_With : declare
16352 if Operating_Mode = Generate_Code
16353 and then In_Extended_Main_Source_Unit (N)
16355 Check_At_Least_N_Arguments (1);
16356 Check_No_Identifiers;
16357 Check_Is_In_Decl_Part_Or_Package_Spec;
16358 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16362 while Present (Arg) loop
16363 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16365 -- Store argument, converting sequences of spaces to a
16366 -- single null character (this is one of the differences
16367 -- in processing between Link_With and Linker_Options).
16369 Arg_Store : declare
16370 C : constant Char_Code := Get_Char_Code (' ');
16371 S : constant String_Id :=
16372 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16373 L : constant Nat := String_Length (S);
16376 procedure Skip_Spaces;
16377 -- Advance F past any spaces
16383 procedure Skip_Spaces is
16385 while F <= L and then Get_String_Char (S, F) = C loop
16390 -- Start of processing for Arg_Store
16393 Skip_Spaces; -- skip leading spaces
16395 -- Loop through characters, changing any embedded
16396 -- sequence of spaces to a single null character (this
16397 -- is how Link_With/Linker_Options differ)
16400 if Get_String_Char (S, F) = C then
16403 Store_String_Char (ASCII.NUL);
16406 Store_String_Char (Get_String_Char (S, F));
16414 if Present (Arg) then
16415 Store_String_Char (ASCII.NUL);
16419 Store_Linker_Option_String (End_String);
16427 -- pragma Linker_Alias (
16428 -- [Entity =>] LOCAL_NAME
16429 -- [Target =>] static_string_EXPRESSION);
16431 when Pragma_Linker_Alias =>
16433 Check_Arg_Order ((Name_Entity, Name_Target));
16434 Check_Arg_Count (2);
16435 Check_Optional_Identifier (Arg1, Name_Entity);
16436 Check_Optional_Identifier (Arg2, Name_Target);
16437 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16438 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16440 -- The only processing required is to link this item on to the
16441 -- list of rep items for the given entity. This is accomplished
16442 -- by the call to Rep_Item_Too_Late (when no error is detected
16443 -- and False is returned).
16445 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16448 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16451 ------------------------
16452 -- Linker_Constructor --
16453 ------------------------
16455 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16457 -- Code is shared with Linker_Destructor
16459 -----------------------
16460 -- Linker_Destructor --
16461 -----------------------
16463 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16465 when Pragma_Linker_Constructor |
16466 Pragma_Linker_Destructor =>
16467 Linker_Constructor : declare
16473 Check_Arg_Count (1);
16474 Check_No_Identifiers;
16475 Check_Arg_Is_Local_Name (Arg1);
16476 Arg1_X := Get_Pragma_Arg (Arg1);
16478 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16480 if not Is_Library_Level_Entity (Proc) then
16482 ("argument for pragma% must be library level entity", Arg1);
16485 -- The only processing required is to link this item on to the
16486 -- list of rep items for the given entity. This is accomplished
16487 -- by the call to Rep_Item_Too_Late (when no error is detected
16488 -- and False is returned).
16490 if Rep_Item_Too_Late (Proc, N) then
16493 Set_Has_Gigi_Rep_Item (Proc);
16495 end Linker_Constructor;
16497 --------------------
16498 -- Linker_Options --
16499 --------------------
16501 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16503 when Pragma_Linker_Options => Linker_Options : declare
16507 Check_Ada_83_Warning;
16508 Check_No_Identifiers;
16509 Check_Arg_Count (1);
16510 Check_Is_In_Decl_Part_Or_Package_Spec;
16511 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16512 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16515 while Present (Arg) loop
16516 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16517 Store_String_Char (ASCII.NUL);
16519 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16523 if Operating_Mode = Generate_Code
16524 and then In_Extended_Main_Source_Unit (N)
16526 Store_Linker_Option_String (End_String);
16528 end Linker_Options;
16530 --------------------
16531 -- Linker_Section --
16532 --------------------
16534 -- pragma Linker_Section (
16535 -- [Entity =>] LOCAL_NAME
16536 -- [Section =>] static_string_EXPRESSION);
16538 when Pragma_Linker_Section => Linker_Section : declare
16543 Ghost_Error_Posted : Boolean := False;
16544 -- Flag set when an error concerning the illegal mix of Ghost and
16545 -- non-Ghost subprograms is emitted.
16547 Ghost_Id : Entity_Id := Empty;
16548 -- The entity of the first Ghost subprogram encountered while
16549 -- processing the arguments of the pragma.
16553 Check_Arg_Order ((Name_Entity, Name_Section));
16554 Check_Arg_Count (2);
16555 Check_Optional_Identifier (Arg1, Name_Entity);
16556 Check_Optional_Identifier (Arg2, Name_Section);
16557 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16558 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16560 -- Check kind of entity
16562 Arg := Get_Pragma_Arg (Arg1);
16563 Ent := Entity (Arg);
16565 case Ekind (Ent) is
16567 -- Objects (constants and variables) and types. For these cases
16568 -- all we need to do is to set the Linker_Section_pragma field,
16569 -- checking that we do not have a duplicate.
16571 when E_Constant | E_Variable | Type_Kind =>
16572 LPE := Linker_Section_Pragma (Ent);
16574 if Present (LPE) then
16575 Error_Msg_Sloc := Sloc (LPE);
16577 ("Linker_Section already specified for &#", Arg1, Ent);
16580 Set_Linker_Section_Pragma (Ent, N);
16582 -- A pragma that applies to a Ghost entity becomes Ghost for
16583 -- the purposes of legality checks and removal of ignored
16586 Mark_Pragma_As_Ghost (N, Ent);
16590 when Subprogram_Kind =>
16592 -- Aspect case, entity already set
16594 if From_Aspect_Specification (N) then
16595 Set_Linker_Section_Pragma
16596 (Entity (Corresponding_Aspect (N)), N);
16598 -- Pragma case, we must climb the homonym chain, but skip
16599 -- any for which the linker section is already set.
16603 if No (Linker_Section_Pragma (Ent)) then
16604 Set_Linker_Section_Pragma (Ent, N);
16606 -- A pragma that applies to a Ghost entity becomes
16607 -- Ghost for the purposes of legality checks and
16608 -- removal of ignored Ghost code.
16610 Mark_Pragma_As_Ghost (N, Ent);
16612 -- Capture the entity of the first Ghost subprogram
16613 -- being processed for error detection purposes.
16615 if Is_Ghost_Entity (Ent) then
16616 if No (Ghost_Id) then
16620 -- Otherwise the subprogram is non-Ghost. It is
16621 -- illegal to mix references to Ghost and non-Ghost
16622 -- entities (SPARK RM 6.9).
16624 elsif Present (Ghost_Id)
16625 and then not Ghost_Error_Posted
16627 Ghost_Error_Posted := True;
16629 Error_Msg_Name_1 := Pname;
16631 ("pragma % cannot mention ghost and "
16632 & "non-ghost subprograms", N);
16634 Error_Msg_Sloc := Sloc (Ghost_Id);
16636 ("\& # declared as ghost", N, Ghost_Id);
16638 Error_Msg_Sloc := Sloc (Ent);
16640 ("\& # declared as non-ghost", N, Ent);
16644 Ent := Homonym (Ent);
16646 or else Scope (Ent) /= Current_Scope;
16650 -- All other cases are illegal
16654 ("pragma% applies only to objects, subprograms, and types",
16657 end Linker_Section;
16663 -- pragma List (On | Off)
16665 -- There is nothing to do here, since we did all the processing for
16666 -- this pragma in Par.Prag (so that it works properly even in syntax
16669 when Pragma_List =>
16676 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16678 when Pragma_Lock_Free => Lock_Free : declare
16679 P : constant Node_Id := Parent (N);
16685 Check_No_Identifiers;
16686 Check_At_Most_N_Arguments (1);
16688 -- Protected definition case
16690 if Nkind (P) = N_Protected_Definition then
16691 Ent := Defining_Identifier (Parent (P));
16695 if Arg_Count = 1 then
16696 Arg := Get_Pragma_Arg (Arg1);
16697 Val := Is_True (Static_Boolean (Arg));
16699 -- No arguments (expression is considered to be True)
16705 -- Check duplicate pragma before we chain the pragma in the Rep
16706 -- Item chain of Ent.
16708 Check_Duplicate_Pragma (Ent);
16709 Record_Rep_Item (Ent, N);
16710 Set_Uses_Lock_Free (Ent, Val);
16712 -- Anything else is incorrect placement
16719 --------------------
16720 -- Locking_Policy --
16721 --------------------
16723 -- pragma Locking_Policy (policy_IDENTIFIER);
16725 when Pragma_Locking_Policy => declare
16726 subtype LP_Range is Name_Id
16727 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
16732 Check_Ada_83_Warning;
16733 Check_Arg_Count (1);
16734 Check_No_Identifiers;
16735 Check_Arg_Is_Locking_Policy (Arg1);
16736 Check_Valid_Configuration_Pragma;
16737 LP_Val := Chars (Get_Pragma_Arg (Arg1));
16740 when Name_Ceiling_Locking =>
16742 when Name_Inheritance_Locking =>
16744 when Name_Concurrent_Readers_Locking =>
16748 if Locking_Policy /= ' '
16749 and then Locking_Policy /= LP
16751 Error_Msg_Sloc := Locking_Policy_Sloc;
16752 Error_Pragma ("locking policy incompatible with policy#");
16754 -- Set new policy, but always preserve System_Location since we
16755 -- like the error message with the run time name.
16758 Locking_Policy := LP;
16760 if Locking_Policy_Sloc /= System_Location then
16761 Locking_Policy_Sloc := Loc;
16766 -------------------
16767 -- Loop_Optimize --
16768 -------------------
16770 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16772 -- OPTIMIZATION_HINT ::=
16773 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16775 when Pragma_Loop_Optimize => Loop_Optimize : declare
16780 Check_At_Least_N_Arguments (1);
16781 Check_No_Identifiers;
16783 Hint := First (Pragma_Argument_Associations (N));
16784 while Present (Hint) loop
16785 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
16793 Check_Loop_Pragma_Placement;
16800 -- pragma Loop_Variant
16801 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16803 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16805 -- CHANGE_DIRECTION ::= Increases | Decreases
16807 when Pragma_Loop_Variant => Loop_Variant : declare
16812 Check_At_Least_N_Arguments (1);
16813 Check_Loop_Pragma_Placement;
16815 -- Process all increasing / decreasing expressions
16817 Variant := First (Pragma_Argument_Associations (N));
16818 while Present (Variant) loop
16819 if not Nam_In (Chars (Variant), Name_Decreases,
16822 Error_Pragma_Arg ("wrong change modifier", Variant);
16825 Preanalyze_Assert_Expression
16826 (Expression (Variant), Any_Discrete);
16832 -----------------------
16833 -- Machine_Attribute --
16834 -----------------------
16836 -- pragma Machine_Attribute (
16837 -- [Entity =>] LOCAL_NAME,
16838 -- [Attribute_Name =>] static_string_EXPRESSION
16839 -- [, [Info =>] static_EXPRESSION] );
16841 when Pragma_Machine_Attribute => Machine_Attribute : declare
16842 Def_Id : Entity_Id;
16846 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
16848 if Arg_Count = 3 then
16849 Check_Optional_Identifier (Arg3, Name_Info);
16850 Check_Arg_Is_OK_Static_Expression (Arg3);
16852 Check_Arg_Count (2);
16855 Check_Optional_Identifier (Arg1, Name_Entity);
16856 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
16857 Check_Arg_Is_Local_Name (Arg1);
16858 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16859 Def_Id := Entity (Get_Pragma_Arg (Arg1));
16861 if Is_Access_Type (Def_Id) then
16862 Def_Id := Designated_Type (Def_Id);
16865 if Rep_Item_Too_Early (Def_Id, N) then
16869 Def_Id := Underlying_Type (Def_Id);
16871 -- The only processing required is to link this item on to the
16872 -- list of rep items for the given entity. This is accomplished
16873 -- by the call to Rep_Item_Too_Late (when no error is detected
16874 -- and False is returned).
16876 if Rep_Item_Too_Late (Def_Id, N) then
16879 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16881 end Machine_Attribute;
16888 -- (MAIN_OPTION [, MAIN_OPTION]);
16891 -- [STACK_SIZE =>] static_integer_EXPRESSION
16892 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16893 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16895 when Pragma_Main => Main : declare
16896 Args : Args_List (1 .. 3);
16897 Names : constant Name_List (1 .. 3) := (
16899 Name_Task_Stack_Size_Default,
16900 Name_Time_Slicing_Enabled);
16906 Gather_Associations (Names, Args);
16908 for J in 1 .. 2 loop
16909 if Present (Args (J)) then
16910 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16914 if Present (Args (3)) then
16915 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
16919 while Present (Nod) loop
16920 if Nkind (Nod) = N_Pragma
16921 and then Pragma_Name (Nod) = Name_Main
16923 Error_Msg_Name_1 := Pname;
16924 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16935 -- pragma Main_Storage
16936 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16938 -- MAIN_STORAGE_OPTION ::=
16939 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16940 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16942 when Pragma_Main_Storage => Main_Storage : declare
16943 Args : Args_List (1 .. 2);
16944 Names : constant Name_List (1 .. 2) := (
16945 Name_Working_Storage,
16952 Gather_Associations (Names, Args);
16954 for J in 1 .. 2 loop
16955 if Present (Args (J)) then
16956 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16960 Check_In_Main_Program;
16963 while Present (Nod) loop
16964 if Nkind (Nod) = N_Pragma
16965 and then Pragma_Name (Nod) = Name_Main_Storage
16967 Error_Msg_Name_1 := Pname;
16968 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16979 -- pragma Memory_Size (NUMERIC_LITERAL)
16981 when Pragma_Memory_Size =>
16984 -- Memory size is simply ignored
16986 Check_No_Identifiers;
16987 Check_Arg_Count (1);
16988 Check_Arg_Is_Integer_Literal (Arg1);
16996 -- The only correct use of this pragma is on its own in a file, in
16997 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16998 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16999 -- check for a file containing nothing but a No_Body pragma). If we
17000 -- attempt to process it during normal semantics processing, it means
17001 -- it was misplaced.
17003 when Pragma_No_Body =>
17007 -----------------------------
17008 -- No_Elaboration_Code_All --
17009 -----------------------------
17011 -- pragma No_Elaboration_Code_All;
17013 when Pragma_No_Elaboration_Code_All =>
17015 Check_Valid_Library_Unit_Pragma;
17017 if Nkind (N) = N_Null_Statement then
17021 -- Must appear for a spec or generic spec
17023 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17024 N_Generic_Package_Declaration,
17025 N_Generic_Subprogram_Declaration,
17026 N_Package_Declaration,
17027 N_Subprogram_Declaration)
17031 ("pragma% can only occur for package "
17032 & "or subprogram spec"));
17035 -- Set flag in unit table
17037 Set_No_Elab_Code_All (Current_Sem_Unit);
17039 -- Set restriction No_Elaboration_Code if this is the main unit
17041 if Current_Sem_Unit = Main_Unit then
17042 Set_Restriction (No_Elaboration_Code, N);
17045 -- If we are in the main unit or in an extended main source unit,
17046 -- then we also add it to the configuration restrictions so that
17047 -- it will apply to all units in the extended main source.
17049 if Current_Sem_Unit = Main_Unit
17050 or else In_Extended_Main_Source_Unit (N)
17052 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17055 -- If in main extended unit, activate transitive with test
17057 if In_Extended_Main_Source_Unit (N) then
17058 Opt.No_Elab_Code_All_Pragma := N;
17065 -- pragma No_Inline ( NAME {, NAME} );
17067 when Pragma_No_Inline =>
17069 Process_Inline (Suppressed);
17075 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17077 when Pragma_No_Return => No_Return : declare
17083 Ghost_Error_Posted : Boolean := False;
17084 -- Flag set when an error concerning the illegal mix of Ghost and
17085 -- non-Ghost subprograms is emitted.
17087 Ghost_Id : Entity_Id := Empty;
17088 -- The entity of the first Ghost procedure encountered while
17089 -- processing the arguments of the pragma.
17093 Check_At_Least_N_Arguments (1);
17095 -- Loop through arguments of pragma
17098 while Present (Arg) loop
17099 Check_Arg_Is_Local_Name (Arg);
17100 Id := Get_Pragma_Arg (Arg);
17103 if not Is_Entity_Name (Id) then
17104 Error_Pragma_Arg ("entity name required", Arg);
17107 if Etype (Id) = Any_Type then
17111 -- Loop to find matching procedures
17117 and then Scope (E) = Current_Scope
17119 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17122 -- A pragma that applies to a Ghost entity becomes Ghost
17123 -- for the purposes of legality checks and removal of
17124 -- ignored Ghost code.
17126 Mark_Pragma_As_Ghost (N, E);
17128 -- Capture the entity of the first Ghost procedure being
17129 -- processed for error detection purposes.
17131 if Is_Ghost_Entity (E) then
17132 if No (Ghost_Id) then
17136 -- Otherwise the subprogram is non-Ghost. It is illegal
17137 -- to mix references to Ghost and non-Ghost entities
17140 elsif Present (Ghost_Id)
17141 and then not Ghost_Error_Posted
17143 Ghost_Error_Posted := True;
17145 Error_Msg_Name_1 := Pname;
17147 ("pragma % cannot mention ghost and non-ghost "
17148 & "procedures", N);
17150 Error_Msg_Sloc := Sloc (Ghost_Id);
17151 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17153 Error_Msg_Sloc := Sloc (E);
17154 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17157 -- Set flag on any alias as well
17159 if Is_Overloadable (E) and then Present (Alias (E)) then
17160 Set_No_Return (Alias (E));
17166 exit when From_Aspect_Specification (N);
17170 -- If entity in not in current scope it may be the enclosing
17171 -- suprogram body to which the aspect applies.
17174 if Entity (Id) = Current_Scope
17175 and then From_Aspect_Specification (N)
17177 Set_No_Return (Entity (Id));
17179 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17191 -- pragma No_Run_Time;
17193 -- Note: this pragma is retained for backwards compatibility. See
17194 -- body of Rtsfind for full details on its handling.
17196 when Pragma_No_Run_Time =>
17198 Check_Valid_Configuration_Pragma;
17199 Check_Arg_Count (0);
17201 No_Run_Time_Mode := True;
17202 Configurable_Run_Time_Mode := True;
17204 -- Set Duration to 32 bits if word size is 32
17206 if Ttypes.System_Word_Size = 32 then
17207 Duration_32_Bits_On_Target := True;
17210 -- Set appropriate restrictions
17212 Set_Restriction (No_Finalization, N);
17213 Set_Restriction (No_Exception_Handlers, N);
17214 Set_Restriction (Max_Tasks, N, 0);
17215 Set_Restriction (No_Tasking, N);
17217 -----------------------
17218 -- No_Tagged_Streams --
17219 -----------------------
17221 -- pragma No_Tagged_Streams;
17222 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17224 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17230 Check_At_Most_N_Arguments (1);
17232 -- One argument case
17234 if Arg_Count = 1 then
17235 Check_Optional_Identifier (Arg1, Name_Entity);
17236 Check_Arg_Is_Local_Name (Arg1);
17237 E_Id := Get_Pragma_Arg (Arg1);
17239 if Etype (E_Id) = Any_Type then
17243 E := Entity (E_Id);
17245 Check_Duplicate_Pragma (E);
17247 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17249 ("argument for pragma% must be root tagged type", Arg1);
17252 if Rep_Item_Too_Early (E, N)
17254 Rep_Item_Too_Late (E, N)
17258 Set_No_Tagged_Streams_Pragma (E, N);
17261 -- Zero argument case
17264 Check_Is_In_Decl_Part_Or_Package_Spec;
17265 No_Tagged_Streams := N;
17267 end No_Tagged_Strms;
17269 ------------------------
17270 -- No_Strict_Aliasing --
17271 ------------------------
17273 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17275 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17280 Check_At_Most_N_Arguments (1);
17282 if Arg_Count = 0 then
17283 Check_Valid_Configuration_Pragma;
17284 Opt.No_Strict_Aliasing := True;
17287 Check_Optional_Identifier (Arg2, Name_Entity);
17288 Check_Arg_Is_Local_Name (Arg1);
17289 E_Id := Entity (Get_Pragma_Arg (Arg1));
17291 if E_Id = Any_Type then
17293 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17294 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17297 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17299 end No_Strict_Aliasing;
17301 -----------------------
17302 -- Normalize_Scalars --
17303 -----------------------
17305 -- pragma Normalize_Scalars;
17307 when Pragma_Normalize_Scalars =>
17308 Check_Ada_83_Warning;
17309 Check_Arg_Count (0);
17310 Check_Valid_Configuration_Pragma;
17312 -- Normalize_Scalars creates false positives in CodePeer, and
17313 -- incorrect negative results in GNATprove mode, so ignore this
17314 -- pragma in these modes.
17316 if not (CodePeer_Mode or GNATprove_Mode) then
17317 Normalize_Scalars := True;
17318 Init_Or_Norm_Scalars := True;
17325 -- pragma Obsolescent;
17327 -- pragma Obsolescent (
17328 -- [Message =>] static_string_EXPRESSION
17329 -- [,[Version =>] Ada_05]]);
17331 -- pragma Obsolescent (
17332 -- [Entity =>] NAME
17333 -- [,[Message =>] static_string_EXPRESSION
17334 -- [,[Version =>] Ada_05]] );
17336 when Pragma_Obsolescent => Obsolescent : declare
17340 procedure Set_Obsolescent (E : Entity_Id);
17341 -- Given an entity Ent, mark it as obsolescent if appropriate
17343 ---------------------
17344 -- Set_Obsolescent --
17345 ---------------------
17347 procedure Set_Obsolescent (E : Entity_Id) is
17356 -- A pragma that applies to a Ghost entity becomes Ghost for
17357 -- the purposes of legality checks and removal of ignored Ghost
17360 Mark_Pragma_As_Ghost (N, E);
17362 -- Entity name was given
17364 if Present (Ename) then
17366 -- If entity name matches, we are fine. Save entity in
17367 -- pragma argument, for ASIS use.
17369 if Chars (Ename) = Chars (Ent) then
17370 Set_Entity (Ename, Ent);
17371 Generate_Reference (Ent, Ename);
17373 -- If entity name does not match, only possibility is an
17374 -- enumeration literal from an enumeration type declaration.
17376 elsif Ekind (Ent) /= E_Enumeration_Type then
17378 ("pragma % entity name does not match declaration");
17381 Ent := First_Literal (E);
17385 ("pragma % entity name does not match any "
17386 & "enumeration literal");
17388 elsif Chars (Ent) = Chars (Ename) then
17389 Set_Entity (Ename, Ent);
17390 Generate_Reference (Ent, Ename);
17394 Ent := Next_Literal (Ent);
17400 -- Ent points to entity to be marked
17402 if Arg_Count >= 1 then
17404 -- Deal with static string argument
17406 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17407 S := Strval (Get_Pragma_Arg (Arg1));
17409 for J in 1 .. String_Length (S) loop
17410 if not In_Character_Range (Get_String_Char (S, J)) then
17412 ("pragma% argument does not allow wide characters",
17417 Obsolescent_Warnings.Append
17418 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17420 -- Check for Ada_05 parameter
17422 if Arg_Count /= 1 then
17423 Check_Arg_Count (2);
17426 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17429 Check_Arg_Is_Identifier (Argx);
17431 if Chars (Argx) /= Name_Ada_05 then
17432 Error_Msg_Name_2 := Name_Ada_05;
17434 ("only allowed argument for pragma% is %", Argx);
17437 if Ada_Version_Explicit < Ada_2005
17438 or else not Warn_On_Ada_2005_Compatibility
17446 -- Set flag if pragma active
17449 Set_Is_Obsolescent (Ent);
17453 end Set_Obsolescent;
17455 -- Start of processing for pragma Obsolescent
17460 Check_At_Most_N_Arguments (3);
17462 -- See if first argument specifies an entity name
17466 (Chars (Arg1) = Name_Entity
17468 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17470 N_Operator_Symbol))
17472 Ename := Get_Pragma_Arg (Arg1);
17474 -- Eliminate first argument, so we can share processing
17478 Arg_Count := Arg_Count - 1;
17480 -- No Entity name argument given
17486 if Arg_Count >= 1 then
17487 Check_Optional_Identifier (Arg1, Name_Message);
17489 if Arg_Count = 2 then
17490 Check_Optional_Identifier (Arg2, Name_Version);
17494 -- Get immediately preceding declaration
17497 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17501 -- Cases where we do not follow anything other than another pragma
17505 -- First case: library level compilation unit declaration with
17506 -- the pragma immediately following the declaration.
17508 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17510 (Defining_Entity (Unit (Parent (Parent (N)))));
17513 -- Case 2: library unit placement for package
17517 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17519 if Is_Package_Or_Generic_Package (Ent) then
17520 Set_Obsolescent (Ent);
17526 -- Cases where we must follow a declaration, including an
17527 -- abstract subprogram declaration, which is not in the
17528 -- other node subtypes.
17531 if Nkind (Decl) not in N_Declaration
17532 and then Nkind (Decl) not in N_Later_Decl_Item
17533 and then Nkind (Decl) not in N_Generic_Declaration
17534 and then Nkind (Decl) not in N_Renaming_Declaration
17535 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
17538 ("pragma% misplaced, "
17539 & "must immediately follow a declaration");
17542 Set_Obsolescent (Defining_Entity (Decl));
17552 -- pragma Optimize (Time | Space | Off);
17554 -- The actual check for optimize is done in Gigi. Note that this
17555 -- pragma does not actually change the optimization setting, it
17556 -- simply checks that it is consistent with the pragma.
17558 when Pragma_Optimize =>
17559 Check_No_Identifiers;
17560 Check_Arg_Count (1);
17561 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17563 ------------------------
17564 -- Optimize_Alignment --
17565 ------------------------
17567 -- pragma Optimize_Alignment (Time | Space | Off);
17569 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17571 Check_No_Identifiers;
17572 Check_Arg_Count (1);
17573 Check_Valid_Configuration_Pragma;
17576 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17580 Opt.Optimize_Alignment := 'T';
17582 Opt.Optimize_Alignment := 'S';
17584 Opt.Optimize_Alignment := 'O';
17586 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17590 -- Set indication that mode is set locally. If we are in fact in a
17591 -- configuration pragma file, this setting is harmless since the
17592 -- switch will get reset anyway at the start of each unit.
17594 Optimize_Alignment_Local := True;
17595 end Optimize_Alignment;
17601 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17603 when Pragma_Ordered => Ordered : declare
17604 Assoc : constant Node_Id := Arg1;
17610 Check_No_Identifiers;
17611 Check_Arg_Count (1);
17612 Check_Arg_Is_Local_Name (Arg1);
17614 Type_Id := Get_Pragma_Arg (Assoc);
17615 Find_Type (Type_Id);
17616 Typ := Entity (Type_Id);
17618 if Typ = Any_Type then
17621 Typ := Underlying_Type (Typ);
17624 if not Is_Enumeration_Type (Typ) then
17625 Error_Pragma ("pragma% must specify enumeration type");
17628 Check_First_Subtype (Arg1);
17629 Set_Has_Pragma_Ordered (Base_Type (Typ));
17632 -------------------
17633 -- Overflow_Mode --
17634 -------------------
17636 -- pragma Overflow_Mode
17637 -- ([General => ] MODE [, [Assertions => ] MODE]);
17639 -- MODE := STRICT | MINIMIZED | ELIMINATED
17641 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17642 -- since System.Bignums makes this assumption. This is true of nearly
17643 -- all (all?) targets.
17645 when Pragma_Overflow_Mode => Overflow_Mode : declare
17646 function Get_Overflow_Mode
17648 Arg : Node_Id) return Overflow_Mode_Type;
17649 -- Function to process one pragma argument, Arg. If an identifier
17650 -- is present, it must be Name. Mode type is returned if a valid
17651 -- argument exists, otherwise an error is signalled.
17653 -----------------------
17654 -- Get_Overflow_Mode --
17655 -----------------------
17657 function Get_Overflow_Mode
17659 Arg : Node_Id) return Overflow_Mode_Type
17661 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
17664 Check_Optional_Identifier (Arg, Name);
17665 Check_Arg_Is_Identifier (Argx);
17667 if Chars (Argx) = Name_Strict then
17670 elsif Chars (Argx) = Name_Minimized then
17673 elsif Chars (Argx) = Name_Eliminated then
17674 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
17676 ("Eliminated not implemented on this target", Argx);
17682 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
17684 end Get_Overflow_Mode;
17686 -- Start of processing for Overflow_Mode
17690 Check_At_Least_N_Arguments (1);
17691 Check_At_Most_N_Arguments (2);
17693 -- Process first argument
17695 Scope_Suppress.Overflow_Mode_General :=
17696 Get_Overflow_Mode (Name_General, Arg1);
17698 -- Case of only one argument
17700 if Arg_Count = 1 then
17701 Scope_Suppress.Overflow_Mode_Assertions :=
17702 Scope_Suppress.Overflow_Mode_General;
17704 -- Case of two arguments present
17707 Scope_Suppress.Overflow_Mode_Assertions :=
17708 Get_Overflow_Mode (Name_Assertions, Arg2);
17712 --------------------------
17713 -- Overriding Renamings --
17714 --------------------------
17716 -- pragma Overriding_Renamings;
17718 when Pragma_Overriding_Renamings =>
17720 Check_Arg_Count (0);
17721 Check_Valid_Configuration_Pragma;
17722 Overriding_Renamings := True;
17728 -- pragma Pack (first_subtype_LOCAL_NAME);
17730 when Pragma_Pack => Pack : declare
17731 Assoc : constant Node_Id := Arg1;
17733 Ignore : Boolean := False;
17738 Check_No_Identifiers;
17739 Check_Arg_Count (1);
17740 Check_Arg_Is_Local_Name (Arg1);
17741 Type_Id := Get_Pragma_Arg (Assoc);
17743 if not Is_Entity_Name (Type_Id)
17744 or else not Is_Type (Entity (Type_Id))
17747 ("argument for pragma% must be type or subtype", Arg1);
17750 Find_Type (Type_Id);
17751 Typ := Entity (Type_Id);
17754 or else Rep_Item_Too_Early (Typ, N)
17758 Typ := Underlying_Type (Typ);
17761 -- A pragma that applies to a Ghost entity becomes Ghost for the
17762 -- purposes of legality checks and removal of ignored Ghost code.
17764 Mark_Pragma_As_Ghost (N, Typ);
17766 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
17767 Error_Pragma ("pragma% must specify array or record type");
17770 Check_First_Subtype (Arg1);
17771 Check_Duplicate_Pragma (Typ);
17775 if Is_Array_Type (Typ) then
17776 Ctyp := Component_Type (Typ);
17778 -- Ignore pack that does nothing
17780 if Known_Static_Esize (Ctyp)
17781 and then Known_Static_RM_Size (Ctyp)
17782 and then Esize (Ctyp) = RM_Size (Ctyp)
17783 and then Addressable (Esize (Ctyp))
17788 -- Process OK pragma Pack. Note that if there is a separate
17789 -- component clause present, the Pack will be cancelled. This
17790 -- processing is in Freeze.
17792 if not Rep_Item_Too_Late (Typ, N) then
17794 -- In CodePeer mode, we do not need complex front-end
17795 -- expansions related to pragma Pack, so disable handling
17798 if CodePeer_Mode then
17801 -- Normal case where we do the pack action
17805 Set_Is_Packed (Base_Type (Typ));
17806 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17809 Set_Has_Pragma_Pack (Base_Type (Typ));
17813 -- For record types, the pack is always effective
17815 else pragma Assert (Is_Record_Type (Typ));
17816 if not Rep_Item_Too_Late (Typ, N) then
17817 Set_Is_Packed (Base_Type (Typ));
17818 Set_Has_Pragma_Pack (Base_Type (Typ));
17819 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17830 -- There is nothing to do here, since we did all the processing for
17831 -- this pragma in Par.Prag (so that it works properly even in syntax
17834 when Pragma_Page =>
17841 -- pragma Part_Of (ABSTRACT_STATE);
17843 -- ABSTRACT_STATE ::= NAME
17845 when Pragma_Part_Of => Part_Of : declare
17846 procedure Propagate_Part_Of
17847 (Pack_Id : Entity_Id;
17848 State_Id : Entity_Id;
17849 Instance : Node_Id);
17850 -- Propagate the Part_Of indicator to all abstract states and
17851 -- objects declared in the visible state space of a package
17852 -- denoted by Pack_Id. State_Id is the encapsulating state.
17853 -- Instance is the package instantiation node.
17855 -----------------------
17856 -- Propagate_Part_Of --
17857 -----------------------
17859 procedure Propagate_Part_Of
17860 (Pack_Id : Entity_Id;
17861 State_Id : Entity_Id;
17862 Instance : Node_Id)
17864 Has_Item : Boolean := False;
17865 -- Flag set when the visible state space contains at least one
17866 -- abstract state or variable.
17868 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
17869 -- Propagate the Part_Of indicator to all abstract states and
17870 -- objects declared in the visible state space of a package
17871 -- denoted by Pack_Id.
17873 -----------------------
17874 -- Propagate_Part_Of --
17875 -----------------------
17877 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
17878 Item_Id : Entity_Id;
17881 -- Traverse the entity chain of the package and set relevant
17882 -- attributes of abstract states and objects declared in the
17883 -- visible state space of the package.
17885 Item_Id := First_Entity (Pack_Id);
17886 while Present (Item_Id)
17887 and then not In_Private_Part (Item_Id)
17889 -- Do not consider internally generated items
17891 if not Comes_From_Source (Item_Id) then
17894 -- The Part_Of indicator turns an abstract state or an
17895 -- object into a constituent of the encapsulating state.
17897 elsif Ekind_In (Item_Id, E_Abstract_State,
17903 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17904 Set_Encapsulating_State (Item_Id, State_Id);
17906 -- Recursively handle nested packages and instantiations
17908 elsif Ekind (Item_Id) = E_Package then
17909 Propagate_Part_Of (Item_Id);
17912 Next_Entity (Item_Id);
17914 end Propagate_Part_Of;
17916 -- Start of processing for Propagate_Part_Of
17919 Propagate_Part_Of (Pack_Id);
17921 -- Detect a package instantiation that is subject to a Part_Of
17922 -- indicator, but has no visible state.
17924 if not Has_Item then
17926 ("package instantiation & has Part_Of indicator but "
17927 & "lacks visible state", Instance, Pack_Id);
17929 end Propagate_Part_Of;
17934 Encap_Id : Entity_Id;
17935 Item_Id : Entity_Id;
17939 -- Start of processing for Part_Of
17943 Check_No_Identifiers;
17944 Check_Arg_Count (1);
17946 Stmt := Find_Related_Context (N, Do_Checks => True);
17948 -- Object declaration
17950 if Nkind (Stmt) = N_Object_Declaration then
17953 -- Package instantiation
17955 elsif Nkind (Stmt) = N_Package_Instantiation then
17958 -- Single concurrent type declaration
17960 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
17963 -- Otherwise the pragma is associated with an illegal construct
17970 -- Extract the entity of the related object declaration or package
17971 -- instantiation. In the case of the instantiation, use the entity
17972 -- of the instance spec.
17974 if Nkind (Stmt) = N_Package_Instantiation then
17975 Stmt := Instance_Spec (Stmt);
17978 Item_Id := Defining_Entity (Stmt);
17979 Encap := Get_Pragma_Arg (Arg1);
17981 -- A pragma that applies to a Ghost entity becomes Ghost for the
17982 -- purposes of legality checks and removal of ignored Ghost code.
17984 Mark_Pragma_As_Ghost (N, Item_Id);
17986 -- Chain the pragma on the contract for further processing by
17987 -- Analyze_Part_Of_In_Decl_Part or for completeness.
17989 Add_Contract_Item (N, Item_Id);
17991 -- A variable may act as consituent of a single concurrent type
17992 -- which in turn could be declared after the variable. Due to this
17993 -- discrepancy, the full analysis of indicator Part_Of is delayed
17994 -- until the end of the enclosing declarative region (see routine
17995 -- Analyze_Part_Of_In_Decl_Part).
17997 if Ekind (Item_Id) = E_Variable then
18000 -- Otherwise indicator Part_Of applies to a constant or a package
18004 -- Detect any discrepancies between the placement of the
18005 -- constant or package instantiation with respect to state
18006 -- space and the encapsulating state.
18010 Item_Id => Item_Id,
18012 Encap_Id => Encap_Id,
18016 pragma Assert (Present (Encap_Id));
18018 if Ekind (Item_Id) = E_Constant then
18019 Append_Elmt (Item_Id, Part_Of_Constituents (Encap_Id));
18020 Set_Encapsulating_State (Item_Id, Encap_Id);
18022 -- Propagate the Part_Of indicator to the visible state
18023 -- space of the package instantiation.
18027 (Pack_Id => Item_Id,
18028 State_Id => Encap_Id,
18035 ----------------------------------
18036 -- Partition_Elaboration_Policy --
18037 ----------------------------------
18039 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18041 when Pragma_Partition_Elaboration_Policy => declare
18042 subtype PEP_Range is Name_Id
18043 range First_Partition_Elaboration_Policy_Name
18044 .. Last_Partition_Elaboration_Policy_Name;
18045 PEP_Val : PEP_Range;
18050 Check_Arg_Count (1);
18051 Check_No_Identifiers;
18052 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18053 Check_Valid_Configuration_Pragma;
18054 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18057 when Name_Concurrent =>
18059 when Name_Sequential =>
18063 if Partition_Elaboration_Policy /= ' '
18064 and then Partition_Elaboration_Policy /= PEP
18066 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18068 ("partition elaboration policy incompatible with policy#");
18070 -- Set new policy, but always preserve System_Location since we
18071 -- like the error message with the run time name.
18074 Partition_Elaboration_Policy := PEP;
18076 if Partition_Elaboration_Policy_Sloc /= System_Location then
18077 Partition_Elaboration_Policy_Sloc := Loc;
18086 -- pragma Passive [(PASSIVE_FORM)];
18088 -- PASSIVE_FORM ::= Semaphore | No
18090 when Pragma_Passive =>
18093 if Nkind (Parent (N)) /= N_Task_Definition then
18094 Error_Pragma ("pragma% must be within task definition");
18097 if Arg_Count /= 0 then
18098 Check_Arg_Count (1);
18099 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18102 ----------------------------------
18103 -- Preelaborable_Initialization --
18104 ----------------------------------
18106 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18108 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18113 Check_Arg_Count (1);
18114 Check_No_Identifiers;
18115 Check_Arg_Is_Identifier (Arg1);
18116 Check_Arg_Is_Local_Name (Arg1);
18117 Check_First_Subtype (Arg1);
18118 Ent := Entity (Get_Pragma_Arg (Arg1));
18120 -- A pragma that applies to a Ghost entity becomes Ghost for the
18121 -- purposes of legality checks and removal of ignored Ghost code.
18123 Mark_Pragma_As_Ghost (N, Ent);
18125 -- The pragma may come from an aspect on a private declaration,
18126 -- even if the freeze point at which this is analyzed in the
18127 -- private part after the full view.
18129 if Has_Private_Declaration (Ent)
18130 and then From_Aspect_Specification (N)
18134 -- Check appropriate type argument
18136 elsif Is_Private_Type (Ent)
18137 or else Is_Protected_Type (Ent)
18138 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18140 -- AI05-0028: The pragma applies to all composite types. Note
18141 -- that we apply this binding interpretation to earlier versions
18142 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18143 -- choice since there are other compilers that do the same.
18145 or else Is_Composite_Type (Ent)
18151 ("pragma % can only be applied to private, formal derived, "
18152 & "protected, or composite type", Arg1);
18155 -- Give an error if the pragma is applied to a protected type that
18156 -- does not qualify (due to having entries, or due to components
18157 -- that do not qualify).
18159 if Is_Protected_Type (Ent)
18160 and then not Has_Preelaborable_Initialization (Ent)
18163 ("protected type & does not have preelaborable "
18164 & "initialization", Ent);
18166 -- Otherwise mark the type as definitely having preelaborable
18170 Set_Known_To_Have_Preelab_Init (Ent);
18173 if Has_Pragma_Preelab_Init (Ent)
18174 and then Warn_On_Redundant_Constructs
18176 Error_Pragma ("?r?duplicate pragma%!");
18178 Set_Has_Pragma_Preelab_Init (Ent);
18182 --------------------
18183 -- Persistent_BSS --
18184 --------------------
18186 -- pragma Persistent_BSS [(object_NAME)];
18188 when Pragma_Persistent_BSS => Persistent_BSS : declare
18195 Check_At_Most_N_Arguments (1);
18197 -- Case of application to specific object (one argument)
18199 if Arg_Count = 1 then
18200 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18202 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18204 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18207 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18210 Ent := Entity (Get_Pragma_Arg (Arg1));
18211 Decl := Parent (Ent);
18213 -- A pragma that applies to a Ghost entity becomes Ghost for
18214 -- the purposes of legality checks and removal of ignored Ghost
18217 Mark_Pragma_As_Ghost (N, Ent);
18219 -- Check for duplication before inserting in list of
18220 -- representation items.
18222 Check_Duplicate_Pragma (Ent);
18224 if Rep_Item_Too_Late (Ent, N) then
18228 if Present (Expression (Decl)) then
18230 ("object for pragma% cannot have initialization", Arg1);
18233 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18235 ("object type for pragma% is not potentially persistent",
18240 Make_Linker_Section_Pragma
18241 (Ent, Sloc (N), ".persistent.bss");
18242 Insert_After (N, Prag);
18245 -- Case of use as configuration pragma with no arguments
18248 Check_Valid_Configuration_Pragma;
18249 Persistent_BSS_Mode := True;
18251 end Persistent_BSS;
18257 -- pragma Polling (ON | OFF);
18259 when Pragma_Polling =>
18261 Check_Arg_Count (1);
18262 Check_No_Identifiers;
18263 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18264 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18266 -----------------------------------
18267 -- Post/Post_Class/Postcondition --
18268 -----------------------------------
18270 -- pragma Post (Boolean_EXPRESSION);
18271 -- pragma Post_Class (Boolean_EXPRESSION);
18272 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18273 -- [,[Message =>] String_EXPRESSION]);
18275 -- Characteristics:
18277 -- * Analysis - The annotation undergoes initial checks to verify
18278 -- the legal placement and context. Secondary checks preanalyze the
18281 -- Analyze_Pre_Post_Condition_In_Decl_Part
18283 -- * Expansion - The annotation is expanded during the expansion of
18284 -- the related subprogram [body] contract as performed in:
18286 -- Expand_Subprogram_Contract
18288 -- * Template - The annotation utilizes the generic template of the
18289 -- related subprogram [body] when it is:
18291 -- aspect on subprogram declaration
18292 -- aspect on stand alone subprogram body
18293 -- pragma on stand alone subprogram body
18295 -- The annotation must prepare its own template when it is:
18297 -- pragma on subprogram declaration
18299 -- * Globals - Capture of global references must occur after full
18302 -- * Instance - The annotation is instantiated automatically when
18303 -- the related generic subprogram [body] is instantiated except for
18304 -- the "pragma on subprogram declaration" case. In that scenario
18305 -- the annotation must instantiate itself.
18308 Pragma_Post_Class |
18309 Pragma_Postcondition =>
18310 Analyze_Pre_Post_Condition;
18312 --------------------------------
18313 -- Pre/Pre_Class/Precondition --
18314 --------------------------------
18316 -- pragma Pre (Boolean_EXPRESSION);
18317 -- pragma Pre_Class (Boolean_EXPRESSION);
18318 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18319 -- [,[Message =>] String_EXPRESSION]);
18321 -- Characteristics:
18323 -- * Analysis - The annotation undergoes initial checks to verify
18324 -- the legal placement and context. Secondary checks preanalyze the
18327 -- Analyze_Pre_Post_Condition_In_Decl_Part
18329 -- * Expansion - The annotation is expanded during the expansion of
18330 -- the related subprogram [body] contract as performed in:
18332 -- Expand_Subprogram_Contract
18334 -- * Template - The annotation utilizes the generic template of the
18335 -- related subprogram [body] when it is:
18337 -- aspect on subprogram declaration
18338 -- aspect on stand alone subprogram body
18339 -- pragma on stand alone subprogram body
18341 -- The annotation must prepare its own template when it is:
18343 -- pragma on subprogram declaration
18345 -- * Globals - Capture of global references must occur after full
18348 -- * Instance - The annotation is instantiated automatically when
18349 -- the related generic subprogram [body] is instantiated except for
18350 -- the "pragma on subprogram declaration" case. In that scenario
18351 -- the annotation must instantiate itself.
18355 Pragma_Precondition =>
18356 Analyze_Pre_Post_Condition;
18362 -- pragma Predicate
18363 -- ([Entity =>] type_LOCAL_NAME,
18364 -- [Check =>] boolean_EXPRESSION);
18366 when Pragma_Predicate => Predicate : declare
18373 Check_Arg_Count (2);
18374 Check_Optional_Identifier (Arg1, Name_Entity);
18375 Check_Optional_Identifier (Arg2, Name_Check);
18377 Check_Arg_Is_Local_Name (Arg1);
18379 Type_Id := Get_Pragma_Arg (Arg1);
18380 Find_Type (Type_Id);
18381 Typ := Entity (Type_Id);
18383 if Typ = Any_Type then
18387 -- A pragma that applies to a Ghost entity becomes Ghost for the
18388 -- purposes of legality checks and removal of ignored Ghost code.
18390 Mark_Pragma_As_Ghost (N, Typ);
18392 -- The remaining processing is simply to link the pragma on to
18393 -- the rep item chain, for processing when the type is frozen.
18394 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18395 -- mark the type as having predicates.
18397 Set_Has_Predicates (Typ);
18398 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18401 -----------------------
18402 -- Predicate_Failure --
18403 -----------------------
18405 -- pragma Predicate_Failure
18406 -- ([Entity =>] type_LOCAL_NAME,
18407 -- [Message =>] string_EXPRESSION);
18409 when Pragma_Predicate_Failure => Predicate_Failure : declare
18416 Check_Arg_Count (2);
18417 Check_Optional_Identifier (Arg1, Name_Entity);
18418 Check_Optional_Identifier (Arg2, Name_Message);
18420 Check_Arg_Is_Local_Name (Arg1);
18422 Type_Id := Get_Pragma_Arg (Arg1);
18423 Find_Type (Type_Id);
18424 Typ := Entity (Type_Id);
18426 if Typ = Any_Type then
18430 -- A pragma that applies to a Ghost entity becomes Ghost for the
18431 -- purposes of legality checks and removal of ignored Ghost code.
18433 Mark_Pragma_As_Ghost (N, Typ);
18435 -- The remaining processing is simply to link the pragma on to
18436 -- the rep item chain, for processing when the type is frozen.
18437 -- This is accomplished by a call to Rep_Item_Too_Late.
18439 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18440 end Predicate_Failure;
18446 -- pragma Preelaborate [(library_unit_NAME)];
18448 -- Set the flag Is_Preelaborated of program unit name entity
18450 when Pragma_Preelaborate => Preelaborate : declare
18451 Pa : constant Node_Id := Parent (N);
18452 Pk : constant Node_Kind := Nkind (Pa);
18456 Check_Ada_83_Warning;
18457 Check_Valid_Library_Unit_Pragma;
18459 if Nkind (N) = N_Null_Statement then
18463 Ent := Find_Lib_Unit_Name;
18465 -- A pragma that applies to a Ghost entity becomes Ghost for the
18466 -- purposes of legality checks and removal of ignored Ghost code.
18468 Mark_Pragma_As_Ghost (N, Ent);
18469 Check_Duplicate_Pragma (Ent);
18471 -- This filters out pragmas inside generic parents that show up
18472 -- inside instantiations. Pragmas that come from aspects in the
18473 -- unit are not ignored.
18475 if Present (Ent) then
18476 if Pk = N_Package_Specification
18477 and then Present (Generic_Parent (Pa))
18478 and then not From_Aspect_Specification (N)
18483 if not Debug_Flag_U then
18484 Set_Is_Preelaborated (Ent);
18485 Set_Suppress_Elaboration_Warnings (Ent);
18491 -------------------------------
18492 -- Prefix_Exception_Messages --
18493 -------------------------------
18495 -- pragma Prefix_Exception_Messages;
18497 when Pragma_Prefix_Exception_Messages =>
18499 Check_Valid_Configuration_Pragma;
18500 Check_Arg_Count (0);
18501 Prefix_Exception_Messages := True;
18507 -- pragma Priority (EXPRESSION);
18509 when Pragma_Priority => Priority : declare
18510 P : constant Node_Id := Parent (N);
18515 Check_No_Identifiers;
18516 Check_Arg_Count (1);
18520 if Nkind (P) = N_Subprogram_Body then
18521 Check_In_Main_Program;
18523 Ent := Defining_Unit_Name (Specification (P));
18525 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18526 Ent := Defining_Identifier (Ent);
18529 Arg := Get_Pragma_Arg (Arg1);
18530 Analyze_And_Resolve (Arg, Standard_Integer);
18534 if not Is_OK_Static_Expression (Arg) then
18535 Flag_Non_Static_Expr
18536 ("main subprogram priority is not static!", Arg);
18539 -- If constraint error, then we already signalled an error
18541 elsif Raises_Constraint_Error (Arg) then
18544 -- Otherwise check in range except if Relaxed_RM_Semantics
18545 -- where we ignore the value if out of range.
18549 Val : constant Uint := Expr_Value (Arg);
18551 if not Relaxed_RM_Semantics
18554 or else Val > Expr_Value (Expression
18555 (Parent (RTE (RE_Max_Priority)))))
18558 ("main subprogram priority is out of range", Arg1);
18561 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18566 -- Load an arbitrary entity from System.Tasking.Stages or
18567 -- System.Tasking.Restricted.Stages (depending on the
18568 -- supported profile) to make sure that one of these packages
18569 -- is implicitly with'ed, since we need to have the tasking
18570 -- run time active for the pragma Priority to have any effect.
18571 -- Previously we with'ed the package System.Tasking, but this
18572 -- package does not trigger the required initialization of the
18573 -- run-time library.
18576 Discard : Entity_Id;
18577 pragma Warnings (Off, Discard);
18579 if Restricted_Profile then
18580 Discard := RTE (RE_Activate_Restricted_Tasks);
18582 Discard := RTE (RE_Activate_Tasks);
18586 -- Task or Protected, must be of type Integer
18588 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18589 Arg := Get_Pragma_Arg (Arg1);
18590 Ent := Defining_Identifier (Parent (P));
18592 -- The expression must be analyzed in the special manner
18593 -- described in "Handling of Default and Per-Object
18594 -- Expressions" in sem.ads.
18596 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18598 if not Is_OK_Static_Expression (Arg) then
18599 Check_Restriction (Static_Priorities, Arg);
18602 -- Anything else is incorrect
18608 -- Check duplicate pragma before we chain the pragma in the Rep
18609 -- Item chain of Ent.
18611 Check_Duplicate_Pragma (Ent);
18612 Record_Rep_Item (Ent, N);
18615 -----------------------------------
18616 -- Priority_Specific_Dispatching --
18617 -----------------------------------
18619 -- pragma Priority_Specific_Dispatching (
18620 -- policy_IDENTIFIER,
18621 -- first_priority_EXPRESSION,
18622 -- last_priority_EXPRESSION);
18624 when Pragma_Priority_Specific_Dispatching =>
18625 Priority_Specific_Dispatching : declare
18626 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18627 -- This is the entity System.Any_Priority;
18630 Lower_Bound : Node_Id;
18631 Upper_Bound : Node_Id;
18637 Check_Arg_Count (3);
18638 Check_No_Identifiers;
18639 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18640 Check_Valid_Configuration_Pragma;
18641 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18642 DP := Fold_Upper (Name_Buffer (1));
18644 Lower_Bound := Get_Pragma_Arg (Arg2);
18645 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
18646 Lower_Val := Expr_Value (Lower_Bound);
18648 Upper_Bound := Get_Pragma_Arg (Arg3);
18649 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
18650 Upper_Val := Expr_Value (Upper_Bound);
18652 -- It is not allowed to use Task_Dispatching_Policy and
18653 -- Priority_Specific_Dispatching in the same partition.
18655 if Task_Dispatching_Policy /= ' ' then
18656 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18658 ("pragma% incompatible with Task_Dispatching_Policy#");
18660 -- Check lower bound in range
18662 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18664 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
18667 ("first_priority is out of range", Arg2);
18669 -- Check upper bound in range
18671 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18673 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
18676 ("last_priority is out of range", Arg3);
18678 -- Check that the priority range is valid
18680 elsif Lower_Val > Upper_Val then
18682 ("last_priority_expression must be greater than or equal to "
18683 & "first_priority_expression");
18685 -- Store the new policy, but always preserve System_Location since
18686 -- we like the error message with the run-time name.
18689 -- Check overlapping in the priority ranges specified in other
18690 -- Priority_Specific_Dispatching pragmas within the same
18691 -- partition. We can only check those we know about.
18694 Specific_Dispatching.First .. Specific_Dispatching.Last
18696 if Specific_Dispatching.Table (J).First_Priority in
18697 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18698 or else Specific_Dispatching.Table (J).Last_Priority in
18699 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18702 Specific_Dispatching.Table (J).Pragma_Loc;
18704 ("priority range overlaps with "
18705 & "Priority_Specific_Dispatching#");
18709 -- The use of Priority_Specific_Dispatching is incompatible
18710 -- with Task_Dispatching_Policy.
18712 if Task_Dispatching_Policy /= ' ' then
18713 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18715 ("Priority_Specific_Dispatching incompatible "
18716 & "with Task_Dispatching_Policy#");
18719 -- The use of Priority_Specific_Dispatching forces ceiling
18722 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
18723 Error_Msg_Sloc := Locking_Policy_Sloc;
18725 ("Priority_Specific_Dispatching incompatible "
18726 & "with Locking_Policy#");
18728 -- Set the Ceiling_Locking policy, but preserve System_Location
18729 -- since we like the error message with the run time name.
18732 Locking_Policy := 'C';
18734 if Locking_Policy_Sloc /= System_Location then
18735 Locking_Policy_Sloc := Loc;
18739 -- Add entry in the table
18741 Specific_Dispatching.Append
18742 ((Dispatching_Policy => DP,
18743 First_Priority => UI_To_Int (Lower_Val),
18744 Last_Priority => UI_To_Int (Upper_Val),
18745 Pragma_Loc => Loc));
18747 end Priority_Specific_Dispatching;
18753 -- pragma Profile (profile_IDENTIFIER);
18755 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18757 when Pragma_Profile =>
18759 Check_Arg_Count (1);
18760 Check_Valid_Configuration_Pragma;
18761 Check_No_Identifiers;
18764 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18767 if Chars (Argx) = Name_Ravenscar then
18768 Set_Ravenscar_Profile (N);
18770 elsif Chars (Argx) = Name_Restricted then
18771 Set_Profile_Restrictions
18773 N, Warn => Treat_Restrictions_As_Warnings);
18775 elsif Chars (Argx) = Name_Rational then
18776 Set_Rational_Profile;
18778 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18779 Set_Profile_Restrictions
18780 (No_Implementation_Extensions,
18781 N, Warn => Treat_Restrictions_As_Warnings);
18784 Error_Pragma_Arg ("& is not a valid profile", Argx);
18788 ----------------------
18789 -- Profile_Warnings --
18790 ----------------------
18792 -- pragma Profile_Warnings (profile_IDENTIFIER);
18794 -- profile_IDENTIFIER => Restricted | Ravenscar
18796 when Pragma_Profile_Warnings =>
18798 Check_Arg_Count (1);
18799 Check_Valid_Configuration_Pragma;
18800 Check_No_Identifiers;
18803 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18806 if Chars (Argx) = Name_Ravenscar then
18807 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
18809 elsif Chars (Argx) = Name_Restricted then
18810 Set_Profile_Restrictions (Restricted, N, Warn => True);
18812 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18813 Set_Profile_Restrictions
18814 (No_Implementation_Extensions, N, Warn => True);
18817 Error_Pragma_Arg ("& is not a valid profile", Argx);
18821 --------------------------
18822 -- Propagate_Exceptions --
18823 --------------------------
18825 -- pragma Propagate_Exceptions;
18827 -- Note: this pragma is obsolete and has no effect
18829 when Pragma_Propagate_Exceptions =>
18831 Check_Arg_Count (0);
18833 if Warn_On_Obsolescent_Feature then
18835 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18836 "and has no effect?j?", N);
18839 -----------------------------
18840 -- Provide_Shift_Operators --
18841 -----------------------------
18843 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18845 when Pragma_Provide_Shift_Operators =>
18846 Provide_Shift_Operators : declare
18849 procedure Declare_Shift_Operator (Nam : Name_Id);
18850 -- Insert declaration and pragma Instrinsic for named shift op
18852 ----------------------------
18853 -- Declare_Shift_Operator --
18854 ----------------------------
18856 procedure Declare_Shift_Operator (Nam : Name_Id) is
18862 Make_Subprogram_Declaration (Loc,
18863 Make_Function_Specification (Loc,
18864 Defining_Unit_Name =>
18865 Make_Defining_Identifier (Loc, Chars => Nam),
18867 Result_Definition =>
18868 Make_Identifier (Loc, Chars => Chars (Ent)),
18870 Parameter_Specifications => New_List (
18871 Make_Parameter_Specification (Loc,
18872 Defining_Identifier =>
18873 Make_Defining_Identifier (Loc, Name_Value),
18875 Make_Identifier (Loc, Chars => Chars (Ent))),
18877 Make_Parameter_Specification (Loc,
18878 Defining_Identifier =>
18879 Make_Defining_Identifier (Loc, Name_Amount),
18881 New_Occurrence_Of (Standard_Natural, Loc)))));
18885 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
18886 Pragma_Argument_Associations => New_List (
18887 Make_Pragma_Argument_Association (Loc,
18888 Expression => Make_Identifier (Loc, Name_Intrinsic)),
18889 Make_Pragma_Argument_Association (Loc,
18890 Expression => Make_Identifier (Loc, Nam))));
18892 Insert_After (N, Import);
18893 Insert_After (N, Func);
18894 end Declare_Shift_Operator;
18896 -- Start of processing for Provide_Shift_Operators
18900 Check_Arg_Count (1);
18901 Check_Arg_Is_Local_Name (Arg1);
18903 Arg1 := Get_Pragma_Arg (Arg1);
18905 -- We must have an entity name
18907 if not Is_Entity_Name (Arg1) then
18909 ("pragma % must apply to integer first subtype", Arg1);
18912 -- If no Entity, means there was a prior error so ignore
18914 if Present (Entity (Arg1)) then
18915 Ent := Entity (Arg1);
18917 -- Apply error checks
18919 if not Is_First_Subtype (Ent) then
18921 ("cannot apply pragma %",
18922 "\& is not a first subtype",
18925 elsif not Is_Integer_Type (Ent) then
18927 ("cannot apply pragma %",
18928 "\& is not an integer type",
18931 elsif Has_Shift_Operator (Ent) then
18933 ("cannot apply pragma %",
18934 "\& already has declared shift operators",
18937 elsif Is_Frozen (Ent) then
18939 ("pragma % appears too late",
18940 "\& is already frozen",
18944 -- Now declare the operators. We do this during analysis rather
18945 -- than expansion, since we want the operators available if we
18946 -- are operating in -gnatc or ASIS mode.
18948 Declare_Shift_Operator (Name_Rotate_Left);
18949 Declare_Shift_Operator (Name_Rotate_Right);
18950 Declare_Shift_Operator (Name_Shift_Left);
18951 Declare_Shift_Operator (Name_Shift_Right);
18952 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
18954 end Provide_Shift_Operators;
18960 -- pragma Psect_Object (
18961 -- [Internal =>] LOCAL_NAME,
18962 -- [, [External =>] EXTERNAL_SYMBOL]
18963 -- [, [Size =>] EXTERNAL_SYMBOL]);
18965 when Pragma_Psect_Object | Pragma_Common_Object =>
18966 Psect_Object : declare
18967 Args : Args_List (1 .. 3);
18968 Names : constant Name_List (1 .. 3) := (
18973 Internal : Node_Id renames Args (1);
18974 External : Node_Id renames Args (2);
18975 Size : Node_Id renames Args (3);
18977 Def_Id : Entity_Id;
18979 procedure Check_Arg (Arg : Node_Id);
18980 -- Checks that argument is either a string literal or an
18981 -- identifier, and posts error message if not.
18987 procedure Check_Arg (Arg : Node_Id) is
18989 if not Nkind_In (Original_Node (Arg),
18994 ("inappropriate argument for pragma %", Arg);
18998 -- Start of processing for Common_Object/Psect_Object
19002 Gather_Associations (Names, Args);
19003 Process_Extended_Import_Export_Internal_Arg (Internal);
19005 Def_Id := Entity (Internal);
19007 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19009 ("pragma% must designate an object", Internal);
19012 Check_Arg (Internal);
19014 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19016 ("cannot use pragma% for imported/exported object",
19020 if Is_Concurrent_Type (Etype (Internal)) then
19022 ("cannot specify pragma % for task/protected object",
19026 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19028 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19030 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19033 if Ekind (Def_Id) = E_Constant then
19035 ("cannot specify pragma % for a constant", Internal);
19038 if Is_Record_Type (Etype (Internal)) then
19044 Ent := First_Entity (Etype (Internal));
19045 while Present (Ent) loop
19046 Decl := Declaration_Node (Ent);
19048 if Ekind (Ent) = E_Component
19049 and then Nkind (Decl) = N_Component_Declaration
19050 and then Present (Expression (Decl))
19051 and then Warn_On_Export_Import
19054 ("?x?object for pragma % has defaults", Internal);
19064 if Present (Size) then
19068 if Present (External) then
19069 Check_Arg_Is_External_Name (External);
19072 -- If all error tests pass, link pragma on to the rep item chain
19074 Record_Rep_Item (Def_Id, N);
19081 -- pragma Pure [(library_unit_NAME)];
19083 when Pragma_Pure => Pure : declare
19087 Check_Ada_83_Warning;
19088 Check_Valid_Library_Unit_Pragma;
19090 if Nkind (N) = N_Null_Statement then
19094 Ent := Find_Lib_Unit_Name;
19096 -- A pragma that applies to a Ghost entity becomes Ghost for the
19097 -- purposes of legality checks and removal of ignored Ghost code.
19099 Mark_Pragma_As_Ghost (N, Ent);
19101 if not Debug_Flag_U then
19103 Set_Has_Pragma_Pure (Ent);
19104 Set_Suppress_Elaboration_Warnings (Ent);
19108 -------------------
19109 -- Pure_Function --
19110 -------------------
19112 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19114 when Pragma_Pure_Function => Pure_Function : declare
19115 Def_Id : Entity_Id;
19118 Effective : Boolean := False;
19122 Check_Arg_Count (1);
19123 Check_Optional_Identifier (Arg1, Name_Entity);
19124 Check_Arg_Is_Local_Name (Arg1);
19125 E_Id := Get_Pragma_Arg (Arg1);
19127 if Error_Posted (E_Id) then
19131 -- Loop through homonyms (overloadings) of referenced entity
19133 E := Entity (E_Id);
19135 -- A pragma that applies to a Ghost entity becomes Ghost for the
19136 -- purposes of legality checks and removal of ignored Ghost code.
19138 Mark_Pragma_As_Ghost (N, E);
19140 if Present (E) then
19142 Def_Id := Get_Base_Subprogram (E);
19144 if not Ekind_In (Def_Id, E_Function,
19145 E_Generic_Function,
19149 ("pragma% requires a function name", Arg1);
19152 Set_Is_Pure (Def_Id);
19154 if not Has_Pragma_Pure_Function (Def_Id) then
19155 Set_Has_Pragma_Pure_Function (Def_Id);
19159 exit when From_Aspect_Specification (N);
19161 exit when No (E) or else Scope (E) /= Current_Scope;
19165 and then Warn_On_Redundant_Constructs
19168 ("pragma Pure_Function on& is redundant?r?",
19174 --------------------
19175 -- Queuing_Policy --
19176 --------------------
19178 -- pragma Queuing_Policy (policy_IDENTIFIER);
19180 when Pragma_Queuing_Policy => declare
19184 Check_Ada_83_Warning;
19185 Check_Arg_Count (1);
19186 Check_No_Identifiers;
19187 Check_Arg_Is_Queuing_Policy (Arg1);
19188 Check_Valid_Configuration_Pragma;
19189 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19190 QP := Fold_Upper (Name_Buffer (1));
19192 if Queuing_Policy /= ' '
19193 and then Queuing_Policy /= QP
19195 Error_Msg_Sloc := Queuing_Policy_Sloc;
19196 Error_Pragma ("queuing policy incompatible with policy#");
19198 -- Set new policy, but always preserve System_Location since we
19199 -- like the error message with the run time name.
19202 Queuing_Policy := QP;
19204 if Queuing_Policy_Sloc /= System_Location then
19205 Queuing_Policy_Sloc := Loc;
19214 -- pragma Rational, for compatibility with foreign compiler
19216 when Pragma_Rational =>
19217 Set_Rational_Profile;
19219 ---------------------
19220 -- Refined_Depends --
19221 ---------------------
19223 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19225 -- DEPENDENCY_RELATION ::=
19227 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
19229 -- DEPENDENCY_CLAUSE ::=
19230 -- OUTPUT_LIST =>[+] INPUT_LIST
19231 -- | NULL_DEPENDENCY_CLAUSE
19233 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19235 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19237 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19239 -- OUTPUT ::= NAME | FUNCTION_RESULT
19242 -- where FUNCTION_RESULT is a function Result attribute_reference
19244 -- Characteristics:
19246 -- * Analysis - The annotation undergoes initial checks to verify
19247 -- the legal placement and context. Secondary checks fully analyze
19248 -- the dependency clauses/global list in:
19250 -- Analyze_Refined_Depends_In_Decl_Part
19252 -- * Expansion - None.
19254 -- * Template - The annotation utilizes the generic template of the
19255 -- related subprogram body.
19257 -- * Globals - Capture of global references must occur after full
19260 -- * Instance - The annotation is instantiated automatically when
19261 -- the related generic subprogram body is instantiated.
19263 when Pragma_Refined_Depends => Refined_Depends : declare
19264 Body_Id : Entity_Id;
19266 Spec_Id : Entity_Id;
19269 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19273 -- Chain the pragma on the contract for further processing by
19274 -- Analyze_Refined_Depends_In_Decl_Part.
19276 Add_Contract_Item (N, Body_Id);
19278 -- The legality checks of pragmas Refined_Depends and
19279 -- Refined_Global are affected by the SPARK mode in effect and
19280 -- the volatility of the context. In addition these two pragmas
19281 -- are subject to an inherent order:
19283 -- 1) Refined_Global
19284 -- 2) Refined_Depends
19286 -- Analyze all these pragmas in the order outlined above
19288 Analyze_If_Present (Pragma_SPARK_Mode);
19289 Analyze_If_Present (Pragma_Volatile_Function);
19290 Analyze_If_Present (Pragma_Refined_Global);
19291 Analyze_Refined_Depends_In_Decl_Part (N);
19293 end Refined_Depends;
19295 --------------------
19296 -- Refined_Global --
19297 --------------------
19299 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19301 -- GLOBAL_SPECIFICATION ::=
19304 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
19306 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19308 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19309 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19310 -- GLOBAL_ITEM ::= NAME
19312 -- Characteristics:
19314 -- * Analysis - The annotation undergoes initial checks to verify
19315 -- the legal placement and context. Secondary checks fully analyze
19316 -- the dependency clauses/global list in:
19318 -- Analyze_Refined_Global_In_Decl_Part
19320 -- * Expansion - None.
19322 -- * Template - The annotation utilizes the generic template of the
19323 -- related subprogram body.
19325 -- * Globals - Capture of global references must occur after full
19328 -- * Instance - The annotation is instantiated automatically when
19329 -- the related generic subprogram body is instantiated.
19331 when Pragma_Refined_Global => Refined_Global : declare
19332 Body_Id : Entity_Id;
19334 Spec_Id : Entity_Id;
19337 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19341 -- Chain the pragma on the contract for further processing by
19342 -- Analyze_Refined_Global_In_Decl_Part.
19344 Add_Contract_Item (N, Body_Id);
19346 -- The legality checks of pragmas Refined_Depends and
19347 -- Refined_Global are affected by the SPARK mode in effect and
19348 -- the volatility of the context. In addition these two pragmas
19349 -- are subject to an inherent order:
19351 -- 1) Refined_Global
19352 -- 2) Refined_Depends
19354 -- Analyze all these pragmas in the order outlined above
19356 Analyze_If_Present (Pragma_SPARK_Mode);
19357 Analyze_If_Present (Pragma_Volatile_Function);
19358 Analyze_Refined_Global_In_Decl_Part (N);
19359 Analyze_If_Present (Pragma_Refined_Depends);
19361 end Refined_Global;
19367 -- pragma Refined_Post (boolean_EXPRESSION);
19369 -- Characteristics:
19371 -- * Analysis - The annotation is fully analyzed immediately upon
19372 -- elaboration as it cannot forward reference entities.
19374 -- * Expansion - The annotation is expanded during the expansion of
19375 -- the related subprogram body contract as performed in:
19377 -- Expand_Subprogram_Contract
19379 -- * Template - The annotation utilizes the generic template of the
19380 -- related subprogram body.
19382 -- * Globals - Capture of global references must occur after full
19385 -- * Instance - The annotation is instantiated automatically when
19386 -- the related generic subprogram body is instantiated.
19388 when Pragma_Refined_Post => Refined_Post : declare
19389 Body_Id : Entity_Id;
19391 Spec_Id : Entity_Id;
19394 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19396 -- Fully analyze the pragma when it appears inside a subprogram
19397 -- body because it cannot benefit from forward references.
19401 -- Chain the pragma on the contract for completeness
19403 Add_Contract_Item (N, Body_Id);
19405 -- The legality checks of pragma Refined_Post are affected by
19406 -- the SPARK mode in effect and the volatility of the context.
19407 -- Analyze all pragmas in a specific order.
19409 Analyze_If_Present (Pragma_SPARK_Mode);
19410 Analyze_If_Present (Pragma_Volatile_Function);
19411 Analyze_Pre_Post_Condition_In_Decl_Part (N);
19413 -- Currently it is not possible to inline pre/postconditions on
19414 -- a subprogram subject to pragma Inline_Always.
19416 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
19420 -------------------
19421 -- Refined_State --
19422 -------------------
19424 -- pragma Refined_State (REFINEMENT_LIST);
19426 -- REFINEMENT_LIST ::=
19427 -- REFINEMENT_CLAUSE
19428 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19430 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19432 -- CONSTITUENT_LIST ::=
19435 -- | (CONSTITUENT {, CONSTITUENT})
19437 -- CONSTITUENT ::= object_NAME | state_NAME
19439 -- Characteristics:
19441 -- * Analysis - The annotation undergoes initial checks to verify
19442 -- the legal placement and context. Secondary checks preanalyze the
19443 -- refinement clauses in:
19445 -- Analyze_Refined_State_In_Decl_Part
19447 -- * Expansion - None.
19449 -- * Template - The annotation utilizes the template of the related
19452 -- * Globals - Capture of global references must occur after full
19455 -- * Instance - The annotation is instantiated automatically when
19456 -- the related generic package body is instantiated.
19458 when Pragma_Refined_State => Refined_State : declare
19459 Pack_Decl : Node_Id;
19460 Spec_Id : Entity_Id;
19464 Check_No_Identifiers;
19465 Check_Arg_Count (1);
19467 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
19469 -- Ensure the proper placement of the pragma. Refined states must
19470 -- be associated with a package body.
19472 if Nkind (Pack_Decl) = N_Package_Body then
19475 -- Otherwise the pragma is associated with an illegal construct
19482 Spec_Id := Corresponding_Spec (Pack_Decl);
19484 -- Chain the pragma on the contract for further processing by
19485 -- Analyze_Refined_State_In_Decl_Part.
19487 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
19489 -- The legality checks of pragma Refined_State are affected by the
19490 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19492 Analyze_If_Present (Pragma_SPARK_Mode);
19494 -- A pragma that applies to a Ghost entity becomes Ghost for the
19495 -- purposes of legality checks and removal of ignored Ghost code.
19497 Mark_Pragma_As_Ghost (N, Spec_Id);
19499 -- State refinement is allowed only when the corresponding package
19500 -- declaration has non-null pragma Abstract_State. Refinement not
19501 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19503 if SPARK_Mode /= Off
19505 (No (Abstract_States (Spec_Id))
19506 or else Has_Null_Abstract_State (Spec_Id))
19509 ("useless refinement, package & does not define abstract "
19510 & "states", N, Spec_Id);
19515 -----------------------
19516 -- Relative_Deadline --
19517 -----------------------
19519 -- pragma Relative_Deadline (time_span_EXPRESSION);
19521 when Pragma_Relative_Deadline => Relative_Deadline : declare
19522 P : constant Node_Id := Parent (N);
19527 Check_No_Identifiers;
19528 Check_Arg_Count (1);
19530 Arg := Get_Pragma_Arg (Arg1);
19532 -- The expression must be analyzed in the special manner described
19533 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19535 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19539 if Nkind (P) = N_Subprogram_Body then
19540 Check_In_Main_Program;
19542 -- Only Task and subprogram cases allowed
19544 elsif Nkind (P) /= N_Task_Definition then
19548 -- Check duplicate pragma before we set the corresponding flag
19550 if Has_Relative_Deadline_Pragma (P) then
19551 Error_Pragma ("duplicate pragma% not allowed");
19554 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19555 -- Relative_Deadline pragma node cannot be inserted in the Rep
19556 -- Item chain of Ent since it is rewritten by the expander as a
19557 -- procedure call statement that will break the chain.
19559 Set_Has_Relative_Deadline_Pragma (P);
19560 end Relative_Deadline;
19562 ------------------------
19563 -- Remote_Access_Type --
19564 ------------------------
19566 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19568 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19573 Check_Arg_Count (1);
19574 Check_Optional_Identifier (Arg1, Name_Entity);
19575 Check_Arg_Is_Local_Name (Arg1);
19577 E := Entity (Get_Pragma_Arg (Arg1));
19579 -- A pragma that applies to a Ghost entity becomes Ghost for the
19580 -- purposes of legality checks and removal of ignored Ghost code.
19582 Mark_Pragma_As_Ghost (N, E);
19584 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19585 and then Ekind (E) = E_General_Access_Type
19586 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19587 and then Scope (Root_Type (Directly_Designated_Type (E)))
19589 and then Is_Valid_Remote_Object_Type
19590 (Root_Type (Directly_Designated_Type (E)))
19592 Set_Is_Remote_Types (E);
19596 ("pragma% applies only to formal access to classwide types",
19599 end Remote_Access_Type;
19601 ---------------------------
19602 -- Remote_Call_Interface --
19603 ---------------------------
19605 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19607 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19608 Cunit_Node : Node_Id;
19609 Cunit_Ent : Entity_Id;
19613 Check_Ada_83_Warning;
19614 Check_Valid_Library_Unit_Pragma;
19616 if Nkind (N) = N_Null_Statement then
19620 Cunit_Node := Cunit (Current_Sem_Unit);
19621 K := Nkind (Unit (Cunit_Node));
19622 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19624 -- A pragma that applies to a Ghost entity becomes Ghost for the
19625 -- purposes of legality checks and removal of ignored Ghost code.
19627 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19629 if K = N_Package_Declaration
19630 or else K = N_Generic_Package_Declaration
19631 or else K = N_Subprogram_Declaration
19632 or else K = N_Generic_Subprogram_Declaration
19633 or else (K = N_Subprogram_Body
19634 and then Acts_As_Spec (Unit (Cunit_Node)))
19639 "pragma% must apply to package or subprogram declaration");
19642 Set_Is_Remote_Call_Interface (Cunit_Ent);
19643 end Remote_Call_Interface;
19649 -- pragma Remote_Types [(library_unit_NAME)];
19651 when Pragma_Remote_Types => Remote_Types : declare
19652 Cunit_Node : Node_Id;
19653 Cunit_Ent : Entity_Id;
19656 Check_Ada_83_Warning;
19657 Check_Valid_Library_Unit_Pragma;
19659 if Nkind (N) = N_Null_Statement then
19663 Cunit_Node := Cunit (Current_Sem_Unit);
19664 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19666 -- A pragma that applies to a Ghost entity becomes Ghost for the
19667 -- purposes of legality checks and removal of ignored Ghost code.
19669 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19671 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19672 N_Generic_Package_Declaration)
19675 ("pragma% can only apply to a package declaration");
19678 Set_Is_Remote_Types (Cunit_Ent);
19685 -- pragma Ravenscar;
19687 when Pragma_Ravenscar =>
19689 Check_Arg_Count (0);
19690 Check_Valid_Configuration_Pragma;
19691 Set_Ravenscar_Profile (N);
19693 if Warn_On_Obsolescent_Feature then
19695 ("pragma Ravenscar is an obsolescent feature?j?", N);
19697 ("|use pragma Profile (Ravenscar) instead?j?", N);
19700 -------------------------
19701 -- Restricted_Run_Time --
19702 -------------------------
19704 -- pragma Restricted_Run_Time;
19706 when Pragma_Restricted_Run_Time =>
19708 Check_Arg_Count (0);
19709 Check_Valid_Configuration_Pragma;
19710 Set_Profile_Restrictions
19711 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
19713 if Warn_On_Obsolescent_Feature then
19715 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19718 ("|use pragma Profile (Restricted) instead?j?", N);
19725 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19728 -- restriction_IDENTIFIER
19729 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19731 when Pragma_Restrictions =>
19732 Process_Restrictions_Or_Restriction_Warnings
19733 (Warn => Treat_Restrictions_As_Warnings);
19735 --------------------------
19736 -- Restriction_Warnings --
19737 --------------------------
19739 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19742 -- restriction_IDENTIFIER
19743 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19745 when Pragma_Restriction_Warnings =>
19747 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
19753 -- pragma Reviewable;
19755 when Pragma_Reviewable =>
19756 Check_Ada_83_Warning;
19757 Check_Arg_Count (0);
19759 -- Call dummy debugging function rv. This is done to assist front
19760 -- end debugging. By placing a Reviewable pragma in the source
19761 -- program, a breakpoint on rv catches this place in the source,
19762 -- allowing convenient stepping to the point of interest.
19766 --------------------------
19767 -- Short_Circuit_And_Or --
19768 --------------------------
19770 -- pragma Short_Circuit_And_Or;
19772 when Pragma_Short_Circuit_And_Or =>
19774 Check_Arg_Count (0);
19775 Check_Valid_Configuration_Pragma;
19776 Short_Circuit_And_Or := True;
19778 -------------------
19779 -- Share_Generic --
19780 -------------------
19782 -- pragma Share_Generic (GNAME {, GNAME});
19784 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19786 when Pragma_Share_Generic =>
19788 Process_Generic_List;
19794 -- pragma Shared (LOCAL_NAME);
19796 when Pragma_Shared =>
19798 Process_Atomic_Independent_Shared_Volatile;
19800 --------------------
19801 -- Shared_Passive --
19802 --------------------
19804 -- pragma Shared_Passive [(library_unit_NAME)];
19806 -- Set the flag Is_Shared_Passive of program unit name entity
19808 when Pragma_Shared_Passive => Shared_Passive : declare
19809 Cunit_Node : Node_Id;
19810 Cunit_Ent : Entity_Id;
19813 Check_Ada_83_Warning;
19814 Check_Valid_Library_Unit_Pragma;
19816 if Nkind (N) = N_Null_Statement then
19820 Cunit_Node := Cunit (Current_Sem_Unit);
19821 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19823 -- A pragma that applies to a Ghost entity becomes Ghost for the
19824 -- purposes of legality checks and removal of ignored Ghost code.
19826 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19828 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19829 N_Generic_Package_Declaration)
19832 ("pragma% can only apply to a package declaration");
19835 Set_Is_Shared_Passive (Cunit_Ent);
19836 end Shared_Passive;
19838 -----------------------
19839 -- Short_Descriptors --
19840 -----------------------
19842 -- pragma Short_Descriptors;
19844 -- Recognize and validate, but otherwise ignore
19846 when Pragma_Short_Descriptors =>
19848 Check_Arg_Count (0);
19849 Check_Valid_Configuration_Pragma;
19851 ------------------------------
19852 -- Simple_Storage_Pool_Type --
19853 ------------------------------
19855 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19857 when Pragma_Simple_Storage_Pool_Type =>
19858 Simple_Storage_Pool_Type : declare
19864 Check_Arg_Count (1);
19865 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19867 Type_Id := Get_Pragma_Arg (Arg1);
19868 Find_Type (Type_Id);
19869 Typ := Entity (Type_Id);
19871 if Typ = Any_Type then
19875 -- A pragma that applies to a Ghost entity becomes Ghost for the
19876 -- purposes of legality checks and removal of ignored Ghost code.
19878 Mark_Pragma_As_Ghost (N, Typ);
19880 -- We require the pragma to apply to a type declared in a package
19881 -- declaration, but not (immediately) within a package body.
19883 if Ekind (Current_Scope) /= E_Package
19884 or else In_Package_Body (Current_Scope)
19887 ("pragma% can only apply to type declared immediately "
19888 & "within a package declaration");
19891 -- A simple storage pool type must be an immutably limited record
19892 -- or private type. If the pragma is given for a private type,
19893 -- the full type is similarly restricted (which is checked later
19894 -- in Freeze_Entity).
19896 if Is_Record_Type (Typ)
19897 and then not Is_Limited_View (Typ)
19900 ("pragma% can only apply to explicitly limited record type");
19902 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
19904 ("pragma% can only apply to a private type that is limited");
19906 elsif not Is_Record_Type (Typ)
19907 and then not Is_Private_Type (Typ)
19910 ("pragma% can only apply to limited record or private type");
19913 Record_Rep_Item (Typ, N);
19914 end Simple_Storage_Pool_Type;
19916 ----------------------
19917 -- Source_File_Name --
19918 ----------------------
19920 -- There are five forms for this pragma:
19922 -- pragma Source_File_Name (
19923 -- [UNIT_NAME =>] unit_NAME,
19924 -- BODY_FILE_NAME => STRING_LITERAL
19925 -- [, [INDEX =>] INTEGER_LITERAL]);
19927 -- pragma Source_File_Name (
19928 -- [UNIT_NAME =>] unit_NAME,
19929 -- SPEC_FILE_NAME => STRING_LITERAL
19930 -- [, [INDEX =>] INTEGER_LITERAL]);
19932 -- pragma Source_File_Name (
19933 -- BODY_FILE_NAME => STRING_LITERAL
19934 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19935 -- [, CASING => CASING_SPEC]);
19937 -- pragma Source_File_Name (
19938 -- SPEC_FILE_NAME => STRING_LITERAL
19939 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19940 -- [, CASING => CASING_SPEC]);
19942 -- pragma Source_File_Name (
19943 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19944 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19945 -- [, CASING => CASING_SPEC]);
19947 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19949 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19950 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19951 -- only be used when no project file is used, while SFNP can only be
19952 -- used when a project file is used.
19954 -- No processing here. Processing was completed during parsing, since
19955 -- we need to have file names set as early as possible. Units are
19956 -- loaded well before semantic processing starts.
19958 -- The only processing we defer to this point is the check for
19959 -- correct placement.
19961 when Pragma_Source_File_Name =>
19963 Check_Valid_Configuration_Pragma;
19965 ------------------------------
19966 -- Source_File_Name_Project --
19967 ------------------------------
19969 -- See Source_File_Name for syntax
19971 -- No processing here. Processing was completed during parsing, since
19972 -- we need to have file names set as early as possible. Units are
19973 -- loaded well before semantic processing starts.
19975 -- The only processing we defer to this point is the check for
19976 -- correct placement.
19978 when Pragma_Source_File_Name_Project =>
19980 Check_Valid_Configuration_Pragma;
19982 -- Check that a pragma Source_File_Name_Project is used only in a
19983 -- configuration pragmas file.
19985 -- Pragmas Source_File_Name_Project should only be generated by
19986 -- the Project Manager in configuration pragmas files.
19988 -- This is really an ugly test. It seems to depend on some
19989 -- accidental and undocumented property. At the very least it
19990 -- needs to be documented, but it would be better to have a
19991 -- clean way of testing if we are in a configuration file???
19993 if Present (Parent (N)) then
19995 ("pragma% can only appear in a configuration pragmas file");
19998 ----------------------
19999 -- Source_Reference --
20000 ----------------------
20002 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20004 -- Nothing to do, all processing completed in Par.Prag, since we need
20005 -- the information for possible parser messages that are output.
20007 when Pragma_Source_Reference =>
20014 -- pragma SPARK_Mode [(On | Off)];
20016 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20017 Mode_Id : SPARK_Mode_Type;
20019 procedure Check_Pragma_Conformance
20020 (Context_Pragma : Node_Id;
20021 Entity : Entity_Id;
20022 Entity_Pragma : Node_Id);
20023 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20024 -- conformance of pragma N depending the following scenarios:
20026 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20027 -- compatible with the pragma Context_Pragma that was inherited
20028 -- from the context:
20029 -- * If the mode of Context_Pragma is ON, then the new mode can
20031 -- * If the mode of Context_Pragma is OFF, then the only allowed
20032 -- new mode is also OFF. Emit error if this is not the case.
20034 -- If Entity is not Empty, verify that pragma N is compatible with
20035 -- pragma Entity_Pragma that belongs to Entity.
20036 -- * If Entity_Pragma is Empty, always issue an error as this
20037 -- corresponds to the case where a previous section of Entity
20038 -- has no SPARK_Mode set.
20039 -- * If the mode of Entity_Pragma is ON, then the new mode can
20041 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20042 -- new mode is also OFF. Emit error if this is not the case.
20044 procedure Check_Library_Level_Entity (E : Entity_Id);
20045 -- Subsidiary to routines Process_xxx. Verify that the related
20046 -- entity E subject to pragma SPARK_Mode is library-level.
20048 procedure Process_Body (Decl : Node_Id);
20049 -- Verify the legality of pragma SPARK_Mode when it appears as the
20050 -- top of the body declarations of entry, package, protected unit,
20051 -- subprogram or task unit body denoted by Decl.
20053 procedure Process_Overloadable (Decl : Node_Id);
20054 -- Verify the legality of pragma SPARK_Mode when it applies to an
20055 -- entry or [generic] subprogram declaration denoted by Decl.
20057 procedure Process_Private_Part (Decl : Node_Id);
20058 -- Verify the legality of pragma SPARK_Mode when it appears at the
20059 -- top of the private declarations of a package spec, protected or
20060 -- task unit declaration denoted by Decl.
20062 procedure Process_Statement_Part (Decl : Node_Id);
20063 -- Verify the legality of pragma SPARK_Mode when it appears at the
20064 -- top of the statement sequence of a package body denoted by node
20067 procedure Process_Visible_Part (Decl : Node_Id);
20068 -- Verify the legality of pragma SPARK_Mode when it appears at the
20069 -- top of the visible declarations of a package spec, protected or
20070 -- task unit declaration denoted by Decl. The routine is also used
20071 -- on protected or task units declared without a definition.
20073 procedure Set_SPARK_Context;
20074 -- Subsidiary to routines Process_xxx. Set the global variables
20075 -- which represent the mode of the context from pragma N. Ensure
20076 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20078 ------------------------------
20079 -- Check_Pragma_Conformance --
20080 ------------------------------
20082 procedure Check_Pragma_Conformance
20083 (Context_Pragma : Node_Id;
20084 Entity : Entity_Id;
20085 Entity_Pragma : Node_Id)
20087 Err_Id : Entity_Id;
20091 -- The current pragma may appear without an argument. If this
20092 -- is the case, associate all error messages with the pragma
20095 if Present (Arg1) then
20101 -- The mode of the current pragma is compared against that of
20102 -- an enclosing context.
20104 if Present (Context_Pragma) then
20105 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20107 -- Issue an error if the new mode is less restrictive than
20108 -- that of the context.
20110 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off
20111 and then Get_SPARK_Mode_From_Pragma (N) = On
20114 ("cannot change SPARK_Mode from Off to On", Err_N);
20115 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20116 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20121 -- The mode of the current pragma is compared against that of
20122 -- an initial package, protected type, subprogram or task type
20125 if Present (Entity) then
20127 -- A simple protected or task type is transformed into an
20128 -- anonymous type whose name cannot be used to issue error
20129 -- messages. Recover the original entity of the type.
20131 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20134 (Original_Node (Unit_Declaration_Node (Entity)));
20139 -- Both the initial declaration and the completion carry
20140 -- SPARK_Mode pragmas.
20142 if Present (Entity_Pragma) then
20143 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20145 -- Issue an error if the new mode is less restrictive
20146 -- than that of the initial declaration.
20148 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off
20149 and then Get_SPARK_Mode_From_Pragma (N) = On
20151 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20152 Error_Msg_Sloc := Sloc (Entity_Pragma);
20154 ("\value Off was set for SPARK_Mode on&#",
20159 -- Otherwise the initial declaration lacks a SPARK_Mode
20160 -- pragma in which case the current pragma is illegal as
20161 -- it cannot "complete".
20164 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20165 Error_Msg_Sloc := Sloc (Err_Id);
20167 ("\no value was set for SPARK_Mode on&#",
20172 end Check_Pragma_Conformance;
20174 --------------------------------
20175 -- Check_Library_Level_Entity --
20176 --------------------------------
20178 procedure Check_Library_Level_Entity (E : Entity_Id) is
20179 procedure Add_Entity_To_Name_Buffer;
20180 -- Add the E_Kind of entity E to the name buffer
20182 -------------------------------
20183 -- Add_Entity_To_Name_Buffer --
20184 -------------------------------
20186 procedure Add_Entity_To_Name_Buffer is
20188 if Ekind_In (E, E_Entry, E_Entry_Family) then
20189 Add_Str_To_Name_Buffer ("entry");
20191 elsif Ekind_In (E, E_Generic_Package,
20195 Add_Str_To_Name_Buffer ("package");
20197 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20198 Add_Str_To_Name_Buffer ("protected type");
20200 elsif Ekind_In (E, E_Function,
20201 E_Generic_Function,
20202 E_Generic_Procedure,
20206 Add_Str_To_Name_Buffer ("subprogram");
20209 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20210 Add_Str_To_Name_Buffer ("task type");
20212 end Add_Entity_To_Name_Buffer;
20216 Msg_1 : constant String := "incorrect placement of pragma%";
20219 -- Start of processing for Check_Library_Level_Entity
20222 if not Is_Library_Level_Entity (E) then
20223 Error_Msg_Name_1 := Pname;
20224 Error_Msg_N (Fix_Error (Msg_1), N);
20227 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20228 Add_Entity_To_Name_Buffer;
20230 Msg_2 := Name_Find;
20231 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20235 end Check_Library_Level_Entity;
20241 procedure Process_Body (Decl : Node_Id) is
20242 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20243 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20246 -- Ignore pragma when applied to the special body created for
20247 -- inlining, recognized by its internal name _Parent.
20249 if Chars (Body_Id) = Name_uParent then
20253 Check_Library_Level_Entity (Body_Id);
20255 -- For entry bodies, verify the legality against:
20256 -- * The mode of the context
20257 -- * The mode of the spec (if any)
20259 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20261 -- A stand alone subprogram body
20263 if Body_Id = Spec_Id then
20264 Check_Pragma_Conformance
20265 (Context_Pragma => SPARK_Pragma (Body_Id),
20267 Entity_Pragma => Empty);
20269 -- An entry or subprogram body that completes a previous
20273 Check_Pragma_Conformance
20274 (Context_Pragma => SPARK_Pragma (Body_Id),
20276 Entity_Pragma => SPARK_Pragma (Spec_Id));
20280 Set_SPARK_Pragma (Body_Id, N);
20281 Set_SPARK_Pragma_Inherited (Body_Id, False);
20283 -- For package bodies, verify the legality against:
20284 -- * The mode of the context
20285 -- * The mode of the private part
20287 -- This case is separated from protected and task bodies
20288 -- because the statement part of the package body inherits
20289 -- the mode of the body declarations.
20291 elsif Nkind (Decl) = N_Package_Body then
20292 Check_Pragma_Conformance
20293 (Context_Pragma => SPARK_Pragma (Body_Id),
20295 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20298 Set_SPARK_Pragma (Body_Id, N);
20299 Set_SPARK_Pragma_Inherited (Body_Id, False);
20300 Set_SPARK_Aux_Pragma (Body_Id, N);
20301 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20303 -- For protected and task bodies, verify the legality against:
20304 -- * The mode of the context
20305 -- * The mode of the private part
20309 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
20311 Check_Pragma_Conformance
20312 (Context_Pragma => SPARK_Pragma (Body_Id),
20314 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20317 Set_SPARK_Pragma (Body_Id, N);
20318 Set_SPARK_Pragma_Inherited (Body_Id, False);
20322 --------------------------
20323 -- Process_Overloadable --
20324 --------------------------
20326 procedure Process_Overloadable (Decl : Node_Id) is
20327 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20328 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
20331 Check_Library_Level_Entity (Spec_Id);
20333 -- Verify the legality against:
20334 -- * The mode of the context
20336 Check_Pragma_Conformance
20337 (Context_Pragma => SPARK_Pragma (Spec_Id),
20339 Entity_Pragma => Empty);
20341 Set_SPARK_Pragma (Spec_Id, N);
20342 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20344 -- When the pragma applies to the anonymous object created for
20345 -- a single task type, decorate the type as well. This scenario
20346 -- arises when the single task type lacks a task definition,
20347 -- therefore there is no issue with respect to a potential
20348 -- pragma SPARK_Mode in the private part.
20350 -- task type Anon_Task_Typ;
20351 -- Obj : Anon_Task_Typ;
20352 -- pragma SPARK_Mode ...;
20354 if Is_Single_Concurrent_Object (Spec_Id)
20355 and then Ekind (Spec_Typ) = E_Task_Type
20357 Set_SPARK_Pragma (Spec_Typ, N);
20358 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
20359 Set_SPARK_Aux_Pragma (Spec_Typ, N);
20360 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
20362 end Process_Overloadable;
20364 --------------------------
20365 -- Process_Private_Part --
20366 --------------------------
20368 procedure Process_Private_Part (Decl : Node_Id) is
20369 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20372 Check_Library_Level_Entity (Spec_Id);
20374 -- Verify the legality against:
20375 -- * The mode of the visible declarations
20377 Check_Pragma_Conformance
20378 (Context_Pragma => Empty,
20380 Entity_Pragma => SPARK_Pragma (Spec_Id));
20383 Set_SPARK_Aux_Pragma (Spec_Id, N);
20384 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
20385 end Process_Private_Part;
20387 ----------------------------
20388 -- Process_Statement_Part --
20389 ----------------------------
20391 procedure Process_Statement_Part (Decl : Node_Id) is
20392 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20395 Check_Library_Level_Entity (Body_Id);
20397 -- Verify the legality against:
20398 -- * The mode of the body declarations
20400 Check_Pragma_Conformance
20401 (Context_Pragma => Empty,
20403 Entity_Pragma => SPARK_Pragma (Body_Id));
20406 Set_SPARK_Aux_Pragma (Body_Id, N);
20407 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20408 end Process_Statement_Part;
20410 --------------------------
20411 -- Process_Visible_Part --
20412 --------------------------
20414 procedure Process_Visible_Part (Decl : Node_Id) is
20415 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20416 Obj_Id : Entity_Id;
20419 Check_Library_Level_Entity (Spec_Id);
20421 -- Verify the legality against:
20422 -- * The mode of the context
20424 Check_Pragma_Conformance
20425 (Context_Pragma => SPARK_Pragma (Spec_Id),
20427 Entity_Pragma => Empty);
20429 -- A task unit declared without a definition does not set the
20430 -- SPARK_Mode of the context because the task does not have any
20431 -- entries that could inherit the mode.
20433 if not Nkind_In (Decl, N_Single_Task_Declaration,
20434 N_Task_Type_Declaration)
20439 Set_SPARK_Pragma (Spec_Id, N);
20440 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20441 Set_SPARK_Aux_Pragma (Spec_Id, N);
20442 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20444 -- When the pragma applies to a single protected or task type,
20445 -- decorate the corresponding anonymous object as well.
20447 -- protected Anon_Prot_Typ is
20448 -- pragma SPARK_Mode ...;
20450 -- end Anon_Prot_Typ;
20452 -- Obj : Anon_Prot_Typ;
20454 if Is_Single_Concurrent_Type (Spec_Id) then
20455 Obj_Id := Anonymous_Object (Spec_Id);
20457 Set_SPARK_Pragma (Obj_Id, N);
20458 Set_SPARK_Pragma_Inherited (Obj_Id, False);
20460 end Process_Visible_Part;
20462 -----------------------
20463 -- Set_SPARK_Context --
20464 -----------------------
20466 procedure Set_SPARK_Context is
20468 SPARK_Mode := Mode_Id;
20469 SPARK_Mode_Pragma := N;
20471 if SPARK_Mode = On then
20472 Dynamic_Elaboration_Checks := False;
20474 end Set_SPARK_Context;
20482 -- Start of processing for Do_SPARK_Mode
20485 -- When a SPARK_Mode pragma appears inside an instantiation whose
20486 -- enclosing context has SPARK_Mode set to "off", the pragma has
20487 -- no semantic effect.
20489 if Ignore_Pragma_SPARK_Mode then
20490 Rewrite (N, Make_Null_Statement (Loc));
20496 Check_No_Identifiers;
20497 Check_At_Most_N_Arguments (1);
20499 -- Check the legality of the mode (no argument = ON)
20501 if Arg_Count = 1 then
20502 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20503 Mode := Chars (Get_Pragma_Arg (Arg1));
20508 Mode_Id := Get_SPARK_Mode_Type (Mode);
20509 Context := Parent (N);
20511 -- The pragma appears in a configuration pragmas file
20513 if No (Context) then
20514 Check_Valid_Configuration_Pragma;
20516 if Present (SPARK_Mode_Pragma) then
20517 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20518 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20524 -- The pragma acts as a configuration pragma in a compilation unit
20526 -- pragma SPARK_Mode ...;
20527 -- package Pack is ...;
20529 elsif Nkind (Context) = N_Compilation_Unit
20530 and then List_Containing (N) = Context_Items (Context)
20532 Check_Valid_Configuration_Pragma;
20535 -- Otherwise the placement of the pragma within the tree dictates
20536 -- its associated construct. Inspect the declarative list where
20537 -- the pragma resides to find a potential construct.
20541 while Present (Stmt) loop
20543 -- Skip prior pragmas, but check for duplicates. Note that
20544 -- this also takes care of pragmas generated for aspects.
20546 if Nkind (Stmt) = N_Pragma then
20547 if Pragma_Name (Stmt) = Pname then
20548 Error_Msg_Name_1 := Pname;
20549 Error_Msg_Sloc := Sloc (Stmt);
20550 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20554 -- The pragma applies to an expression function that has
20555 -- already been rewritten into a subprogram declaration.
20557 -- function Expr_Func return ... is (...);
20558 -- pragma SPARK_Mode ...;
20560 elsif Nkind (Stmt) = N_Subprogram_Declaration
20561 and then Nkind (Original_Node (Stmt)) =
20562 N_Expression_Function
20564 Process_Overloadable (Stmt);
20567 -- The pragma applies to the anonymous object created for a
20568 -- single concurrent type.
20570 -- protected type Anon_Prot_Typ ...;
20571 -- Obj : Anon_Prot_Typ;
20572 -- pragma SPARK_Mode ...;
20574 elsif Nkind (Stmt) = N_Object_Declaration
20575 and then Is_Single_Concurrent_Object
20576 (Defining_Entity (Stmt))
20578 Process_Overloadable (Stmt);
20581 -- Skip internally generated code
20583 elsif not Comes_From_Source (Stmt) then
20586 -- The pragma applies to an entry or [generic] subprogram
20590 -- pragma SPARK_Mode ...;
20593 -- procedure Proc ...;
20594 -- pragma SPARK_Mode ...;
20596 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
20597 N_Subprogram_Declaration)
20598 or else (Nkind (Stmt) = N_Entry_Declaration
20599 and then Is_Protected_Type
20600 (Scope (Defining_Entity (Stmt))))
20602 Process_Overloadable (Stmt);
20605 -- Otherwise the pragma does not apply to a legal construct
20606 -- or it does not appear at the top of a declarative or a
20607 -- statement list. Issue an error and stop the analysis.
20617 -- The pragma applies to a package or a subprogram that acts as
20618 -- a compilation unit.
20620 -- procedure Proc ...;
20621 -- pragma SPARK_Mode ...;
20623 if Nkind (Context) = N_Compilation_Unit_Aux then
20624 Context := Unit (Parent (Context));
20627 -- The pragma appears at the top of entry, package, protected
20628 -- unit, subprogram or task unit body declarations.
20630 -- entry Ent when ... is
20631 -- pragma SPARK_Mode ...;
20633 -- package body Pack is
20634 -- pragma SPARK_Mode ...;
20636 -- procedure Proc ... is
20637 -- pragma SPARK_Mode;
20639 -- protected body Prot is
20640 -- pragma SPARK_Mode ...;
20642 if Nkind_In (Context, N_Entry_Body,
20648 Process_Body (Context);
20650 -- The pragma appears at the top of the visible or private
20651 -- declaration of a package spec, protected or task unit.
20654 -- pragma SPARK_Mode ...;
20656 -- pragma SPARK_Mode ...;
20658 -- protected [type] Prot is
20659 -- pragma SPARK_Mode ...;
20661 -- pragma SPARK_Mode ...;
20663 elsif Nkind_In (Context, N_Package_Specification,
20664 N_Protected_Definition,
20667 if List_Containing (N) = Visible_Declarations (Context) then
20668 Process_Visible_Part (Parent (Context));
20670 Process_Private_Part (Parent (Context));
20673 -- The pragma appears at the top of package body statements
20675 -- package body Pack is
20677 -- pragma SPARK_Mode;
20679 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
20680 and then Nkind (Parent (Context)) = N_Package_Body
20682 Process_Statement_Part (Parent (Context));
20684 -- The pragma appeared as an aspect of a [generic] subprogram
20685 -- declaration that acts as a compilation unit.
20688 -- procedure Proc ...;
20689 -- pragma SPARK_Mode ...;
20691 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
20692 N_Subprogram_Declaration)
20694 Process_Overloadable (Context);
20696 -- The pragma does not apply to a legal construct, issue error
20704 --------------------------------
20705 -- Static_Elaboration_Desired --
20706 --------------------------------
20708 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20710 when Pragma_Static_Elaboration_Desired =>
20712 Check_At_Most_N_Arguments (1);
20714 if Is_Compilation_Unit (Current_Scope)
20715 and then Ekind (Current_Scope) = E_Package
20717 Set_Static_Elaboration_Desired (Current_Scope, True);
20719 Error_Pragma ("pragma% must apply to a library-level package");
20726 -- pragma Storage_Size (EXPRESSION);
20728 when Pragma_Storage_Size => Storage_Size : declare
20729 P : constant Node_Id := Parent (N);
20733 Check_No_Identifiers;
20734 Check_Arg_Count (1);
20736 -- The expression must be analyzed in the special manner described
20737 -- in "Handling of Default Expressions" in sem.ads.
20739 Arg := Get_Pragma_Arg (Arg1);
20740 Preanalyze_Spec_Expression (Arg, Any_Integer);
20742 if not Is_OK_Static_Expression (Arg) then
20743 Check_Restriction (Static_Storage_Size, Arg);
20746 if Nkind (P) /= N_Task_Definition then
20751 if Has_Storage_Size_Pragma (P) then
20752 Error_Pragma ("duplicate pragma% not allowed");
20754 Set_Has_Storage_Size_Pragma (P, True);
20757 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
20765 -- pragma Storage_Unit (NUMERIC_LITERAL);
20767 -- Only permitted argument is System'Storage_Unit value
20769 when Pragma_Storage_Unit =>
20770 Check_No_Identifiers;
20771 Check_Arg_Count (1);
20772 Check_Arg_Is_Integer_Literal (Arg1);
20774 if Intval (Get_Pragma_Arg (Arg1)) /=
20775 UI_From_Int (Ttypes.System_Storage_Unit)
20777 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
20779 ("the only allowed argument for pragma% is ^", Arg1);
20782 --------------------
20783 -- Stream_Convert --
20784 --------------------
20786 -- pragma Stream_Convert (
20787 -- [Entity =>] type_LOCAL_NAME,
20788 -- [Read =>] function_NAME,
20789 -- [Write =>] function NAME);
20791 when Pragma_Stream_Convert => Stream_Convert : declare
20793 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
20794 -- Check that the given argument is the name of a local function
20795 -- of one argument that is not overloaded earlier in the current
20796 -- local scope. A check is also made that the argument is a
20797 -- function with one parameter.
20799 --------------------------------------
20800 -- Check_OK_Stream_Convert_Function --
20801 --------------------------------------
20803 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
20807 Check_Arg_Is_Local_Name (Arg);
20808 Ent := Entity (Get_Pragma_Arg (Arg));
20810 if Has_Homonym (Ent) then
20812 ("argument for pragma% may not be overloaded", Arg);
20815 if Ekind (Ent) /= E_Function
20816 or else No (First_Formal (Ent))
20817 or else Present (Next_Formal (First_Formal (Ent)))
20820 ("argument for pragma% must be function of one argument",
20823 end Check_OK_Stream_Convert_Function;
20825 -- Start of processing for Stream_Convert
20829 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
20830 Check_Arg_Count (3);
20831 Check_Optional_Identifier (Arg1, Name_Entity);
20832 Check_Optional_Identifier (Arg2, Name_Read);
20833 Check_Optional_Identifier (Arg3, Name_Write);
20834 Check_Arg_Is_Local_Name (Arg1);
20835 Check_OK_Stream_Convert_Function (Arg2);
20836 Check_OK_Stream_Convert_Function (Arg3);
20839 Typ : constant Entity_Id :=
20840 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
20841 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
20842 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
20845 Check_First_Subtype (Arg1);
20847 -- Check for too early or too late. Note that we don't enforce
20848 -- the rule about primitive operations in this case, since, as
20849 -- is the case for explicit stream attributes themselves, these
20850 -- restrictions are not appropriate. Note that the chaining of
20851 -- the pragma by Rep_Item_Too_Late is actually the critical
20852 -- processing done for this pragma.
20854 if Rep_Item_Too_Early (Typ, N)
20856 Rep_Item_Too_Late (Typ, N, FOnly => True)
20861 -- Return if previous error
20863 if Etype (Typ) = Any_Type
20865 Etype (Read) = Any_Type
20867 Etype (Write) = Any_Type
20874 if Underlying_Type (Etype (Read)) /= Typ then
20876 ("incorrect return type for function&", Arg2);
20879 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
20881 ("incorrect parameter type for function&", Arg3);
20884 if Underlying_Type (Etype (First_Formal (Read))) /=
20885 Underlying_Type (Etype (Write))
20888 ("result type of & does not match Read parameter type",
20892 end Stream_Convert;
20898 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20900 -- This is processed by the parser since some of the style checks
20901 -- take place during source scanning and parsing. This means that
20902 -- we don't need to issue error messages here.
20904 when Pragma_Style_Checks => Style_Checks : declare
20905 A : constant Node_Id := Get_Pragma_Arg (Arg1);
20911 Check_No_Identifiers;
20913 -- Two argument form
20915 if Arg_Count = 2 then
20916 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20923 E_Id := Get_Pragma_Arg (Arg2);
20926 if not Is_Entity_Name (E_Id) then
20928 ("second argument of pragma% must be entity name",
20932 E := Entity (E_Id);
20934 if not Ignore_Style_Checks_Pragmas then
20939 Set_Suppress_Style_Checks
20940 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
20941 exit when No (Homonym (E));
20948 -- One argument form
20951 Check_Arg_Count (1);
20953 if Nkind (A) = N_String_Literal then
20957 Slen : constant Natural := Natural (String_Length (S));
20958 Options : String (1 .. Slen);
20964 C := Get_String_Char (S, Int (J));
20965 exit when not In_Character_Range (C);
20966 Options (J) := Get_Character (C);
20968 -- If at end of string, set options. As per discussion
20969 -- above, no need to check for errors, since we issued
20970 -- them in the parser.
20973 if not Ignore_Style_Checks_Pragmas then
20974 Set_Style_Check_Options (Options);
20984 elsif Nkind (A) = N_Identifier then
20985 if Chars (A) = Name_All_Checks then
20986 if not Ignore_Style_Checks_Pragmas then
20988 Set_GNAT_Style_Check_Options;
20990 Set_Default_Style_Check_Options;
20994 elsif Chars (A) = Name_On then
20995 if not Ignore_Style_Checks_Pragmas then
20996 Style_Check := True;
20999 elsif Chars (A) = Name_Off then
21000 if not Ignore_Style_Checks_Pragmas then
21001 Style_Check := False;
21012 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21014 when Pragma_Subtitle =>
21016 Check_Arg_Count (1);
21017 Check_Optional_Identifier (Arg1, Name_Subtitle);
21018 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21025 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21027 when Pragma_Suppress =>
21028 Process_Suppress_Unsuppress (Suppress_Case => True);
21034 -- pragma Suppress_All;
21036 -- The only check made here is that the pragma has no arguments.
21037 -- There are no placement rules, and the processing required (setting
21038 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21039 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21040 -- then creates and inserts a pragma Suppress (All_Checks).
21042 when Pragma_Suppress_All =>
21044 Check_Arg_Count (0);
21046 -------------------------
21047 -- Suppress_Debug_Info --
21048 -------------------------
21050 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21052 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21053 Nam_Id : Entity_Id;
21057 Check_Arg_Count (1);
21058 Check_Optional_Identifier (Arg1, Name_Entity);
21059 Check_Arg_Is_Local_Name (Arg1);
21061 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21063 -- A pragma that applies to a Ghost entity becomes Ghost for the
21064 -- purposes of legality checks and removal of ignored Ghost code.
21066 Mark_Pragma_As_Ghost (N, Nam_Id);
21067 Set_Debug_Info_Off (Nam_Id);
21068 end Suppress_Debug_Info;
21070 ----------------------------------
21071 -- Suppress_Exception_Locations --
21072 ----------------------------------
21074 -- pragma Suppress_Exception_Locations;
21076 when Pragma_Suppress_Exception_Locations =>
21078 Check_Arg_Count (0);
21079 Check_Valid_Configuration_Pragma;
21080 Exception_Locations_Suppressed := True;
21082 -----------------------------
21083 -- Suppress_Initialization --
21084 -----------------------------
21086 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21088 when Pragma_Suppress_Initialization => Suppress_Init : declare
21094 Check_Arg_Count (1);
21095 Check_Optional_Identifier (Arg1, Name_Entity);
21096 Check_Arg_Is_Local_Name (Arg1);
21098 E_Id := Get_Pragma_Arg (Arg1);
21100 if Etype (E_Id) = Any_Type then
21104 E := Entity (E_Id);
21106 -- A pragma that applies to a Ghost entity becomes Ghost for the
21107 -- purposes of legality checks and removal of ignored Ghost code.
21109 Mark_Pragma_As_Ghost (N, E);
21111 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21113 ("pragma% requires variable, type or subtype", Arg1);
21116 if Rep_Item_Too_Early (E, N)
21118 Rep_Item_Too_Late (E, N, FOnly => True)
21123 -- For incomplete/private type, set flag on full view
21125 if Is_Incomplete_Or_Private_Type (E) then
21126 if No (Full_View (Base_Type (E))) then
21128 ("argument of pragma% cannot be an incomplete type", Arg1);
21130 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21133 -- For first subtype, set flag on base type
21135 elsif Is_First_Subtype (E) then
21136 Set_Suppress_Initialization (Base_Type (E));
21138 -- For other than first subtype, set flag on subtype or variable
21141 Set_Suppress_Initialization (E);
21149 -- pragma System_Name (DIRECT_NAME);
21151 -- Syntax check: one argument, which must be the identifier GNAT or
21152 -- the identifier GCC, no other identifiers are acceptable.
21154 when Pragma_System_Name =>
21156 Check_No_Identifiers;
21157 Check_Arg_Count (1);
21158 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21160 -----------------------------
21161 -- Task_Dispatching_Policy --
21162 -----------------------------
21164 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21166 when Pragma_Task_Dispatching_Policy => declare
21170 Check_Ada_83_Warning;
21171 Check_Arg_Count (1);
21172 Check_No_Identifiers;
21173 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21174 Check_Valid_Configuration_Pragma;
21175 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21176 DP := Fold_Upper (Name_Buffer (1));
21178 if Task_Dispatching_Policy /= ' '
21179 and then Task_Dispatching_Policy /= DP
21181 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21183 ("task dispatching policy incompatible with policy#");
21185 -- Set new policy, but always preserve System_Location since we
21186 -- like the error message with the run time name.
21189 Task_Dispatching_Policy := DP;
21191 if Task_Dispatching_Policy_Sloc /= System_Location then
21192 Task_Dispatching_Policy_Sloc := Loc;
21201 -- pragma Task_Info (EXPRESSION);
21203 when Pragma_Task_Info => Task_Info : declare
21204 P : constant Node_Id := Parent (N);
21210 if Warn_On_Obsolescent_Feature then
21212 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21213 & "instead?j?", N);
21216 if Nkind (P) /= N_Task_Definition then
21217 Error_Pragma ("pragma% must appear in task definition");
21220 Check_No_Identifiers;
21221 Check_Arg_Count (1);
21223 Analyze_And_Resolve
21224 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21226 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21230 Ent := Defining_Identifier (Parent (P));
21232 -- Check duplicate pragma before we chain the pragma in the Rep
21233 -- Item chain of Ent.
21236 (Ent, Name_Task_Info, Check_Parents => False)
21238 Error_Pragma ("duplicate pragma% not allowed");
21241 Record_Rep_Item (Ent, N);
21248 -- pragma Task_Name (string_EXPRESSION);
21250 when Pragma_Task_Name => Task_Name : declare
21251 P : constant Node_Id := Parent (N);
21256 Check_No_Identifiers;
21257 Check_Arg_Count (1);
21259 Arg := Get_Pragma_Arg (Arg1);
21261 -- The expression is used in the call to Create_Task, and must be
21262 -- expanded there, not in the context of the current spec. It must
21263 -- however be analyzed to capture global references, in case it
21264 -- appears in a generic context.
21266 Preanalyze_And_Resolve (Arg, Standard_String);
21268 if Nkind (P) /= N_Task_Definition then
21272 Ent := Defining_Identifier (Parent (P));
21274 -- Check duplicate pragma before we chain the pragma in the Rep
21275 -- Item chain of Ent.
21278 (Ent, Name_Task_Name, Check_Parents => False)
21280 Error_Pragma ("duplicate pragma% not allowed");
21283 Record_Rep_Item (Ent, N);
21290 -- pragma Task_Storage (
21291 -- [Task_Type =>] LOCAL_NAME,
21292 -- [Top_Guard =>] static_integer_EXPRESSION);
21294 when Pragma_Task_Storage => Task_Storage : declare
21295 Args : Args_List (1 .. 2);
21296 Names : constant Name_List (1 .. 2) := (
21300 Task_Type : Node_Id renames Args (1);
21301 Top_Guard : Node_Id renames Args (2);
21307 Gather_Associations (Names, Args);
21309 if No (Task_Type) then
21311 ("missing task_type argument for pragma%");
21314 Check_Arg_Is_Local_Name (Task_Type);
21316 Ent := Entity (Task_Type);
21318 if not Is_Task_Type (Ent) then
21320 ("argument for pragma% must be task type", Task_Type);
21323 if No (Top_Guard) then
21325 ("pragma% takes two arguments", Task_Type);
21327 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
21330 Check_First_Subtype (Task_Type);
21332 if Rep_Item_Too_Late (Ent, N) then
21341 -- pragma Test_Case
21342 -- ([Name =>] Static_String_EXPRESSION
21343 -- ,[Mode =>] MODE_TYPE
21344 -- [, Requires => Boolean_EXPRESSION]
21345 -- [, Ensures => Boolean_EXPRESSION]);
21347 -- MODE_TYPE ::= Nominal | Robustness
21349 -- Characteristics:
21351 -- * Analysis - The annotation undergoes initial checks to verify
21352 -- the legal placement and context. Secondary checks preanalyze the
21355 -- Analyze_Test_Case_In_Decl_Part
21357 -- * Expansion - None.
21359 -- * Template - The annotation utilizes the generic template of the
21360 -- related subprogram when it is:
21362 -- aspect on subprogram declaration
21364 -- The annotation must prepare its own template when it is:
21366 -- pragma on subprogram declaration
21368 -- * Globals - Capture of global references must occur after full
21371 -- * Instance - The annotation is instantiated automatically when
21372 -- the related generic subprogram is instantiated except for the
21373 -- "pragma on subprogram declaration" case. In that scenario the
21374 -- annotation must instantiate itself.
21376 when Pragma_Test_Case => Test_Case : declare
21377 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
21378 -- Ensure that the contract of subprogram Subp_Id does not contain
21379 -- another Test_Case pragma with the same Name as the current one.
21381 -------------------------
21382 -- Check_Distinct_Name --
21383 -------------------------
21385 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
21386 Items : constant Node_Id := Contract (Subp_Id);
21387 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
21391 -- Inspect all Test_Case pragma of the related subprogram
21392 -- looking for one with a duplicate "Name" argument.
21394 if Present (Items) then
21395 Prag := Contract_Test_Cases (Items);
21396 while Present (Prag) loop
21397 if Pragma_Name (Prag) = Name_Test_Case
21399 and then String_Equal
21400 (Name, Get_Name_From_CTC_Pragma (Prag))
21402 Error_Msg_Sloc := Sloc (Prag);
21403 Error_Pragma ("name for pragma % is already used #");
21406 Prag := Next_Pragma (Prag);
21409 end Check_Distinct_Name;
21413 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
21416 Subp_Decl : Node_Id;
21417 Subp_Id : Entity_Id;
21419 -- Start of processing for Test_Case
21423 Check_At_Least_N_Arguments (2);
21424 Check_At_Most_N_Arguments (4);
21426 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
21430 Check_Optional_Identifier (Arg1, Name_Name);
21431 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21435 Check_Optional_Identifier (Arg2, Name_Mode);
21436 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
21438 -- Arguments "Requires" and "Ensures"
21440 if Present (Arg3) then
21441 if Present (Arg4) then
21442 Check_Identifier (Arg3, Name_Requires);
21443 Check_Identifier (Arg4, Name_Ensures);
21445 Check_Identifier_Is_One_Of
21446 (Arg3, Name_Requires, Name_Ensures);
21450 -- Pragma Test_Case must be associated with a subprogram declared
21451 -- in a library-level package. First determine whether the current
21452 -- compilation unit is a legal context.
21454 if Nkind_In (Pack_Decl, N_Package_Declaration,
21455 N_Generic_Package_Declaration)
21459 -- Otherwise the placement is illegal
21466 Subp_Decl := Find_Related_Declaration_Or_Body (N);
21468 -- Find the enclosing context
21470 Context := Parent (Subp_Decl);
21472 if Present (Context) then
21473 Context := Parent (Context);
21476 -- Verify the placement of the pragma
21478 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
21480 ("pragma % cannot be applied to abstract subprogram");
21483 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
21484 Error_Pragma ("pragma % cannot be applied to entry");
21487 -- The context is a [generic] subprogram declared at the top level
21488 -- of the [generic] package unit.
21490 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
21491 N_Subprogram_Declaration)
21492 and then Present (Context)
21493 and then Nkind_In (Context, N_Generic_Package_Declaration,
21494 N_Package_Declaration)
21498 -- Otherwise the placement is illegal
21505 Subp_Id := Defining_Entity (Subp_Decl);
21507 -- Chain the pragma on the contract for further processing by
21508 -- Analyze_Test_Case_In_Decl_Part.
21510 Add_Contract_Item (N, Subp_Id);
21512 -- A pragma that applies to a Ghost entity becomes Ghost for the
21513 -- purposes of legality checks and removal of ignored Ghost code.
21515 Mark_Pragma_As_Ghost (N, Subp_Id);
21517 -- Preanalyze the original aspect argument "Name" for ASIS or for
21518 -- a generic subprogram to properly capture global references.
21520 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
21521 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
21523 if Present (Asp_Arg) then
21525 -- The argument appears with an identifier in association
21528 if Nkind (Asp_Arg) = N_Component_Association then
21529 Asp_Arg := Expression (Asp_Arg);
21532 Check_Expr_Is_OK_Static_Expression
21533 (Asp_Arg, Standard_String);
21537 -- Ensure that the all Test_Case pragmas of the related subprogram
21538 -- have distinct names.
21540 Check_Distinct_Name (Subp_Id);
21542 -- Fully analyze the pragma when it appears inside an entry
21543 -- or subprogram body because it cannot benefit from forward
21546 if Nkind_In (Subp_Decl, N_Entry_Body,
21548 N_Subprogram_Body_Stub)
21550 -- The legality checks of pragma Test_Case are affected by the
21551 -- SPARK mode in effect and the volatility of the context.
21552 -- Analyze all pragmas in a specific order.
21554 Analyze_If_Present (Pragma_SPARK_Mode);
21555 Analyze_If_Present (Pragma_Volatile_Function);
21556 Analyze_Test_Case_In_Decl_Part (N);
21560 --------------------------
21561 -- Thread_Local_Storage --
21562 --------------------------
21564 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21566 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
21572 Check_Arg_Count (1);
21573 Check_Optional_Identifier (Arg1, Name_Entity);
21574 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21576 Id := Get_Pragma_Arg (Arg1);
21579 if not Is_Entity_Name (Id)
21580 or else Ekind (Entity (Id)) /= E_Variable
21582 Error_Pragma_Arg ("local variable name required", Arg1);
21587 -- A pragma that applies to a Ghost entity becomes Ghost for the
21588 -- purposes of legality checks and removal of ignored Ghost code.
21590 Mark_Pragma_As_Ghost (N, E);
21592 if Rep_Item_Too_Early (E, N)
21594 Rep_Item_Too_Late (E, N)
21599 Set_Has_Pragma_Thread_Local_Storage (E);
21600 Set_Has_Gigi_Rep_Item (E);
21601 end Thread_Local_Storage;
21607 -- pragma Time_Slice (static_duration_EXPRESSION);
21609 when Pragma_Time_Slice => Time_Slice : declare
21615 Check_Arg_Count (1);
21616 Check_No_Identifiers;
21617 Check_In_Main_Program;
21618 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
21620 if not Error_Posted (Arg1) then
21622 while Present (Nod) loop
21623 if Nkind (Nod) = N_Pragma
21624 and then Pragma_Name (Nod) = Name_Time_Slice
21626 Error_Msg_Name_1 := Pname;
21627 Error_Msg_N ("duplicate pragma% not permitted", Nod);
21634 -- Process only if in main unit
21636 if Get_Source_Unit (Loc) = Main_Unit then
21637 Opt.Time_Slice_Set := True;
21638 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
21640 if Val <= Ureal_0 then
21641 Opt.Time_Slice_Value := 0;
21643 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
21644 Opt.Time_Slice_Value := 1_000_000_000;
21647 Opt.Time_Slice_Value :=
21648 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
21657 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
21659 -- TITLING_OPTION ::=
21660 -- [Title =>] STRING_LITERAL
21661 -- | [Subtitle =>] STRING_LITERAL
21663 when Pragma_Title => Title : declare
21664 Args : Args_List (1 .. 2);
21665 Names : constant Name_List (1 .. 2) := (
21671 Gather_Associations (Names, Args);
21674 for J in 1 .. 2 loop
21675 if Present (Args (J)) then
21676 Check_Arg_Is_OK_Static_Expression
21677 (Args (J), Standard_String);
21682 ----------------------------
21683 -- Type_Invariant[_Class] --
21684 ----------------------------
21686 -- pragma Type_Invariant[_Class]
21687 -- ([Entity =>] type_LOCAL_NAME,
21688 -- [Check =>] EXPRESSION);
21690 when Pragma_Type_Invariant |
21691 Pragma_Type_Invariant_Class =>
21692 Type_Invariant : declare
21693 I_Pragma : Node_Id;
21696 Check_Arg_Count (2);
21698 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
21699 -- setting Class_Present for the Type_Invariant_Class case.
21701 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
21702 I_Pragma := New_Copy (N);
21703 Set_Pragma_Identifier
21704 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
21705 Rewrite (N, I_Pragma);
21706 Set_Analyzed (N, False);
21708 end Type_Invariant;
21710 ---------------------
21711 -- Unchecked_Union --
21712 ---------------------
21714 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
21716 when Pragma_Unchecked_Union => Unchecked_Union : declare
21717 Assoc : constant Node_Id := Arg1;
21718 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
21728 Check_No_Identifiers;
21729 Check_Arg_Count (1);
21730 Check_Arg_Is_Local_Name (Arg1);
21732 Find_Type (Type_Id);
21734 Typ := Entity (Type_Id);
21736 -- A pragma that applies to a Ghost entity becomes Ghost for the
21737 -- purposes of legality checks and removal of ignored Ghost code.
21739 Mark_Pragma_As_Ghost (N, Typ);
21742 or else Rep_Item_Too_Early (Typ, N)
21746 Typ := Underlying_Type (Typ);
21749 if Rep_Item_Too_Late (Typ, N) then
21753 Check_First_Subtype (Arg1);
21755 -- Note remaining cases are references to a type in the current
21756 -- declarative part. If we find an error, we post the error on
21757 -- the relevant type declaration at an appropriate point.
21759 if not Is_Record_Type (Typ) then
21760 Error_Msg_N ("unchecked union must be record type", Typ);
21763 elsif Is_Tagged_Type (Typ) then
21764 Error_Msg_N ("unchecked union must not be tagged", Typ);
21767 elsif not Has_Discriminants (Typ) then
21769 ("unchecked union must have one discriminant", Typ);
21772 -- Note: in previous versions of GNAT we used to check for limited
21773 -- types and give an error, but in fact the standard does allow
21774 -- Unchecked_Union on limited types, so this check was removed.
21776 -- Similarly, GNAT used to require that all discriminants have
21777 -- default values, but this is not mandated by the RM.
21779 -- Proceed with basic error checks completed
21782 Tdef := Type_Definition (Declaration_Node (Typ));
21783 Clist := Component_List (Tdef);
21785 -- Check presence of component list and variant part
21787 if No (Clist) or else No (Variant_Part (Clist)) then
21789 ("unchecked union must have variant part", Tdef);
21793 -- Check components
21795 Comp := First (Component_Items (Clist));
21796 while Present (Comp) loop
21797 Check_Component (Comp, Typ);
21801 -- Check variant part
21803 Vpart := Variant_Part (Clist);
21805 Variant := First (Variants (Vpart));
21806 while Present (Variant) loop
21807 Check_Variant (Variant, Typ);
21812 Set_Is_Unchecked_Union (Typ);
21813 Set_Convention (Typ, Convention_C);
21814 Set_Has_Unchecked_Union (Base_Type (Typ));
21815 Set_Is_Unchecked_Union (Base_Type (Typ));
21816 end Unchecked_Union;
21818 ------------------------
21819 -- Unimplemented_Unit --
21820 ------------------------
21822 -- pragma Unimplemented_Unit;
21824 -- Note: this only gives an error if we are generating code, or if
21825 -- we are in a generic library unit (where the pragma appears in the
21826 -- body, not in the spec).
21828 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
21829 Cunitent : constant Entity_Id :=
21830 Cunit_Entity (Get_Source_Unit (Loc));
21831 Ent_Kind : constant Entity_Kind :=
21836 Check_Arg_Count (0);
21838 if Operating_Mode = Generate_Code
21839 or else Ent_Kind = E_Generic_Function
21840 or else Ent_Kind = E_Generic_Procedure
21841 or else Ent_Kind = E_Generic_Package
21843 Get_Name_String (Chars (Cunitent));
21844 Set_Casing (Mixed_Case);
21845 Write_Str (Name_Buffer (1 .. Name_Len));
21846 Write_Str (" is not supported in this configuration");
21848 raise Unrecoverable_Error;
21850 end Unimplemented_Unit;
21852 ------------------------
21853 -- Universal_Aliasing --
21854 ------------------------
21856 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
21858 when Pragma_Universal_Aliasing => Universal_Alias : declare
21863 Check_Arg_Count (1);
21864 Check_Optional_Identifier (Arg2, Name_Entity);
21865 Check_Arg_Is_Local_Name (Arg1);
21866 E_Id := Entity (Get_Pragma_Arg (Arg1));
21868 if E_Id = Any_Type then
21870 elsif No (E_Id) or else not Is_Type (E_Id) then
21871 Error_Pragma_Arg ("pragma% requires type", Arg1);
21874 -- A pragma that applies to a Ghost entity becomes Ghost for the
21875 -- purposes of legality checks and removal of ignored Ghost code.
21877 Mark_Pragma_As_Ghost (N, E_Id);
21878 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
21879 Record_Rep_Item (E_Id, N);
21880 end Universal_Alias;
21882 --------------------
21883 -- Universal_Data --
21884 --------------------
21886 -- pragma Universal_Data [(library_unit_NAME)];
21888 when Pragma_Universal_Data =>
21891 -- If this is a configuration pragma, then set the universal
21892 -- addressing option, otherwise confirm that the pragma satisfies
21893 -- the requirements of library unit pragma placement and leave it
21894 -- to the GNAAMP back end to detect the pragma (avoids transitive
21895 -- setting of the option due to withed units).
21897 if Is_Configuration_Pragma then
21898 Universal_Addressing_On_AAMP := True;
21900 Check_Valid_Library_Unit_Pragma;
21903 if not AAMP_On_Target then
21904 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
21911 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
21913 when Pragma_Unmodified => Unmodified : declare
21915 Arg_Expr : Node_Id;
21916 Arg_Id : Entity_Id;
21918 Ghost_Error_Posted : Boolean := False;
21919 -- Flag set when an error concerning the illegal mix of Ghost and
21920 -- non-Ghost variables is emitted.
21922 Ghost_Id : Entity_Id := Empty;
21923 -- The entity of the first Ghost variable encountered while
21924 -- processing the arguments of the pragma.
21928 Check_At_Least_N_Arguments (1);
21930 -- Loop through arguments
21933 while Present (Arg) loop
21934 Check_No_Identifier (Arg);
21936 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21937 -- in fact generate reference, so that the entity will have a
21938 -- reference, which will inhibit any warnings about it not
21939 -- being referenced, and also properly show up in the ali file
21940 -- as a reference. But this reference is recorded before the
21941 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21942 -- generated for this reference.
21944 Check_Arg_Is_Local_Name (Arg);
21945 Arg_Expr := Get_Pragma_Arg (Arg);
21947 if Is_Entity_Name (Arg_Expr) then
21948 Arg_Id := Entity (Arg_Expr);
21950 if Is_Assignable (Arg_Id) then
21951 Set_Has_Pragma_Unmodified (Arg_Id);
21953 -- A pragma that applies to a Ghost entity becomes Ghost
21954 -- for the purposes of legality checks and removal of
21955 -- ignored Ghost code.
21957 Mark_Pragma_As_Ghost (N, Arg_Id);
21959 -- Capture the entity of the first Ghost variable being
21960 -- processed for error detection purposes.
21962 if Is_Ghost_Entity (Arg_Id) then
21963 if No (Ghost_Id) then
21964 Ghost_Id := Arg_Id;
21967 -- Otherwise the variable is non-Ghost. It is illegal
21968 -- to mix references to Ghost and non-Ghost entities
21971 elsif Present (Ghost_Id)
21972 and then not Ghost_Error_Posted
21974 Ghost_Error_Posted := True;
21976 Error_Msg_Name_1 := Pname;
21978 ("pragma % cannot mention ghost and non-ghost "
21981 Error_Msg_Sloc := Sloc (Ghost_Id);
21982 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
21984 Error_Msg_Sloc := Sloc (Arg_Id);
21985 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
21988 -- Otherwise the pragma referenced an illegal entity
21992 ("pragma% can only be applied to a variable", Arg_Expr);
22004 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22006 -- or when used in a context clause:
22008 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22010 when Pragma_Unreferenced => Unreferenced : declare
22012 Arg_Expr : Node_Id;
22013 Arg_Id : Entity_Id;
22016 Ghost_Error_Posted : Boolean := False;
22017 -- Flag set when an error concerning the illegal mix of Ghost and
22018 -- non-Ghost names is emitted.
22020 Ghost_Id : Entity_Id := Empty;
22021 -- The entity of the first Ghost name encountered while processing
22022 -- the arguments of the pragma.
22026 Check_At_Least_N_Arguments (1);
22028 -- Check case of appearing within context clause
22030 if Is_In_Context_Clause then
22032 -- The arguments must all be units mentioned in a with clause
22033 -- in the same context clause. Note we already checked (in
22034 -- Par.Prag) that the arguments are either identifiers or
22035 -- selected components.
22038 while Present (Arg) loop
22039 Citem := First (List_Containing (N));
22040 while Citem /= N loop
22041 Arg_Expr := Get_Pragma_Arg (Arg);
22043 if Nkind (Citem) = N_With_Clause
22044 and then Same_Name (Name (Citem), Arg_Expr)
22046 Set_Has_Pragma_Unreferenced
22049 (Library_Unit (Citem))));
22050 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
22059 ("argument of pragma% is not withed unit", Arg);
22065 -- Case of not in list of context items
22069 while Present (Arg) loop
22070 Check_No_Identifier (Arg);
22072 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22073 -- will in fact generate reference, so that the entity will
22074 -- have a reference, which will inhibit any warnings about
22075 -- it not being referenced, and also properly show up in the
22076 -- ali file as a reference. But this reference is recorded
22077 -- before the Has_Pragma_Unreferenced flag is set, so that
22078 -- no warning is generated for this reference.
22080 Check_Arg_Is_Local_Name (Arg);
22081 Arg_Expr := Get_Pragma_Arg (Arg);
22083 if Is_Entity_Name (Arg_Expr) then
22084 Arg_Id := Entity (Arg_Expr);
22086 -- If the entity is overloaded, the pragma applies to the
22087 -- most recent overloading, as documented. In this case,
22088 -- name resolution does not generate a reference, so it
22089 -- must be done here explicitly.
22091 if Is_Overloaded (Arg_Expr) then
22092 Generate_Reference (Arg_Id, N);
22095 Set_Has_Pragma_Unreferenced (Arg_Id);
22097 -- A pragma that applies to a Ghost entity becomes Ghost
22098 -- for the purposes of legality checks and removal of
22099 -- ignored Ghost code.
22101 Mark_Pragma_As_Ghost (N, Arg_Id);
22103 -- Capture the entity of the first Ghost name being
22104 -- processed for error detection purposes.
22106 if Is_Ghost_Entity (Arg_Id) then
22107 if No (Ghost_Id) then
22108 Ghost_Id := Arg_Id;
22111 -- Otherwise the name is non-Ghost. It is illegal to mix
22112 -- references to Ghost and non-Ghost entities
22115 elsif Present (Ghost_Id)
22116 and then not Ghost_Error_Posted
22118 Ghost_Error_Posted := True;
22120 Error_Msg_Name_1 := Pname;
22122 ("pragma % cannot mention ghost and non-ghost names",
22125 Error_Msg_Sloc := Sloc (Ghost_Id);
22126 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22128 Error_Msg_Sloc := Sloc (Arg_Id);
22129 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22138 --------------------------
22139 -- Unreferenced_Objects --
22140 --------------------------
22142 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22144 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22146 Arg_Expr : Node_Id;
22147 Arg_Id : Entity_Id;
22149 Ghost_Error_Posted : Boolean := False;
22150 -- Flag set when an error concerning the illegal mix of Ghost and
22151 -- non-Ghost types is emitted.
22153 Ghost_Id : Entity_Id := Empty;
22154 -- The entity of the first Ghost type encountered while processing
22155 -- the arguments of the pragma.
22159 Check_At_Least_N_Arguments (1);
22162 while Present (Arg) loop
22163 Check_No_Identifier (Arg);
22164 Check_Arg_Is_Local_Name (Arg);
22165 Arg_Expr := Get_Pragma_Arg (Arg);
22167 if Is_Entity_Name (Arg_Expr) then
22168 Arg_Id := Entity (Arg_Expr);
22170 if Is_Type (Arg_Id) then
22171 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22173 -- A pragma that applies to a Ghost entity becomes Ghost
22174 -- for the purposes of legality checks and removal of
22175 -- ignored Ghost code.
22177 Mark_Pragma_As_Ghost (N, Arg_Id);
22179 -- Capture the entity of the first Ghost type being
22180 -- processed for error detection purposes.
22182 if Is_Ghost_Entity (Arg_Id) then
22183 if No (Ghost_Id) then
22184 Ghost_Id := Arg_Id;
22187 -- Otherwise the type is non-Ghost. It is illegal to mix
22188 -- references to Ghost and non-Ghost entities
22191 elsif Present (Ghost_Id)
22192 and then not Ghost_Error_Posted
22194 Ghost_Error_Posted := True;
22196 Error_Msg_Name_1 := Pname;
22198 ("pragma % cannot mention ghost and non-ghost types",
22201 Error_Msg_Sloc := Sloc (Ghost_Id);
22202 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22204 Error_Msg_Sloc := Sloc (Arg_Id);
22205 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22209 ("argument for pragma% must be type or subtype", Arg);
22213 ("argument for pragma% must be type or subtype", Arg);
22218 end Unreferenced_Objects;
22220 ------------------------------
22221 -- Unreserve_All_Interrupts --
22222 ------------------------------
22224 -- pragma Unreserve_All_Interrupts;
22226 when Pragma_Unreserve_All_Interrupts =>
22228 Check_Arg_Count (0);
22230 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22231 Unreserve_All_Interrupts := True;
22238 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22240 when Pragma_Unsuppress =>
22242 Process_Suppress_Unsuppress (Suppress_Case => False);
22244 ----------------------------
22245 -- Unevaluated_Use_Of_Old --
22246 ----------------------------
22248 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22250 when Pragma_Unevaluated_Use_Of_Old =>
22252 Check_Arg_Count (1);
22253 Check_No_Identifiers;
22254 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22256 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22257 -- a declarative part or a package spec.
22259 if not Is_Configuration_Pragma then
22260 Check_Is_In_Decl_Part_Or_Package_Spec;
22263 -- Store proper setting of Uneval_Old
22265 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22266 Uneval_Old := Fold_Upper (Name_Buffer (1));
22268 -------------------
22269 -- Use_VADS_Size --
22270 -------------------
22272 -- pragma Use_VADS_Size;
22274 when Pragma_Use_VADS_Size =>
22276 Check_Arg_Count (0);
22277 Check_Valid_Configuration_Pragma;
22278 Use_VADS_Size := True;
22280 ---------------------
22281 -- Validity_Checks --
22282 ---------------------
22284 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22286 when Pragma_Validity_Checks => Validity_Checks : declare
22287 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22293 Check_Arg_Count (1);
22294 Check_No_Identifiers;
22296 -- Pragma always active unless in CodePeer or GNATprove modes,
22297 -- which use a fixed configuration of validity checks.
22299 if not (CodePeer_Mode or GNATprove_Mode) then
22300 if Nkind (A) = N_String_Literal then
22304 Slen : constant Natural := Natural (String_Length (S));
22305 Options : String (1 .. Slen);
22309 -- Couldn't we use a for loop here over Options'Range???
22313 C := Get_String_Char (S, Int (J));
22315 -- This is a weird test, it skips setting validity
22316 -- checks entirely if any element of S is out of
22317 -- range of Character, what is that about ???
22319 exit when not In_Character_Range (C);
22320 Options (J) := Get_Character (C);
22323 Set_Validity_Check_Options (Options);
22331 elsif Nkind (A) = N_Identifier then
22332 if Chars (A) = Name_All_Checks then
22333 Set_Validity_Check_Options ("a");
22334 elsif Chars (A) = Name_On then
22335 Validity_Checks_On := True;
22336 elsif Chars (A) = Name_Off then
22337 Validity_Checks_On := False;
22341 end Validity_Checks;
22347 -- pragma Volatile (LOCAL_NAME);
22349 when Pragma_Volatile =>
22350 Process_Atomic_Independent_Shared_Volatile;
22352 -------------------------
22353 -- Volatile_Components --
22354 -------------------------
22356 -- pragma Volatile_Components (array_LOCAL_NAME);
22358 -- Volatile is handled by the same circuit as Atomic_Components
22360 --------------------------
22361 -- Volatile_Full_Access --
22362 --------------------------
22364 -- pragma Volatile_Full_Access (LOCAL_NAME);
22366 when Pragma_Volatile_Full_Access =>
22368 Process_Atomic_Independent_Shared_Volatile;
22370 -----------------------
22371 -- Volatile_Function --
22372 -----------------------
22374 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22376 when Pragma_Volatile_Function => Volatile_Function : declare
22377 Over_Id : Entity_Id;
22378 Spec_Id : Entity_Id;
22379 Subp_Decl : Node_Id;
22383 Check_No_Identifiers;
22384 Check_At_Most_N_Arguments (1);
22387 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22389 -- Generic subprogram
22391 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22394 -- Body acts as spec
22396 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22397 and then No (Corresponding_Spec (Subp_Decl))
22401 -- Body stub acts as spec
22403 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22404 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22410 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22418 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22420 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22425 -- Chain the pragma on the contract for completeness
22427 Add_Contract_Item (N, Spec_Id);
22429 -- The legality checks of pragma Volatile_Function are affected by
22430 -- the SPARK mode in effect. Analyze all pragmas in a specific
22433 Analyze_If_Present (Pragma_SPARK_Mode);
22435 -- A pragma that applies to a Ghost entity becomes Ghost for the
22436 -- purposes of legality checks and removal of ignored Ghost code.
22438 Mark_Pragma_As_Ghost (N, Spec_Id);
22440 -- A volatile function cannot override a non-volatile function
22441 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22442 -- in New_Overloaded_Entity, however at that point the pragma has
22443 -- not been processed yet.
22445 Over_Id := Overridden_Operation (Spec_Id);
22447 if Present (Over_Id)
22448 and then not Is_Volatile_Function (Over_Id)
22451 ("incompatible volatile function values in effect", Spec_Id);
22453 Error_Msg_Sloc := Sloc (Over_Id);
22455 ("\& declared # with Volatile_Function value `False`",
22458 Error_Msg_Sloc := Sloc (Spec_Id);
22460 ("\overridden # with Volatile_Function value `True`",
22464 -- Analyze the Boolean expression (if any)
22466 if Present (Arg1) then
22467 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22469 end Volatile_Function;
22471 ----------------------
22472 -- Warning_As_Error --
22473 ----------------------
22475 -- pragma Warning_As_Error (static_string_EXPRESSION);
22477 when Pragma_Warning_As_Error =>
22479 Check_Arg_Count (1);
22480 Check_No_Identifiers;
22481 Check_Valid_Configuration_Pragma;
22483 if not Is_Static_String_Expression (Arg1) then
22485 ("argument of pragma% must be static string expression",
22488 -- OK static string expression
22491 Acquire_Warning_Match_String (Arg1);
22492 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
22493 Warnings_As_Errors (Warnings_As_Errors_Count) :=
22494 new String'(Name_Buffer (1 .. Name_Len));
22501 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22503 -- DETAILS ::= On | Off
22504 -- DETAILS ::= On | Off, local_NAME
22505 -- DETAILS ::= static_string_EXPRESSION
22506 -- DETAILS ::= On | Off, static_string_EXPRESSION
22508 -- TOOL_NAME ::= GNAT | GNATProve
22510 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22512 -- Note: If the first argument matches an allowed tool name, it is
22513 -- always considered to be a tool name, even if there is a string
22514 -- variable of that name.
22516 -- Note if the second argument of DETAILS is a local_NAME then the
22517 -- second form is always understood. If the intention is to use
22518 -- the fourth form, then you can write NAME & "" to force the
22519 -- intepretation as a static_string_EXPRESSION.
22521 when Pragma_Warnings => Warnings : declare
22522 Reason : String_Id;
22526 Check_At_Least_N_Arguments (1);
22528 -- See if last argument is labeled Reason. If so, make sure we
22529 -- have a string literal or a concatenation of string literals,
22530 -- and acquire the REASON string. Then remove the REASON argument
22531 -- by decreasing Num_Args by one; Remaining processing looks only
22532 -- at first Num_Args arguments).
22535 Last_Arg : constant Node_Id :=
22536 Last (Pragma_Argument_Associations (N));
22539 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22540 and then Chars (Last_Arg) = Name_Reason
22543 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22544 Reason := End_String;
22545 Arg_Count := Arg_Count - 1;
22547 -- Not allowed in compiler units (bootstrap issues)
22549 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22551 -- No REASON string, set null string as reason
22554 Reason := Null_String_Id;
22558 -- Now proceed with REASON taken care of and eliminated
22560 Check_No_Identifiers;
22562 -- If debug flag -gnatd.i is set, pragma is ignored
22564 if Debug_Flag_Dot_I then
22568 -- Process various forms of the pragma
22571 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22572 Shifted_Args : List_Id;
22575 -- See if first argument is a tool name, currently either
22576 -- GNAT or GNATprove. If so, either ignore the pragma if the
22577 -- tool used does not match, or continue as if no tool name
22578 -- was given otherwise, by shifting the arguments.
22580 if Nkind (Argx) = N_Identifier
22581 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22583 if Chars (Argx) = Name_Gnat then
22584 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22585 Rewrite (N, Make_Null_Statement (Loc));
22590 elsif Chars (Argx) = Name_Gnatprove then
22591 if not GNATprove_Mode then
22592 Rewrite (N, Make_Null_Statement (Loc));
22598 raise Program_Error;
22601 -- At this point, the pragma Warnings applies to the tool,
22602 -- so continue with shifted arguments.
22604 Arg_Count := Arg_Count - 1;
22606 if Arg_Count = 1 then
22607 Shifted_Args := New_List (New_Copy (Arg2));
22608 elsif Arg_Count = 2 then
22609 Shifted_Args := New_List (New_Copy (Arg2),
22611 elsif Arg_Count = 3 then
22612 Shifted_Args := New_List (New_Copy (Arg2),
22616 raise Program_Error;
22621 Chars => Name_Warnings,
22622 Pragma_Argument_Associations => Shifted_Args));
22627 -- One argument case
22629 if Arg_Count = 1 then
22631 -- On/Off one argument case was processed by parser
22633 if Nkind (Argx) = N_Identifier
22634 and then Nam_In (Chars (Argx), Name_On, Name_Off)
22638 -- One argument case must be ON/OFF or static string expr
22640 elsif not Is_Static_String_Expression (Arg1) then
22642 ("argument of pragma% must be On/Off or static string "
22643 & "expression", Arg1);
22645 -- One argument string expression case
22649 Lit : constant Node_Id := Expr_Value_S (Argx);
22650 Str : constant String_Id := Strval (Lit);
22651 Len : constant Nat := String_Length (Str);
22659 while J <= Len loop
22660 C := Get_String_Char (Str, J);
22661 OK := In_Character_Range (C);
22664 Chr := Get_Character (C);
22666 -- Dash case: only -Wxxx is accepted
22673 C := Get_String_Char (Str, J);
22674 Chr := Get_Character (C);
22675 exit when Chr = 'W';
22680 elsif J < Len and then Chr = '.' then
22682 C := Get_String_Char (Str, J);
22683 Chr := Get_Character (C);
22685 if not Set_Dot_Warning_Switch (Chr) then
22687 ("invalid warning switch character "
22688 & '.' & Chr, Arg1);
22694 OK := Set_Warning_Switch (Chr);
22700 ("invalid warning switch character " & Chr,
22709 -- Two or more arguments (must be two)
22712 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22713 Check_Arg_Count (2);
22721 E_Id := Get_Pragma_Arg (Arg2);
22724 -- In the expansion of an inlined body, a reference to
22725 -- the formal may be wrapped in a conversion if the
22726 -- actual is a conversion. Retrieve the real entity name.
22728 if (In_Instance_Body or In_Inlined_Body)
22729 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
22731 E_Id := Expression (E_Id);
22734 -- Entity name case
22736 if Is_Entity_Name (E_Id) then
22737 E := Entity (E_Id);
22744 (E, (Chars (Get_Pragma_Arg (Arg1)) =
22747 -- For OFF case, make entry in warnings off
22748 -- pragma table for later processing. But we do
22749 -- not do that within an instance, since these
22750 -- warnings are about what is needed in the
22751 -- template, not an instance of it.
22753 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
22754 and then Warn_On_Warnings_Off
22755 and then not In_Instance
22757 Warnings_Off_Pragmas.Append ((N, E, Reason));
22760 if Is_Enumeration_Type (E) then
22764 Lit := First_Literal (E);
22765 while Present (Lit) loop
22766 Set_Warnings_Off (Lit);
22767 Next_Literal (Lit);
22772 exit when No (Homonym (E));
22777 -- Error if not entity or static string expression case
22779 elsif not Is_Static_String_Expression (Arg2) then
22781 ("second argument of pragma% must be entity name "
22782 & "or static string expression", Arg2);
22784 -- Static string expression case
22787 Acquire_Warning_Match_String (Arg2);
22789 -- Note on configuration pragma case: If this is a
22790 -- configuration pragma, then for an OFF pragma, we
22791 -- just set Config True in the call, which is all
22792 -- that needs to be done. For the case of ON, this
22793 -- is normally an error, unless it is canceling the
22794 -- effect of a previous OFF pragma in the same file.
22795 -- In any other case, an error will be signalled (ON
22796 -- with no matching OFF).
22798 -- Note: We set Used if we are inside a generic to
22799 -- disable the test that the non-config case actually
22800 -- cancels a warning. That's because we can't be sure
22801 -- there isn't an instantiation in some other unit
22802 -- where a warning is suppressed.
22804 -- We could do a little better here by checking if the
22805 -- generic unit we are inside is public, but for now
22806 -- we don't bother with that refinement.
22808 if Chars (Argx) = Name_Off then
22809 Set_Specific_Warning_Off
22810 (Loc, Name_Buffer (1 .. Name_Len), Reason,
22811 Config => Is_Configuration_Pragma,
22812 Used => Inside_A_Generic or else In_Instance);
22814 elsif Chars (Argx) = Name_On then
22815 Set_Specific_Warning_On
22816 (Loc, Name_Buffer (1 .. Name_Len), Err);
22820 ("??pragma Warnings On with no matching "
22821 & "Warnings Off", Loc);
22830 -------------------
22831 -- Weak_External --
22832 -------------------
22834 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
22836 when Pragma_Weak_External => Weak_External : declare
22841 Check_Arg_Count (1);
22842 Check_Optional_Identifier (Arg1, Name_Entity);
22843 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22844 Ent := Entity (Get_Pragma_Arg (Arg1));
22846 if Rep_Item_Too_Early (Ent, N) then
22849 Ent := Underlying_Type (Ent);
22852 -- The only processing required is to link this item on to the
22853 -- list of rep items for the given entity. This is accomplished
22854 -- by the call to Rep_Item_Too_Late (when no error is detected
22855 -- and False is returned).
22857 if Rep_Item_Too_Late (Ent, N) then
22860 Set_Has_Gigi_Rep_Item (Ent);
22864 -----------------------------
22865 -- Wide_Character_Encoding --
22866 -----------------------------
22868 -- pragma Wide_Character_Encoding (IDENTIFIER);
22870 when Pragma_Wide_Character_Encoding =>
22873 -- Nothing to do, handled in parser. Note that we do not enforce
22874 -- configuration pragma placement, this pragma can appear at any
22875 -- place in the source, allowing mixed encodings within a single
22880 --------------------
22881 -- Unknown_Pragma --
22882 --------------------
22884 -- Should be impossible, since the case of an unknown pragma is
22885 -- separately processed before the case statement is entered.
22887 when Unknown_Pragma =>
22888 raise Program_Error;
22891 -- AI05-0144: detect dangerous order dependence. Disabled for now,
22892 -- until AI is formally approved.
22894 -- Check_Order_Dependence;
22897 when Pragma_Exit => null;
22898 end Analyze_Pragma;
22900 ---------------------------------------------
22901 -- Analyze_Pre_Post_Condition_In_Decl_Part --
22902 ---------------------------------------------
22904 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
22905 procedure Process_Class_Wide_Condition
22907 Spec_Id : Entity_Id;
22908 Subp_Decl : Node_Id);
22909 -- Replace the type of all references to the controlling formal of
22910 -- subprogram Spec_Id found in expression Expr with the corresponding
22911 -- class-wide type. Subp_Decl is the subprogram [body] declaration
22912 -- where the pragma resides.
22914 ----------------------------------
22915 -- Process_Class_Wide_Condition --
22916 ----------------------------------
22918 procedure Process_Class_Wide_Condition
22920 Spec_Id : Entity_Id;
22921 Subp_Decl : Node_Id)
22923 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
22925 ACW : Entity_Id := Empty;
22926 -- Access to Disp_Typ'Class, created if there is a controlling formal
22927 -- that is an access parameter.
22929 function Access_Class_Wide_Type return Entity_Id;
22930 -- If expression Expr contains a reference to a controlling access
22931 -- parameter, create an access to Disp_Typ'Class for the necessary
22932 -- conversions if one does not exist.
22934 function Replace_Type (N : Node_Id) return Traverse_Result;
22935 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
22936 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
22937 -- name that denotes a formal parameter of type Disp_Typ is treated
22938 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
22939 -- formal access parameter of type access-to-Disp_Typ is interpreted
22940 -- as with type access-to-Disp_Typ'Class. This ensures the expression
22941 -- is well defined for a primitive subprogram of a type descended
22944 ----------------------------
22945 -- Access_Class_Wide_Type --
22946 ----------------------------
22948 function Access_Class_Wide_Type return Entity_Id is
22949 Loc : constant Source_Ptr := Sloc (N);
22953 ACW := Make_Temporary (Loc, 'T');
22955 Insert_Before_And_Analyze (Subp_Decl,
22956 Make_Full_Type_Declaration (Loc,
22957 Defining_Identifier => ACW,
22959 Make_Access_To_Object_Definition (Loc,
22960 Subtype_Indication =>
22961 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
22962 All_Present => True)));
22964 Freeze_Before (Subp_Decl, ACW);
22968 end Access_Class_Wide_Type;
22974 function Replace_Type (N : Node_Id) return Traverse_Result is
22975 Context : constant Node_Id := Parent (N);
22976 Loc : constant Source_Ptr := Sloc (N);
22977 CW_Typ : Entity_Id := Empty;
22982 if Is_Entity_Name (N)
22983 and then Present (Entity (N))
22984 and then Is_Formal (Entity (N))
22987 Typ := Etype (Ent);
22989 -- Do not perform the type replacement for selector names in
22990 -- parameter associations. These carry an entity for reference
22991 -- purposes, but semantically they are just identifiers.
22993 if Nkind (Context) = N_Type_Conversion then
22996 elsif Nkind (Context) = N_Parameter_Association
22997 and then Selector_Name (Context) = N
23001 elsif Typ = Disp_Typ then
23002 CW_Typ := Class_Wide_Type (Typ);
23004 elsif Is_Access_Type (Typ)
23005 and then Designated_Type (Typ) = Disp_Typ
23007 CW_Typ := Access_Class_Wide_Type;
23010 if Present (CW_Typ) then
23012 Make_Type_Conversion (Loc,
23013 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
23014 Expression => New_Occurrence_Of (Ent, Loc)));
23015 Set_Etype (N, CW_Typ);
23022 procedure Replace_Types is new Traverse_Proc (Replace_Type);
23024 -- Start of processing for Process_Class_Wide_Condition
23027 -- The subprogram subject to Pre'Class/Post'Class does not have a
23028 -- dispatching type, therefore the aspect/pragma is illegal.
23030 if No (Disp_Typ) then
23031 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23033 if From_Aspect_Specification (N) then
23035 ("aspect % can only be specified for a primitive operation "
23036 & "of a tagged type", Corresponding_Aspect (N));
23038 -- The pragma is a source construct
23042 ("pragma % can only be specified for a primitive operation "
23043 & "of a tagged type", N);
23047 Replace_Types (Expr);
23048 end Process_Class_Wide_Condition;
23052 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23053 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23054 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23056 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23058 Restore_Scope : Boolean := False;
23060 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23063 -- Do not analyze the pragma multiple times
23065 if Is_Analyzed_Pragma (N) then
23069 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23070 -- analysis of the pragma, the Ghost mode at point of declaration and
23071 -- point of analysis may not necessarely be the same. Use the mode in
23072 -- effect at the point of declaration.
23074 Set_Ghost_Mode (N);
23076 -- Ensure that the subprogram and its formals are visible when analyzing
23077 -- the expression of the pragma.
23079 if not In_Open_Scopes (Spec_Id) then
23080 Restore_Scope := True;
23081 Push_Scope (Spec_Id);
23083 if Is_Generic_Subprogram (Spec_Id) then
23084 Install_Generic_Formals (Spec_Id);
23086 Install_Formals (Spec_Id);
23090 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23092 -- For a class-wide condition, a reference to a controlling formal must
23093 -- be interpreted as having the class-wide type (or an access to such)
23094 -- so that the inherited condition can be properly applied to any
23095 -- overriding operation (see ARM12 6.6.1 (7)).
23097 if Class_Present (N) then
23098 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
23101 if Restore_Scope then
23105 -- Currently it is not possible to inline pre/postconditions on a
23106 -- subprogram subject to pragma Inline_Always.
23108 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23109 Ghost_Mode := Save_Ghost_Mode;
23111 Set_Is_Analyzed_Pragma (N);
23112 end Analyze_Pre_Post_Condition_In_Decl_Part;
23114 ------------------------------------------
23115 -- Analyze_Refined_Depends_In_Decl_Part --
23116 ------------------------------------------
23118 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23119 Body_Inputs : Elist_Id := No_Elist;
23120 Body_Outputs : Elist_Id := No_Elist;
23121 -- The inputs and outputs of the subprogram body synthesized from pragma
23122 -- Refined_Depends.
23124 Dependencies : List_Id := No_List;
23126 -- The corresponding Depends pragma along with its clauses
23128 Matched_Items : Elist_Id := No_Elist;
23129 -- A list containing the entities of all successfully matched items
23130 -- found in pragma Depends.
23132 Refinements : List_Id := No_List;
23133 -- The clauses of pragma Refined_Depends
23135 Spec_Id : Entity_Id;
23136 -- The entity of the subprogram subject to pragma Refined_Depends
23138 Spec_Inputs : Elist_Id := No_Elist;
23139 Spec_Outputs : Elist_Id := No_Elist;
23140 -- The inputs and outputs of the subprogram spec synthesized from pragma
23143 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23144 -- Try to match a single dependency clause Dep_Clause against one or
23145 -- more refinement clauses found in list Refinements. Each successful
23146 -- match eliminates at least one refinement clause from Refinements.
23148 procedure Check_Output_States;
23149 -- Determine whether pragma Depends contains an output state with a
23150 -- visible refinement and if so, ensure that pragma Refined_Depends
23151 -- mentions all its constituents as outputs.
23153 procedure Normalize_Clauses (Clauses : List_Id);
23154 -- Given a list of dependence or refinement clauses Clauses, normalize
23155 -- each clause by creating multiple dependencies with exactly one input
23158 procedure Report_Extra_Clauses;
23159 -- Emit an error for each extra clause found in list Refinements
23161 -----------------------------
23162 -- Check_Dependency_Clause --
23163 -----------------------------
23165 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23166 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23167 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23169 function Is_In_Out_State_Clause return Boolean;
23170 -- Determine whether dependence clause Dep_Clause denotes an abstract
23171 -- state that depends on itself (State => State).
23173 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23174 -- Determine whether item Item denotes an abstract state with visible
23175 -- null refinement.
23177 procedure Match_Items
23178 (Dep_Item : Node_Id;
23179 Ref_Item : Node_Id;
23180 Matched : out Boolean);
23181 -- Try to match dependence item Dep_Item against refinement item
23182 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23183 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23184 -- the following conformance scenarios is in effect:
23185 -- 1) Both items denote null
23186 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23187 -- 3) Both items denote attribute 'Result
23188 -- 4) Both items denote the same object
23189 -- 5) Both items denote the same formal parameter
23190 -- 6) Both items denote the same current instance of a type
23191 -- 7) Both items denote the same discriminant
23192 -- 8) Dep_Item is an abstract state with visible null refinement
23193 -- and Ref_Item denotes null.
23194 -- 9) Dep_Item is an abstract state with visible null refinement
23195 -- and Ref_Item is Empty (special case).
23196 -- 10) Dep_Item is an abstract state with visible non-null
23197 -- refinement and Ref_Item denotes one of its constituents.
23198 -- 11) Dep_Item is an abstract state without a visible refinement
23199 -- and Ref_Item denotes the same state.
23200 -- When scenario 10 is in effect, the entity of the abstract state
23201 -- denoted by Dep_Item is added to list Refined_States.
23203 procedure Record_Item (Item_Id : Entity_Id);
23204 -- Store the entity of an item denoted by Item_Id in Matched_Items
23206 ----------------------------
23207 -- Is_In_Out_State_Clause --
23208 ----------------------------
23210 function Is_In_Out_State_Clause return Boolean is
23211 Dep_Input_Id : Entity_Id;
23212 Dep_Output_Id : Entity_Id;
23215 -- Detect the following clause:
23218 if Is_Entity_Name (Dep_Input)
23219 and then Is_Entity_Name (Dep_Output)
23221 -- Handle abstract views generated for limited with clauses
23223 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23224 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23227 Ekind (Dep_Input_Id) = E_Abstract_State
23228 and then Dep_Input_Id = Dep_Output_Id;
23232 end Is_In_Out_State_Clause;
23234 ---------------------------
23235 -- Is_Null_Refined_State --
23236 ---------------------------
23238 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23239 Item_Id : Entity_Id;
23242 if Is_Entity_Name (Item) then
23244 -- Handle abstract views generated for limited with clauses
23246 Item_Id := Available_View (Entity_Of (Item));
23249 Ekind (Item_Id) = E_Abstract_State
23250 and then Has_Null_Refinement (Item_Id);
23254 end Is_Null_Refined_State;
23260 procedure Match_Items
23261 (Dep_Item : Node_Id;
23262 Ref_Item : Node_Id;
23263 Matched : out Boolean)
23265 Dep_Item_Id : Entity_Id;
23266 Ref_Item_Id : Entity_Id;
23269 -- Assume that the two items do not match
23273 -- A null matches null or Empty (special case)
23275 if Nkind (Dep_Item) = N_Null
23276 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23280 -- Attribute 'Result matches attribute 'Result
23282 elsif Is_Attribute_Result (Dep_Item)
23283 and then Is_Attribute_Result (Dep_Item)
23287 -- Abstract states, current instances of concurrent types,
23288 -- discriminants, formal parameters and objects.
23290 elsif Is_Entity_Name (Dep_Item) then
23292 -- Handle abstract views generated for limited with clauses
23294 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23296 if Ekind (Dep_Item_Id) = E_Abstract_State then
23298 -- An abstract state with visible null refinement matches
23299 -- null or Empty (special case).
23301 if Has_Null_Refinement (Dep_Item_Id)
23302 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23304 Record_Item (Dep_Item_Id);
23307 -- An abstract state with visible non-null refinement
23308 -- matches one of its constituents.
23310 elsif Has_Non_Null_Refinement (Dep_Item_Id) then
23311 if Is_Entity_Name (Ref_Item) then
23312 Ref_Item_Id := Entity_Of (Ref_Item);
23314 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23317 and then Present (Encapsulating_State (Ref_Item_Id))
23318 and then Encapsulating_State (Ref_Item_Id) =
23321 Record_Item (Dep_Item_Id);
23326 -- An abstract state without a visible refinement matches
23329 elsif Is_Entity_Name (Ref_Item)
23330 and then Entity_Of (Ref_Item) = Dep_Item_Id
23332 Record_Item (Dep_Item_Id);
23336 -- A current instance of a concurrent type, discriminant,
23337 -- formal parameter or an object matches itself.
23339 elsif Is_Entity_Name (Ref_Item)
23340 and then Entity_Of (Ref_Item) = Dep_Item_Id
23342 Record_Item (Dep_Item_Id);
23352 procedure Record_Item (Item_Id : Entity_Id) is
23354 if not Contains (Matched_Items, Item_Id) then
23355 Append_New_Elmt (Item_Id, Matched_Items);
23361 Clause_Matched : Boolean := False;
23362 Dummy : Boolean := False;
23363 Inputs_Match : Boolean;
23364 Next_Ref_Clause : Node_Id;
23365 Outputs_Match : Boolean;
23366 Ref_Clause : Node_Id;
23367 Ref_Input : Node_Id;
23368 Ref_Output : Node_Id;
23370 -- Start of processing for Check_Dependency_Clause
23373 -- Do not perform this check in an instance because it was already
23374 -- performed successfully in the generic template.
23376 if Is_Generic_Instance (Spec_Id) then
23380 -- Examine all refinement clauses and compare them against the
23381 -- dependence clause.
23383 Ref_Clause := First (Refinements);
23384 while Present (Ref_Clause) loop
23385 Next_Ref_Clause := Next (Ref_Clause);
23387 -- Obtain the attributes of the current refinement clause
23389 Ref_Input := Expression (Ref_Clause);
23390 Ref_Output := First (Choices (Ref_Clause));
23392 -- The current refinement clause matches the dependence clause
23393 -- when both outputs match and both inputs match. See routine
23394 -- Match_Items for all possible conformance scenarios.
23396 -- Depends Dep_Output => Dep_Input
23400 -- Refined_Depends Ref_Output => Ref_Input
23403 (Dep_Item => Dep_Input,
23404 Ref_Item => Ref_Input,
23405 Matched => Inputs_Match);
23408 (Dep_Item => Dep_Output,
23409 Ref_Item => Ref_Output,
23410 Matched => Outputs_Match);
23412 -- An In_Out state clause may be matched against a refinement with
23413 -- a null input or null output as long as the non-null side of the
23414 -- relation contains a valid constituent of the In_Out_State.
23416 if Is_In_Out_State_Clause then
23418 -- Depends => (State => State)
23419 -- Refined_Depends => (null => Constit) -- OK
23422 and then not Outputs_Match
23423 and then Nkind (Ref_Output) = N_Null
23425 Outputs_Match := True;
23428 -- Depends => (State => State)
23429 -- Refined_Depends => (Constit => null) -- OK
23431 if not Inputs_Match
23432 and then Outputs_Match
23433 and then Nkind (Ref_Input) = N_Null
23435 Inputs_Match := True;
23439 -- The current refinement clause is legally constructed following
23440 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23441 -- the pool of candidates. The seach continues because a single
23442 -- dependence clause may have multiple matching refinements.
23444 if Inputs_Match and then Outputs_Match then
23445 Clause_Matched := True;
23446 Remove (Ref_Clause);
23449 Ref_Clause := Next_Ref_Clause;
23452 -- Depending on the order or composition of refinement clauses, an
23453 -- In_Out state clause may not be directly refinable.
23455 -- Depends => ((Output, State) => (Input, State))
23456 -- Refined_State => (State => (Constit_1, Constit_2))
23457 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23459 -- Matching normalized clause (State => State) fails because there is
23460 -- no direct refinement capable of satisfying this relation. Another
23461 -- similar case arises when clauses (Constit_1 => Input) and (Output
23462 -- => Constit_2) are matched first, leaving no candidates for clause
23463 -- (State => State). Both scenarios are legal as long as one of the
23464 -- previous clauses mentioned a valid constituent of State.
23466 if not Clause_Matched
23467 and then Is_In_Out_State_Clause
23469 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23471 Clause_Matched := True;
23474 -- A clause where the input is an abstract state with visible null
23475 -- refinement is implicitly matched when the output has already been
23476 -- matched in a previous clause.
23478 -- Depends => (Output => State) -- implicitly OK
23479 -- Refined_State => (State => null)
23480 -- Refined_Depends => (Output => ...)
23482 if not Clause_Matched
23483 and then Is_Null_Refined_State (Dep_Input)
23484 and then Is_Entity_Name (Dep_Output)
23486 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23488 Clause_Matched := True;
23491 -- A clause where the output is an abstract state with visible null
23492 -- refinement is implicitly matched when the input has already been
23493 -- matched in a previous clause.
23495 -- Depends => (State => Input) -- implicitly OK
23496 -- Refined_State => (State => null)
23497 -- Refined_Depends => (... => Input)
23499 if not Clause_Matched
23500 and then Is_Null_Refined_State (Dep_Output)
23501 and then Is_Entity_Name (Dep_Input)
23503 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23505 Clause_Matched := True;
23508 -- At this point either all refinement clauses have been examined or
23509 -- pragma Refined_Depends contains a solitary null. Only an abstract
23510 -- state with null refinement can possibly match these cases.
23512 -- Depends => (State => null)
23513 -- Refined_State => (State => null)
23514 -- Refined_Depends => null -- OK
23516 if not Clause_Matched then
23518 (Dep_Item => Dep_Input,
23520 Matched => Inputs_Match);
23523 (Dep_Item => Dep_Output,
23525 Matched => Outputs_Match);
23527 Clause_Matched := Inputs_Match and Outputs_Match;
23530 -- If the contents of Refined_Depends are legal, then the current
23531 -- dependence clause should be satisfied either by an explicit match
23532 -- or by one of the special cases.
23534 if not Clause_Matched then
23536 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
23537 & "matching refinement in body"), Dep_Clause, Spec_Id);
23539 end Check_Dependency_Clause;
23541 -------------------------
23542 -- Check_Output_States --
23543 -------------------------
23545 procedure Check_Output_States is
23546 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23547 -- Determine whether all constituents of state State_Id with visible
23548 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23549 -- error if this is not the case.
23551 -----------------------------
23552 -- Check_Constituent_Usage --
23553 -----------------------------
23555 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23556 Constit_Elmt : Elmt_Id;
23557 Constit_Id : Entity_Id;
23558 Posted : Boolean := False;
23561 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23562 while Present (Constit_Elmt) loop
23563 Constit_Id := Node (Constit_Elmt);
23565 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23567 if Present (Body_Inputs)
23568 and then Appears_In (Body_Inputs, Constit_Id)
23570 Error_Msg_Name_1 := Chars (State_Id);
23572 ("constituent & of state % must act as output in "
23573 & "dependence refinement", N, Constit_Id);
23575 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23577 elsif No (Body_Outputs)
23578 or else not Appears_In (Body_Outputs, Constit_Id)
23583 ("output state & must be replaced by all its "
23584 & "constituents in dependence refinement",
23589 ("\constituent & is missing in output list",
23593 Next_Elmt (Constit_Elmt);
23595 end Check_Constituent_Usage;
23600 Item_Elmt : Elmt_Id;
23601 Item_Id : Entity_Id;
23603 -- Start of processing for Check_Output_States
23606 -- Do not perform this check in an instance because it was already
23607 -- performed successfully in the generic template.
23609 if Is_Generic_Instance (Spec_Id) then
23612 -- Inspect the outputs of pragma Depends looking for a state with a
23613 -- visible refinement.
23615 elsif Present (Spec_Outputs) then
23616 Item_Elmt := First_Elmt (Spec_Outputs);
23617 while Present (Item_Elmt) loop
23618 Item := Node (Item_Elmt);
23620 -- Deal with the mixed nature of the input and output lists
23622 if Nkind (Item) = N_Defining_Identifier then
23625 Item_Id := Available_View (Entity_Of (Item));
23628 if Ekind (Item_Id) = E_Abstract_State then
23630 -- The state acts as an input-output, skip it
23632 if Present (Spec_Inputs)
23633 and then Appears_In (Spec_Inputs, Item_Id)
23637 -- Ensure that all of the constituents are utilized as
23638 -- outputs in pragma Refined_Depends.
23640 elsif Has_Non_Null_Refinement (Item_Id) then
23641 Check_Constituent_Usage (Item_Id);
23645 Next_Elmt (Item_Elmt);
23648 end Check_Output_States;
23650 -----------------------
23651 -- Normalize_Clauses --
23652 -----------------------
23654 procedure Normalize_Clauses (Clauses : List_Id) is
23655 procedure Normalize_Inputs (Clause : Node_Id);
23656 -- Normalize clause Clause by creating multiple clauses for each
23657 -- input item of Clause. It is assumed that Clause has exactly one
23658 -- output. The transformation is as follows:
23660 -- Output => (Input_1, Input_2) -- original
23662 -- Output => Input_1 -- normalizations
23663 -- Output => Input_2
23665 procedure Normalize_Outputs (Clause : Node_Id);
23666 -- Normalize clause Clause by creating multiple clause for each
23667 -- output item of Clause. The transformation is as follows:
23669 -- (Output_1, Output_2) => Input -- original
23671 -- Output_1 => Input -- normalization
23672 -- Output_2 => Input
23674 ----------------------
23675 -- Normalize_Inputs --
23676 ----------------------
23678 procedure Normalize_Inputs (Clause : Node_Id) is
23679 Inputs : constant Node_Id := Expression (Clause);
23680 Loc : constant Source_Ptr := Sloc (Clause);
23681 Output : constant List_Id := Choices (Clause);
23682 Last_Input : Node_Id;
23684 New_Clause : Node_Id;
23685 Next_Input : Node_Id;
23688 -- Normalization is performed only when the original clause has
23689 -- more than one input. Multiple inputs appear as an aggregate.
23691 if Nkind (Inputs) = N_Aggregate then
23692 Last_Input := Last (Expressions (Inputs));
23694 -- Create a new clause for each input
23696 Input := First (Expressions (Inputs));
23697 while Present (Input) loop
23698 Next_Input := Next (Input);
23700 -- Unhook the current input from the original input list
23701 -- because it will be relocated to a new clause.
23705 -- Special processing for the last input. At this point the
23706 -- original aggregate has been stripped down to one element.
23707 -- Replace the aggregate by the element itself.
23709 if Input = Last_Input then
23710 Rewrite (Inputs, Input);
23712 -- Generate a clause of the form:
23717 Make_Component_Association (Loc,
23718 Choices => New_Copy_List_Tree (Output),
23719 Expression => Input);
23721 -- The new clause contains replicated content that has
23722 -- already been analyzed, mark the clause as analyzed.
23724 Set_Analyzed (New_Clause);
23725 Insert_After (Clause, New_Clause);
23728 Input := Next_Input;
23731 end Normalize_Inputs;
23733 -----------------------
23734 -- Normalize_Outputs --
23735 -----------------------
23737 procedure Normalize_Outputs (Clause : Node_Id) is
23738 Inputs : constant Node_Id := Expression (Clause);
23739 Loc : constant Source_Ptr := Sloc (Clause);
23740 Outputs : constant Node_Id := First (Choices (Clause));
23741 Last_Output : Node_Id;
23742 New_Clause : Node_Id;
23743 Next_Output : Node_Id;
23747 -- Multiple outputs appear as an aggregate. Nothing to do when
23748 -- the clause has exactly one output.
23750 if Nkind (Outputs) = N_Aggregate then
23751 Last_Output := Last (Expressions (Outputs));
23753 -- Create a clause for each output. Note that each time a new
23754 -- clause is created, the original output list slowly shrinks
23755 -- until there is one item left.
23757 Output := First (Expressions (Outputs));
23758 while Present (Output) loop
23759 Next_Output := Next (Output);
23761 -- Unhook the output from the original output list as it
23762 -- will be relocated to a new clause.
23766 -- Special processing for the last output. At this point
23767 -- the original aggregate has been stripped down to one
23768 -- element. Replace the aggregate by the element itself.
23770 if Output = Last_Output then
23771 Rewrite (Outputs, Output);
23774 -- Generate a clause of the form:
23775 -- (Output => Inputs)
23778 Make_Component_Association (Loc,
23779 Choices => New_List (Output),
23780 Expression => New_Copy_Tree (Inputs));
23782 -- The new clause contains replicated content that has
23783 -- already been analyzed. There is not need to reanalyze
23786 Set_Analyzed (New_Clause);
23787 Insert_After (Clause, New_Clause);
23790 Output := Next_Output;
23793 end Normalize_Outputs;
23799 -- Start of processing for Normalize_Clauses
23802 Clause := First (Clauses);
23803 while Present (Clause) loop
23804 Normalize_Outputs (Clause);
23808 Clause := First (Clauses);
23809 while Present (Clause) loop
23810 Normalize_Inputs (Clause);
23813 end Normalize_Clauses;
23815 --------------------------
23816 -- Report_Extra_Clauses --
23817 --------------------------
23819 procedure Report_Extra_Clauses is
23823 -- Do not perform this check in an instance because it was already
23824 -- performed successfully in the generic template.
23826 if Is_Generic_Instance (Spec_Id) then
23829 elsif Present (Refinements) then
23830 Clause := First (Refinements);
23831 while Present (Clause) loop
23833 -- Do not complain about a null input refinement, since a null
23834 -- input legitimately matches anything.
23836 if Nkind (Clause) = N_Component_Association
23837 and then Nkind (Expression (Clause)) = N_Null
23843 ("unmatched or extra clause in dependence refinement",
23850 end Report_Extra_Clauses;
23854 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23855 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
23856 Errors : constant Nat := Serious_Errors_Detected;
23862 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
23865 -- Do not analyze the pragma multiple times
23867 if Is_Analyzed_Pragma (N) then
23871 Spec_Id := Unique_Defining_Entity (Body_Decl);
23873 -- Use the anonymous object as the proper spec when Refined_Depends
23874 -- applies to the body of a single task type. The object carries the
23875 -- proper Chars as well as all non-refined versions of pragmas.
23877 if Is_Single_Concurrent_Type (Spec_Id) then
23878 Spec_Id := Anonymous_Object (Spec_Id);
23881 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
23883 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
23884 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
23886 if No (Depends) then
23888 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
23889 & "& lacks aspect or pragma Depends"), N, Spec_Id);
23893 Deps := Expression (Get_Argument (Depends, Spec_Id));
23895 -- A null dependency relation renders the refinement useless because it
23896 -- cannot possibly mention abstract states with visible refinement. Note
23897 -- that the inverse is not true as states may be refined to null
23898 -- (SPARK RM 7.2.5(2)).
23900 if Nkind (Deps) = N_Null then
23902 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
23903 & "depend on abstract state with visible refinement"), N, Spec_Id);
23907 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
23908 -- This ensures that the categorization of all refined dependency items
23909 -- is consistent with their role.
23911 Analyze_Depends_In_Decl_Part (N);
23913 -- Do not match dependencies against refinements if Refined_Depends is
23914 -- illegal to avoid emitting misleading error.
23916 if Serious_Errors_Detected = Errors then
23918 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
23919 -- the inputs and outputs of the subprogram spec and body to verify
23920 -- the use of states with visible refinement and their constituents.
23922 if No (Get_Pragma (Spec_Id, Pragma_Global))
23923 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
23925 Collect_Subprogram_Inputs_Outputs
23926 (Subp_Id => Spec_Id,
23927 Synthesize => True,
23928 Subp_Inputs => Spec_Inputs,
23929 Subp_Outputs => Spec_Outputs,
23930 Global_Seen => Dummy);
23932 Collect_Subprogram_Inputs_Outputs
23933 (Subp_Id => Body_Id,
23934 Synthesize => True,
23935 Subp_Inputs => Body_Inputs,
23936 Subp_Outputs => Body_Outputs,
23937 Global_Seen => Dummy);
23939 -- For an output state with a visible refinement, ensure that all
23940 -- constituents appear as outputs in the dependency refinement.
23942 Check_Output_States;
23945 -- Matching is disabled in ASIS because clauses are not normalized as
23946 -- this is a tree altering activity similar to expansion.
23952 -- Multiple dependency clauses appear as component associations of an
23953 -- aggregate. Note that the clauses are copied because the algorithm
23954 -- modifies them and this should not be visible in Depends.
23956 pragma Assert (Nkind (Deps) = N_Aggregate);
23957 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
23958 Normalize_Clauses (Dependencies);
23960 Refs := Expression (Get_Argument (N, Spec_Id));
23962 if Nkind (Refs) = N_Null then
23963 Refinements := No_List;
23965 -- Multiple dependency clauses appear as component associations of an
23966 -- aggregate. Note that the clauses are copied because the algorithm
23967 -- modifies them and this should not be visible in Refined_Depends.
23969 else pragma Assert (Nkind (Refs) = N_Aggregate);
23970 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
23971 Normalize_Clauses (Refinements);
23974 -- At this point the clauses of pragmas Depends and Refined_Depends
23975 -- have been normalized into simple dependencies between one output
23976 -- and one input. Examine all clauses of pragma Depends looking for
23977 -- matching clauses in pragma Refined_Depends.
23979 Clause := First (Dependencies);
23980 while Present (Clause) loop
23981 Check_Dependency_Clause (Clause);
23985 if Serious_Errors_Detected = Errors then
23986 Report_Extra_Clauses;
23991 Set_Is_Analyzed_Pragma (N);
23992 end Analyze_Refined_Depends_In_Decl_Part;
23994 -----------------------------------------
23995 -- Analyze_Refined_Global_In_Decl_Part --
23996 -----------------------------------------
23998 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24000 -- The corresponding Global pragma
24002 Has_In_State : Boolean := False;
24003 Has_In_Out_State : Boolean := False;
24004 Has_Out_State : Boolean := False;
24005 Has_Proof_In_State : Boolean := False;
24006 -- These flags are set when the corresponding Global pragma has a state
24007 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24010 Has_Null_State : Boolean := False;
24011 -- This flag is set when the corresponding Global pragma has at least
24012 -- one state with a null refinement.
24014 In_Constits : Elist_Id := No_Elist;
24015 In_Out_Constits : Elist_Id := No_Elist;
24016 Out_Constits : Elist_Id := No_Elist;
24017 Proof_In_Constits : Elist_Id := No_Elist;
24018 -- These lists contain the entities of all Input, In_Out, Output and
24019 -- Proof_In constituents that appear in Refined_Global and participate
24020 -- in state refinement.
24022 In_Items : Elist_Id := No_Elist;
24023 In_Out_Items : Elist_Id := No_Elist;
24024 Out_Items : Elist_Id := No_Elist;
24025 Proof_In_Items : Elist_Id := No_Elist;
24026 -- These list contain the entities of all Input, In_Out, Output and
24027 -- Proof_In items defined in the corresponding Global pragma.
24029 Spec_Id : Entity_Id;
24030 -- The entity of the subprogram subject to pragma Refined_Global
24032 procedure Check_In_Out_States;
24033 -- Determine whether the corresponding Global pragma mentions In_Out
24034 -- states with visible refinement and if so, ensure that one of the
24035 -- following completions apply to the constituents of the state:
24036 -- 1) there is at least one constituent of mode In_Out
24037 -- 2) there is at least one Input and one Output constituent
24038 -- 3) not all constituents are present and one of them is of mode
24040 -- This routine may remove elements from In_Constits, In_Out_Constits,
24041 -- Out_Constits and Proof_In_Constits.
24043 procedure Check_Input_States;
24044 -- Determine whether the corresponding Global pragma mentions Input
24045 -- states with visible refinement and if so, ensure that at least one of
24046 -- its constituents appears as an Input item in Refined_Global.
24047 -- This routine may remove elements from In_Constits, In_Out_Constits,
24048 -- Out_Constits and Proof_In_Constits.
24050 procedure Check_Output_States;
24051 -- Determine whether the corresponding Global pragma mentions Output
24052 -- states with visible refinement and if so, ensure that all of its
24053 -- constituents appear as Output items in Refined_Global.
24054 -- This routine may remove elements from In_Constits, In_Out_Constits,
24055 -- Out_Constits and Proof_In_Constits.
24057 procedure Check_Proof_In_States;
24058 -- Determine whether the corresponding Global pragma mentions Proof_In
24059 -- states with visible refinement and if so, ensure that at least one of
24060 -- its constituents appears as a Proof_In item in Refined_Global.
24061 -- This routine may remove elements from In_Constits, In_Out_Constits,
24062 -- Out_Constits and Proof_In_Constits.
24064 procedure Check_Refined_Global_List
24066 Global_Mode : Name_Id := Name_Input);
24067 -- Verify the legality of a single global list declaration. Global_Mode
24068 -- denotes the current mode in effect.
24070 procedure Collect_Global_Items
24072 Mode : Name_Id := Name_Input);
24073 -- Gather all input, in out, output and Proof_In items from node List
24074 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24075 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24076 -- and Has_Proof_In_State are set when there is at least one abstract
24077 -- state with visible refinement available in the corresponding mode.
24078 -- Flag Has_Null_State is set when at least state has a null refinement.
24079 -- Mode enotes the current global mode in effect.
24081 function Present_Then_Remove
24083 Item : Entity_Id) return Boolean;
24084 -- Search List for a particular entity Item. If Item has been found,
24085 -- remove it from List. This routine is used to strip lists In_Constits,
24086 -- In_Out_Constits and Out_Constits of valid constituents.
24088 procedure Report_Extra_Constituents;
24089 -- Emit an error for each constituent found in lists In_Constits,
24090 -- In_Out_Constits and Out_Constits.
24092 -------------------------
24093 -- Check_In_Out_States --
24094 -------------------------
24096 procedure Check_In_Out_States is
24097 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24098 -- Determine whether one of the following coverage scenarios is in
24100 -- 1) there is at least one constituent of mode In_Out
24101 -- 2) there is at least one Input and one Output constituent
24102 -- 3) not all constituents are present and one of them is of mode
24104 -- If this is not the case, emit an error.
24106 -----------------------------
24107 -- Check_Constituent_Usage --
24108 -----------------------------
24110 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24111 Constit_Elmt : Elmt_Id;
24112 Constit_Id : Entity_Id;
24113 Has_Missing : Boolean := False;
24114 In_Out_Seen : Boolean := False;
24115 In_Seen : Boolean := False;
24116 Out_Seen : Boolean := False;
24119 -- Process all the constituents of the state and note their modes
24120 -- within the global refinement.
24122 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
24123 while Present (Constit_Elmt) loop
24124 Constit_Id := Node (Constit_Elmt);
24126 if Present_Then_Remove (In_Constits, Constit_Id) then
24129 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24130 In_Out_Seen := True;
24132 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24135 -- A Proof_In constituent cannot participate in the completion
24136 -- of an Output state (SPARK RM 7.2.4(5)).
24138 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24139 Error_Msg_Name_1 := Chars (State_Id);
24141 ("constituent & of state % must have mode Input, In_Out "
24142 & "or Output in global refinement", N, Constit_Id);
24145 Has_Missing := True;
24148 Next_Elmt (Constit_Elmt);
24151 -- A single In_Out constituent is a valid completion
24153 if In_Out_Seen then
24156 -- A pair of one Input and one Output constituent is a valid
24159 elsif In_Seen and then Out_Seen then
24162 -- A single Output constituent is a valid completion only when
24163 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
24165 elsif Has_Missing and then Out_Seen then
24170 ("global refinement of state & redefines the mode of its "
24171 & "constituents", N, State_Id);
24173 end Check_Constituent_Usage;
24177 Item_Elmt : Elmt_Id;
24178 Item_Id : Entity_Id;
24180 -- Start of processing for Check_In_Out_States
24183 -- Do not perform this check in an instance because it was already
24184 -- performed successfully in the generic template.
24186 if Is_Generic_Instance (Spec_Id) then
24189 -- Inspect the In_Out items of the corresponding Global pragma
24190 -- looking for a state with a visible refinement.
24192 elsif Has_In_Out_State and then Present (In_Out_Items) then
24193 Item_Elmt := First_Elmt (In_Out_Items);
24194 while Present (Item_Elmt) loop
24195 Item_Id := Node (Item_Elmt);
24197 -- Ensure that one of the three coverage variants is satisfied
24199 if Ekind (Item_Id) = E_Abstract_State
24200 and then Has_Non_Null_Refinement (Item_Id)
24202 Check_Constituent_Usage (Item_Id);
24205 Next_Elmt (Item_Elmt);
24208 end Check_In_Out_States;
24210 ------------------------
24211 -- Check_Input_States --
24212 ------------------------
24214 procedure Check_Input_States is
24215 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24216 -- Determine whether at least one constituent of state State_Id with
24217 -- visible refinement is used and has mode Input. Ensure that the
24218 -- remaining constituents do not have In_Out, Output or Proof_In
24221 -----------------------------
24222 -- Check_Constituent_Usage --
24223 -----------------------------
24225 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24226 Constit_Elmt : Elmt_Id;
24227 Constit_Id : Entity_Id;
24228 In_Seen : Boolean := False;
24231 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
24232 while Present (Constit_Elmt) loop
24233 Constit_Id := Node (Constit_Elmt);
24235 -- At least one of the constituents appears as an Input
24237 if Present_Then_Remove (In_Constits, Constit_Id) then
24240 -- The constituent appears in the global refinement, but has
24241 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
24243 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24244 or else Present_Then_Remove (Out_Constits, Constit_Id)
24245 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24247 Error_Msg_Name_1 := Chars (State_Id);
24249 ("constituent & of state % must have mode Input in global "
24250 & "refinement", N, Constit_Id);
24253 Next_Elmt (Constit_Elmt);
24256 -- Not one of the constituents appeared as Input
24258 if not In_Seen then
24260 ("global refinement of state & must include at least one "
24261 & "constituent of mode Input", N, State_Id);
24263 end Check_Constituent_Usage;
24267 Item_Elmt : Elmt_Id;
24268 Item_Id : Entity_Id;
24270 -- Start of processing for Check_Input_States
24273 -- Do not perform this check in an instance because it was already
24274 -- performed successfully in the generic template.
24276 if Is_Generic_Instance (Spec_Id) then
24279 -- Inspect the Input items of the corresponding Global pragma looking
24280 -- for a state with a visible refinement.
24282 elsif Has_In_State and then Present (In_Items) then
24283 Item_Elmt := First_Elmt (In_Items);
24284 while Present (Item_Elmt) loop
24285 Item_Id := Node (Item_Elmt);
24287 -- Ensure that at least one of the constituents is utilized and
24288 -- is of mode Input.
24290 if Ekind (Item_Id) = E_Abstract_State
24291 and then Has_Non_Null_Refinement (Item_Id)
24293 Check_Constituent_Usage (Item_Id);
24296 Next_Elmt (Item_Elmt);
24299 end Check_Input_States;
24301 -------------------------
24302 -- Check_Output_States --
24303 -------------------------
24305 procedure Check_Output_States is
24306 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24307 -- Determine whether all constituents of state State_Id with visible
24308 -- refinement are used and have mode Output. Emit an error if this is
24311 -----------------------------
24312 -- Check_Constituent_Usage --
24313 -----------------------------
24315 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24316 Constit_Elmt : Elmt_Id;
24317 Constit_Id : Entity_Id;
24318 Posted : Boolean := False;
24321 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
24322 while Present (Constit_Elmt) loop
24323 Constit_Id := Node (Constit_Elmt);
24325 if Present_Then_Remove (Out_Constits, Constit_Id) then
24328 -- The constituent appears in the global refinement, but has
24329 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24331 elsif Present_Then_Remove (In_Constits, Constit_Id)
24332 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24333 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24335 Error_Msg_Name_1 := Chars (State_Id);
24337 ("constituent & of state % must have mode Output in "
24338 & "global refinement", N, Constit_Id);
24340 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24346 ("output state & must be replaced by all its "
24347 & "constituents in global refinement", N, State_Id);
24351 ("\constituent & is missing in output list",
24355 Next_Elmt (Constit_Elmt);
24357 end Check_Constituent_Usage;
24361 Item_Elmt : Elmt_Id;
24362 Item_Id : Entity_Id;
24364 -- Start of processing for Check_Output_States
24367 -- Do not perform this check in an instance because it was already
24368 -- performed successfully in the generic template.
24370 if Is_Generic_Instance (Spec_Id) then
24373 -- Inspect the Output items of the corresponding Global pragma
24374 -- looking for a state with a visible refinement.
24376 elsif Has_Out_State and then Present (Out_Items) then
24377 Item_Elmt := First_Elmt (Out_Items);
24378 while Present (Item_Elmt) loop
24379 Item_Id := Node (Item_Elmt);
24381 -- Ensure that all of the constituents are utilized and they
24382 -- have mode Output.
24384 if Ekind (Item_Id) = E_Abstract_State
24385 and then Has_Non_Null_Refinement (Item_Id)
24387 Check_Constituent_Usage (Item_Id);
24390 Next_Elmt (Item_Elmt);
24393 end Check_Output_States;
24395 ---------------------------
24396 -- Check_Proof_In_States --
24397 ---------------------------
24399 procedure Check_Proof_In_States is
24400 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24401 -- Determine whether at least one constituent of state State_Id with
24402 -- visible refinement is used and has mode Proof_In. Ensure that the
24403 -- remaining constituents do not have Input, In_Out or Output modes.
24405 -----------------------------
24406 -- Check_Constituent_Usage --
24407 -----------------------------
24409 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24410 Constit_Elmt : Elmt_Id;
24411 Constit_Id : Entity_Id;
24412 Proof_In_Seen : Boolean := False;
24415 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
24416 while Present (Constit_Elmt) loop
24417 Constit_Id := Node (Constit_Elmt);
24419 -- At least one of the constituents appears as Proof_In
24421 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24422 Proof_In_Seen := True;
24424 -- The constituent appears in the global refinement, but has
24425 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24427 elsif Present_Then_Remove (In_Constits, Constit_Id)
24428 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24429 or else Present_Then_Remove (Out_Constits, Constit_Id)
24431 Error_Msg_Name_1 := Chars (State_Id);
24433 ("constituent & of state % must have mode Proof_In in "
24434 & "global refinement", N, Constit_Id);
24437 Next_Elmt (Constit_Elmt);
24440 -- Not one of the constituents appeared as Proof_In
24442 if not Proof_In_Seen then
24444 ("global refinement of state & must include at least one "
24445 & "constituent of mode Proof_In", N, State_Id);
24447 end Check_Constituent_Usage;
24451 Item_Elmt : Elmt_Id;
24452 Item_Id : Entity_Id;
24454 -- Start of processing for Check_Proof_In_States
24457 -- Do not perform this check in an instance because it was already
24458 -- performed successfully in the generic template.
24460 if Is_Generic_Instance (Spec_Id) then
24463 -- Inspect the Proof_In items of the corresponding Global pragma
24464 -- looking for a state with a visible refinement.
24466 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
24467 Item_Elmt := First_Elmt (Proof_In_Items);
24468 while Present (Item_Elmt) loop
24469 Item_Id := Node (Item_Elmt);
24471 -- Ensure that at least one of the constituents is utilized and
24472 -- is of mode Proof_In
24474 if Ekind (Item_Id) = E_Abstract_State
24475 and then Has_Non_Null_Refinement (Item_Id)
24477 Check_Constituent_Usage (Item_Id);
24480 Next_Elmt (Item_Elmt);
24483 end Check_Proof_In_States;
24485 -------------------------------
24486 -- Check_Refined_Global_List --
24487 -------------------------------
24489 procedure Check_Refined_Global_List
24491 Global_Mode : Name_Id := Name_Input)
24493 procedure Check_Refined_Global_Item
24495 Global_Mode : Name_Id);
24496 -- Verify the legality of a single global item declaration. Parameter
24497 -- Global_Mode denotes the current mode in effect.
24499 -------------------------------
24500 -- Check_Refined_Global_Item --
24501 -------------------------------
24503 procedure Check_Refined_Global_Item
24505 Global_Mode : Name_Id)
24507 Item_Id : constant Entity_Id := Entity_Of (Item);
24509 procedure Inconsistent_Mode_Error (Expect : Name_Id);
24510 -- Issue a common error message for all mode mismatches. Expect
24511 -- denotes the expected mode.
24513 -----------------------------
24514 -- Inconsistent_Mode_Error --
24515 -----------------------------
24517 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
24520 ("global item & has inconsistent modes", Item, Item_Id);
24522 Error_Msg_Name_1 := Global_Mode;
24523 Error_Msg_Name_2 := Expect;
24524 SPARK_Msg_N ("\expected mode %, found mode %", Item);
24525 end Inconsistent_Mode_Error;
24527 -- Start of processing for Check_Refined_Global_Item
24530 -- When the state or object acts as a constituent of another
24531 -- state with a visible refinement, collect it for the state
24532 -- completeness checks performed later on.
24534 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
24535 and then Present (Encapsulating_State (Item_Id))
24536 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
24538 if Global_Mode = Name_Input then
24539 Append_New_Elmt (Item_Id, In_Constits);
24541 elsif Global_Mode = Name_In_Out then
24542 Append_New_Elmt (Item_Id, In_Out_Constits);
24544 elsif Global_Mode = Name_Output then
24545 Append_New_Elmt (Item_Id, Out_Constits);
24547 elsif Global_Mode = Name_Proof_In then
24548 Append_New_Elmt (Item_Id, Proof_In_Constits);
24551 -- When not a constituent, ensure that both occurrences of the
24552 -- item in pragmas Global and Refined_Global match.
24554 elsif Contains (In_Items, Item_Id) then
24555 if Global_Mode /= Name_Input then
24556 Inconsistent_Mode_Error (Name_Input);
24559 elsif Contains (In_Out_Items, Item_Id) then
24560 if Global_Mode /= Name_In_Out then
24561 Inconsistent_Mode_Error (Name_In_Out);
24564 elsif Contains (Out_Items, Item_Id) then
24565 if Global_Mode /= Name_Output then
24566 Inconsistent_Mode_Error (Name_Output);
24569 elsif Contains (Proof_In_Items, Item_Id) then
24572 -- The item does not appear in the corresponding Global pragma,
24573 -- it must be an extra (SPARK RM 7.2.4(3)).
24576 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
24578 end Check_Refined_Global_Item;
24584 -- Start of processing for Check_Refined_Global_List
24587 -- Do not perform this check in an instance because it was already
24588 -- performed successfully in the generic template.
24590 if Is_Generic_Instance (Spec_Id) then
24593 elsif Nkind (List) = N_Null then
24596 -- Single global item declaration
24598 elsif Nkind_In (List, N_Expanded_Name,
24600 N_Selected_Component)
24602 Check_Refined_Global_Item (List, Global_Mode);
24604 -- Simple global list or moded global list declaration
24606 elsif Nkind (List) = N_Aggregate then
24608 -- The declaration of a simple global list appear as a collection
24611 if Present (Expressions (List)) then
24612 Item := First (Expressions (List));
24613 while Present (Item) loop
24614 Check_Refined_Global_Item (Item, Global_Mode);
24618 -- The declaration of a moded global list appears as a collection
24619 -- of component associations where individual choices denote
24622 elsif Present (Component_Associations (List)) then
24623 Item := First (Component_Associations (List));
24624 while Present (Item) loop
24625 Check_Refined_Global_List
24626 (List => Expression (Item),
24627 Global_Mode => Chars (First (Choices (Item))));
24635 raise Program_Error;
24641 raise Program_Error;
24643 end Check_Refined_Global_List;
24645 --------------------------
24646 -- Collect_Global_Items --
24647 --------------------------
24649 procedure Collect_Global_Items
24651 Mode : Name_Id := Name_Input)
24653 procedure Collect_Global_Item
24655 Item_Mode : Name_Id);
24656 -- Add a single item to the appropriate list. Item_Mode denotes the
24657 -- current mode in effect.
24659 -------------------------
24660 -- Collect_Global_Item --
24661 -------------------------
24663 procedure Collect_Global_Item
24665 Item_Mode : Name_Id)
24667 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
24668 -- The above handles abstract views of variables and states built
24669 -- for limited with clauses.
24672 -- Signal that the global list contains at least one abstract
24673 -- state with a visible refinement. Note that the refinement may
24674 -- be null in which case there are no constituents.
24676 if Ekind (Item_Id) = E_Abstract_State then
24677 if Has_Null_Refinement (Item_Id) then
24678 Has_Null_State := True;
24680 elsif Has_Non_Null_Refinement (Item_Id) then
24681 if Item_Mode = Name_Input then
24682 Has_In_State := True;
24683 elsif Item_Mode = Name_In_Out then
24684 Has_In_Out_State := True;
24685 elsif Item_Mode = Name_Output then
24686 Has_Out_State := True;
24687 elsif Item_Mode = Name_Proof_In then
24688 Has_Proof_In_State := True;
24693 -- Add the item to the proper list
24695 if Item_Mode = Name_Input then
24696 Append_New_Elmt (Item_Id, In_Items);
24697 elsif Item_Mode = Name_In_Out then
24698 Append_New_Elmt (Item_Id, In_Out_Items);
24699 elsif Item_Mode = Name_Output then
24700 Append_New_Elmt (Item_Id, Out_Items);
24701 elsif Item_Mode = Name_Proof_In then
24702 Append_New_Elmt (Item_Id, Proof_In_Items);
24704 end Collect_Global_Item;
24710 -- Start of processing for Collect_Global_Items
24713 if Nkind (List) = N_Null then
24716 -- Single global item declaration
24718 elsif Nkind_In (List, N_Expanded_Name,
24720 N_Selected_Component)
24722 Collect_Global_Item (List, Mode);
24724 -- Single global list or moded global list declaration
24726 elsif Nkind (List) = N_Aggregate then
24728 -- The declaration of a simple global list appear as a collection
24731 if Present (Expressions (List)) then
24732 Item := First (Expressions (List));
24733 while Present (Item) loop
24734 Collect_Global_Item (Item, Mode);
24738 -- The declaration of a moded global list appears as a collection
24739 -- of component associations where individual choices denote mode.
24741 elsif Present (Component_Associations (List)) then
24742 Item := First (Component_Associations (List));
24743 while Present (Item) loop
24744 Collect_Global_Items
24745 (List => Expression (Item),
24746 Mode => Chars (First (Choices (Item))));
24754 raise Program_Error;
24757 -- To accomodate partial decoration of disabled SPARK features, this
24758 -- routine may be called with illegal input. If this is the case, do
24759 -- not raise Program_Error.
24764 end Collect_Global_Items;
24766 -------------------------
24767 -- Present_Then_Remove --
24768 -------------------------
24770 function Present_Then_Remove
24772 Item : Entity_Id) return Boolean
24777 if Present (List) then
24778 Elmt := First_Elmt (List);
24779 while Present (Elmt) loop
24780 if Node (Elmt) = Item then
24781 Remove_Elmt (List, Elmt);
24790 end Present_Then_Remove;
24792 -------------------------------
24793 -- Report_Extra_Constituents --
24794 -------------------------------
24796 procedure Report_Extra_Constituents is
24797 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
24798 -- Emit an error for every element of List
24800 ---------------------------------------
24801 -- Report_Extra_Constituents_In_List --
24802 ---------------------------------------
24804 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
24805 Constit_Elmt : Elmt_Id;
24808 if Present (List) then
24809 Constit_Elmt := First_Elmt (List);
24810 while Present (Constit_Elmt) loop
24811 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
24812 Next_Elmt (Constit_Elmt);
24815 end Report_Extra_Constituents_In_List;
24817 -- Start of processing for Report_Extra_Constituents
24820 -- Do not perform this check in an instance because it was already
24821 -- performed successfully in the generic template.
24823 if Is_Generic_Instance (Spec_Id) then
24827 Report_Extra_Constituents_In_List (In_Constits);
24828 Report_Extra_Constituents_In_List (In_Out_Constits);
24829 Report_Extra_Constituents_In_List (Out_Constits);
24830 Report_Extra_Constituents_In_List (Proof_In_Constits);
24832 end Report_Extra_Constituents;
24836 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24837 Errors : constant Nat := Serious_Errors_Detected;
24840 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
24843 -- Do not analyze the pragma multiple times
24845 if Is_Analyzed_Pragma (N) then
24849 Spec_Id := Unique_Defining_Entity (Body_Decl);
24851 -- Use the anonymous object as the proper spec when Refined_Global
24852 -- applies to the body of a single task type. The object carries the
24853 -- proper Chars as well as all non-refined versions of pragmas.
24855 if Is_Single_Concurrent_Type (Spec_Id) then
24856 Spec_Id := Anonymous_Object (Spec_Id);
24859 Global := Get_Pragma (Spec_Id, Pragma_Global);
24860 Items := Expression (Get_Argument (N, Spec_Id));
24862 -- The subprogram declaration lacks pragma Global. This renders
24863 -- Refined_Global useless as there is nothing to refine.
24865 if No (Global) then
24867 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24868 & "& lacks aspect or pragma Global"), N, Spec_Id);
24872 -- Extract all relevant items from the corresponding Global pragma
24874 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
24876 -- Package and subprogram bodies are instantiated individually in
24877 -- a separate compiler pass. Due to this mode of instantiation, the
24878 -- refinement of a state may no longer be visible when a subprogram
24879 -- body contract is instantiated. Since the generic template is legal,
24880 -- do not perform this check in the instance to circumvent this oddity.
24882 if Is_Generic_Instance (Spec_Id) then
24885 -- Non-instance case
24888 -- The corresponding Global pragma must mention at least one state
24889 -- witha visible refinement at the point Refined_Global is processed.
24890 -- States with null refinements need Refined_Global pragma
24891 -- (SPARK RM 7.2.4(2)).
24893 if not Has_In_State
24894 and then not Has_In_Out_State
24895 and then not Has_Out_State
24896 and then not Has_Proof_In_State
24897 and then not Has_Null_State
24900 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24901 & "depend on abstract state with visible refinement"),
24905 -- The global refinement of inputs and outputs cannot be null when
24906 -- the corresponding Global pragma contains at least one item except
24907 -- in the case where we have states with null refinements.
24909 elsif Nkind (Items) = N_Null
24911 (Present (In_Items)
24912 or else Present (In_Out_Items)
24913 or else Present (Out_Items)
24914 or else Present (Proof_In_Items))
24915 and then not Has_Null_State
24918 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
24919 & "global items"), N, Spec_Id);
24924 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
24925 -- This ensures that the categorization of all refined global items is
24926 -- consistent with their role.
24928 Analyze_Global_In_Decl_Part (N);
24930 -- Perform all refinement checks with respect to completeness and mode
24933 if Serious_Errors_Detected = Errors then
24934 Check_Refined_Global_List (Items);
24937 -- For Input states with visible refinement, at least one constituent
24938 -- must be used as an Input in the global refinement.
24940 if Serious_Errors_Detected = Errors then
24941 Check_Input_States;
24944 -- Verify all possible completion variants for In_Out states with
24945 -- visible refinement.
24947 if Serious_Errors_Detected = Errors then
24948 Check_In_Out_States;
24951 -- For Output states with visible refinement, all constituents must be
24952 -- used as Outputs in the global refinement.
24954 if Serious_Errors_Detected = Errors then
24955 Check_Output_States;
24958 -- For Proof_In states with visible refinement, at least one constituent
24959 -- must be used as Proof_In in the global refinement.
24961 if Serious_Errors_Detected = Errors then
24962 Check_Proof_In_States;
24965 -- Emit errors for all constituents that belong to other states with
24966 -- visible refinement that do not appear in Global.
24968 if Serious_Errors_Detected = Errors then
24969 Report_Extra_Constituents;
24973 Set_Is_Analyzed_Pragma (N);
24974 end Analyze_Refined_Global_In_Decl_Part;
24976 ----------------------------------------
24977 -- Analyze_Refined_State_In_Decl_Part --
24978 ----------------------------------------
24980 procedure Analyze_Refined_State_In_Decl_Part
24982 Freeze_Id : Entity_Id := Empty)
24984 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
24985 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24986 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
24988 Available_States : Elist_Id := No_Elist;
24989 -- A list of all abstract states defined in the package declaration that
24990 -- are available for refinement. The list is used to report unrefined
24993 Body_States : Elist_Id := No_Elist;
24994 -- A list of all hidden states that appear in the body of the related
24995 -- package. The list is used to report unused hidden states.
24997 Constituents_Seen : Elist_Id := No_Elist;
24998 -- A list that contains all constituents processed so far. The list is
24999 -- used to detect multiple uses of the same constituent.
25001 Freeze_Posted : Boolean := False;
25002 -- A flag that controls the output of a freezing-related error (see use
25005 Refined_States_Seen : Elist_Id := No_Elist;
25006 -- A list that contains all refined states processed so far. The list is
25007 -- used to detect duplicate refinements.
25009 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25010 -- Perform full analysis of a single refinement clause
25012 procedure Report_Unrefined_States (States : Elist_Id);
25013 -- Emit errors for all unrefined abstract states found in list States
25015 -------------------------------
25016 -- Analyze_Refinement_Clause --
25017 -------------------------------
25019 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25020 AR_Constit : Entity_Id := Empty;
25021 AW_Constit : Entity_Id := Empty;
25022 ER_Constit : Entity_Id := Empty;
25023 EW_Constit : Entity_Id := Empty;
25024 -- The entities of external constituents that contain one of the
25025 -- following enabled properties: Async_Readers, Async_Writers,
25026 -- Effective_Reads and Effective_Writes.
25028 External_Constit_Seen : Boolean := False;
25029 -- Flag used to mark when at least one external constituent is part
25030 -- of the state refinement.
25032 Non_Null_Seen : Boolean := False;
25033 Null_Seen : Boolean := False;
25034 -- Flags used to detect multiple uses of null in a single clause or a
25035 -- mixture of null and non-null constituents.
25037 Part_Of_Constits : Elist_Id := No_Elist;
25038 -- A list of all candidate constituents subject to indicator Part_Of
25039 -- where the encapsulating state is the current state.
25042 State_Id : Entity_Id;
25043 -- The current state being refined
25045 procedure Analyze_Constituent (Constit : Node_Id);
25046 -- Perform full analysis of a single constituent
25048 procedure Check_External_Property
25049 (Prop_Nam : Name_Id;
25051 Constit : Entity_Id);
25052 -- Determine whether a property denoted by name Prop_Nam is present
25053 -- in both the refined state and constituent Constit. Flag Enabled
25054 -- should be set when the property applies to the refined state. If
25055 -- this is not the case, emit an error message.
25057 procedure Match_State;
25058 -- Determine whether the state being refined appears in list
25059 -- Available_States. Emit an error when attempting to re-refine the
25060 -- state or when the state is not defined in the package declaration,
25061 -- otherwise remove the state from Available_States.
25063 procedure Report_Unused_Constituents (Constits : Elist_Id);
25064 -- Emit errors for all unused Part_Of constituents in list Constits
25066 -------------------------
25067 -- Analyze_Constituent --
25068 -------------------------
25070 procedure Analyze_Constituent (Constit : Node_Id) is
25071 procedure Match_Constituent (Constit_Id : Entity_Id);
25072 -- Determine whether constituent Constit denoted by its entity
25073 -- Constit_Id appears in Body_States. Emit an error when the
25074 -- constituent is not a valid hidden state of the related package
25075 -- or when it is used more than once. Otherwise remove the
25076 -- constituent from Body_States.
25078 -----------------------
25079 -- Match_Constituent --
25080 -----------------------
25082 procedure Match_Constituent (Constit_Id : Entity_Id) is
25083 procedure Collect_Constituent;
25084 -- Verify the legality of constituent Constit_Id and add it to
25085 -- the refinements of State_Id.
25087 -------------------------
25088 -- Collect_Constituent --
25089 -------------------------
25091 procedure Collect_Constituent is
25093 if Is_Ghost_Entity (State_Id) then
25094 if Is_Ghost_Entity (Constit_Id) then
25096 -- The Ghost policy in effect at the point of abstract
25097 -- state declaration and constituent must match
25098 -- (SPARK RM 6.9(16)).
25100 if Is_Checked_Ghost_Entity (State_Id)
25101 and then Is_Ignored_Ghost_Entity (Constit_Id)
25103 Error_Msg_Sloc := Sloc (Constit);
25106 ("incompatible ghost policies in effect", State);
25108 ("\abstract state & declared with ghost policy "
25109 & "Check", State, State_Id);
25111 ("\constituent & declared # with ghost policy "
25112 & "Ignore", State, Constit_Id);
25114 elsif Is_Ignored_Ghost_Entity (State_Id)
25115 and then Is_Checked_Ghost_Entity (Constit_Id)
25117 Error_Msg_Sloc := Sloc (Constit);
25120 ("incompatible ghost policies in effect", State);
25122 ("\abstract state & declared with ghost policy "
25123 & "Ignore", State, State_Id);
25125 ("\constituent & declared # with ghost policy "
25126 & "Check", State, Constit_Id);
25129 -- A constituent of a Ghost abstract state must be a
25130 -- Ghost entity (SPARK RM 7.2.2(12)).
25134 ("constituent of ghost state & must be ghost",
25135 Constit, State_Id);
25139 -- A synchronized state must be refined by a synchronized
25140 -- object or another synchronized state (SPARK RM 9.6).
25142 if Is_Synchronized_State (State_Id)
25143 and then not Is_Synchronized_Object (Constit_Id)
25144 and then not Is_Synchronized_State (Constit_Id)
25147 ("constituent of synchronized state & must be "
25148 & "synchronized", Constit, State_Id);
25151 -- Add the constituent to the list of processed items to aid
25152 -- with the detection of duplicates.
25154 Append_New_Elmt (Constit_Id, Constituents_Seen);
25156 -- Collect the constituent in the list of refinement items
25157 -- and establish a relation between the refined state and
25160 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
25161 Set_Encapsulating_State (Constit_Id, State_Id);
25163 -- The state has at least one legal constituent, mark the
25164 -- start of the refinement region. The region ends when the
25165 -- body declarations end (see routine Analyze_Declarations).
25167 Set_Has_Visible_Refinement (State_Id);
25169 -- When the constituent is external, save its relevant
25170 -- property for further checks.
25172 if Async_Readers_Enabled (Constit_Id) then
25173 AR_Constit := Constit_Id;
25174 External_Constit_Seen := True;
25177 if Async_Writers_Enabled (Constit_Id) then
25178 AW_Constit := Constit_Id;
25179 External_Constit_Seen := True;
25182 if Effective_Reads_Enabled (Constit_Id) then
25183 ER_Constit := Constit_Id;
25184 External_Constit_Seen := True;
25187 if Effective_Writes_Enabled (Constit_Id) then
25188 EW_Constit := Constit_Id;
25189 External_Constit_Seen := True;
25191 end Collect_Constituent;
25195 State_Elmt : Elmt_Id;
25197 -- Start of processing for Match_Constituent
25200 -- Detect a duplicate use of a constituent
25202 if Contains (Constituents_Seen, Constit_Id) then
25204 ("duplicate use of constituent &", Constit, Constit_Id);
25208 -- The constituent is subject to a Part_Of indicator
25210 if Present (Encapsulating_State (Constit_Id)) then
25211 if Encapsulating_State (Constit_Id) = State_Id then
25212 Remove (Part_Of_Constits, Constit_Id);
25213 Collect_Constituent;
25215 -- The constituent is part of another state and is used
25216 -- incorrectly in the refinement of the current state.
25219 Error_Msg_Name_1 := Chars (State_Id);
25221 ("& cannot act as constituent of state %",
25222 Constit, Constit_Id);
25224 ("\Part_Of indicator specifies encapsulator &",
25225 Constit, Encapsulating_State (Constit_Id));
25228 -- The only other source of legal constituents is the body
25229 -- state space of the related package.
25232 if Present (Body_States) then
25233 State_Elmt := First_Elmt (Body_States);
25234 while Present (State_Elmt) loop
25236 -- Consume a valid constituent to signal that it has
25237 -- been encountered.
25239 if Node (State_Elmt) = Constit_Id then
25240 Remove_Elmt (Body_States, State_Elmt);
25241 Collect_Constituent;
25245 Next_Elmt (State_Elmt);
25249 -- Constants are part of the hidden state of a package, but
25250 -- the compiler cannot determine whether they have variable
25251 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25252 -- hidden state. Accept the constant quietly even if it is
25253 -- a visible state or lacks a Part_Of indicator.
25255 if Ekind (Constit_Id) = E_Constant then
25258 -- If we get here, then the constituent is not a hidden
25259 -- state of the related package and may not be used in a
25260 -- refinement (SPARK RM 7.2.2(9)).
25263 Error_Msg_Name_1 := Chars (Spec_Id);
25265 ("cannot use & in refinement, constituent is not a "
25266 & "hidden state of package %", Constit, Constit_Id);
25269 end Match_Constituent;
25273 Constit_Id : Entity_Id;
25275 -- Start of processing for Analyze_Constituent
25278 -- Detect multiple uses of null in a single refinement clause or a
25279 -- mixture of null and non-null constituents.
25281 if Nkind (Constit) = N_Null then
25284 ("multiple null constituents not allowed", Constit);
25286 elsif Non_Null_Seen then
25288 ("cannot mix null and non-null constituents", Constit);
25293 -- Collect the constituent in the list of refinement items
25295 Append_Elmt (Constit, Refinement_Constituents (State_Id));
25297 -- The state has at least one legal constituent, mark the
25298 -- start of the refinement region. The region ends when the
25299 -- body declarations end (see Analyze_Declarations).
25301 Set_Has_Visible_Refinement (State_Id);
25304 -- Non-null constituents
25307 Non_Null_Seen := True;
25311 ("cannot mix null and non-null constituents", Constit);
25315 Resolve_State (Constit);
25317 -- Ensure that the constituent denotes a valid state or a
25318 -- whole object (SPARK RM 7.2.2(5)).
25320 if Is_Entity_Name (Constit) then
25321 Constit_Id := Entity_Of (Constit);
25323 -- When a constituent is declared after a subprogram body
25324 -- that caused "freezing" of the related contract where
25325 -- pragma Refined_State resides, the constituent appears
25326 -- undefined and carries Any_Id as its entity.
25328 -- package body Pack
25329 -- with Refined_State => (State => Constit)
25332 -- with Refined_Global => (Input => Constit)
25340 if Constit_Id = Any_Id then
25341 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25343 -- Emit a specialized info message when the contract of
25344 -- the related package body was "frozen" by another body.
25345 -- Note that it is not possible to precisely identify why
25346 -- the constituent is undefined because it is not visible
25347 -- when pragma Refined_State is analyzed. This message is
25348 -- a reasonable approximation.
25350 if Present (Freeze_Id) and then not Freeze_Posted then
25351 Freeze_Posted := True;
25353 Error_Msg_Name_1 := Chars (Body_Id);
25354 Error_Msg_Sloc := Sloc (Freeze_Id);
25356 ("body & declared # freezes the contract of %",
25359 ("\all constituents must be declared before body #",
25363 -- The constituent is a valid state or object
25365 elsif Ekind_In (Constit_Id, E_Abstract_State,
25369 Match_Constituent (Constit_Id);
25371 -- Otherwise the constituent is illegal
25375 ("constituent & must denote object or state",
25376 Constit, Constit_Id);
25379 -- The constituent is illegal
25382 SPARK_Msg_N ("malformed constituent", Constit);
25385 end Analyze_Constituent;
25387 -----------------------------
25388 -- Check_External_Property --
25389 -----------------------------
25391 procedure Check_External_Property
25392 (Prop_Nam : Name_Id;
25394 Constit : Entity_Id)
25397 Error_Msg_Name_1 := Prop_Nam;
25399 -- The property is enabled in the related Abstract_State pragma
25400 -- that defines the state (SPARK RM 7.2.8(3)).
25403 if No (Constit) then
25405 ("external state & requires at least one constituent with "
25406 & "property %", State, State_Id);
25409 -- The property is missing in the declaration of the state, but
25410 -- a constituent is introducing it in the state refinement
25411 -- (SPARK RM 7.2.8(3)).
25413 elsif Present (Constit) then
25414 Error_Msg_Name_2 := Chars (Constit);
25416 ("external state & lacks property % set by constituent %",
25419 end Check_External_Property;
25425 procedure Match_State is
25426 State_Elmt : Elmt_Id;
25429 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25431 if Contains (Refined_States_Seen, State_Id) then
25433 ("duplicate refinement of state &", State, State_Id);
25437 -- Inspect the abstract states defined in the package declaration
25438 -- looking for a match.
25440 State_Elmt := First_Elmt (Available_States);
25441 while Present (State_Elmt) loop
25443 -- A valid abstract state is being refined in the body. Add
25444 -- the state to the list of processed refined states to aid
25445 -- with the detection of duplicate refinements. Remove the
25446 -- state from Available_States to signal that it has already
25449 if Node (State_Elmt) = State_Id then
25450 Append_New_Elmt (State_Id, Refined_States_Seen);
25451 Remove_Elmt (Available_States, State_Elmt);
25455 Next_Elmt (State_Elmt);
25458 -- If we get here, we are refining a state that is not defined in
25459 -- the package declaration.
25461 Error_Msg_Name_1 := Chars (Spec_Id);
25463 ("cannot refine state, & is not defined in package %",
25467 --------------------------------
25468 -- Report_Unused_Constituents --
25469 --------------------------------
25471 procedure Report_Unused_Constituents (Constits : Elist_Id) is
25472 Constit_Elmt : Elmt_Id;
25473 Constit_Id : Entity_Id;
25474 Posted : Boolean := False;
25477 if Present (Constits) then
25478 Constit_Elmt := First_Elmt (Constits);
25479 while Present (Constit_Elmt) loop
25480 Constit_Id := Node (Constit_Elmt);
25482 -- Generate an error message of the form:
25484 -- state ... has unused Part_Of constituents
25485 -- abstract state ... defined at ...
25486 -- constant ... defined at ...
25487 -- variable ... defined at ...
25492 ("state & has unused Part_Of constituents",
25496 Error_Msg_Sloc := Sloc (Constit_Id);
25498 if Ekind (Constit_Id) = E_Abstract_State then
25500 ("\abstract state & defined #", State, Constit_Id);
25502 elsif Ekind (Constit_Id) = E_Constant then
25504 ("\constant & defined #", State, Constit_Id);
25507 pragma Assert (Ekind (Constit_Id) = E_Variable);
25508 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
25511 Next_Elmt (Constit_Elmt);
25514 end Report_Unused_Constituents;
25516 -- Local declarations
25518 Body_Ref : Node_Id;
25519 Body_Ref_Elmt : Elmt_Id;
25521 Extra_State : Node_Id;
25523 -- Start of processing for Analyze_Refinement_Clause
25526 -- A refinement clause appears as a component association where the
25527 -- sole choice is the state and the expressions are the constituents.
25528 -- This is a syntax error, always report.
25530 if Nkind (Clause) /= N_Component_Association then
25531 Error_Msg_N ("malformed state refinement clause", Clause);
25535 -- Analyze the state name of a refinement clause
25537 State := First (Choices (Clause));
25540 Resolve_State (State);
25542 -- Ensure that the state name denotes a valid abstract state that is
25543 -- defined in the spec of the related package.
25545 if Is_Entity_Name (State) then
25546 State_Id := Entity_Of (State);
25548 -- When the abstract state is undefined, it appears as Any_Id. Do
25549 -- not continue with the analysis of the clause.
25551 if State_Id = Any_Id then
25554 -- Catch any attempts to re-refine a state or refine a state that
25555 -- is not defined in the package declaration.
25557 elsif Ekind (State_Id) = E_Abstract_State then
25561 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
25565 -- References to a state with visible refinement are illegal.
25566 -- When nested packages are involved, detecting such references is
25567 -- tricky because pragma Refined_State is analyzed later than the
25568 -- offending pragma Depends or Global. References that occur in
25569 -- such nested context are stored in a list. Emit errors for all
25570 -- references found in Body_References (SPARK RM 6.1.4(8)).
25572 if Present (Body_References (State_Id)) then
25573 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
25574 while Present (Body_Ref_Elmt) loop
25575 Body_Ref := Node (Body_Ref_Elmt);
25577 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
25578 Error_Msg_Sloc := Sloc (State);
25579 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
25581 Next_Elmt (Body_Ref_Elmt);
25585 -- The state name is illegal. This is a syntax error, always report.
25588 Error_Msg_N ("malformed state name in refinement clause", State);
25592 -- A refinement clause may only refine one state at a time
25594 Extra_State := Next (State);
25596 if Present (Extra_State) then
25598 ("refinement clause cannot cover multiple states", Extra_State);
25601 -- Replicate the Part_Of constituents of the refined state because
25602 -- the algorithm will consume items.
25604 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
25606 -- Analyze all constituents of the refinement. Multiple constituents
25607 -- appear as an aggregate.
25609 Constit := Expression (Clause);
25611 if Nkind (Constit) = N_Aggregate then
25612 if Present (Component_Associations (Constit)) then
25614 ("constituents of refinement clause must appear in "
25615 & "positional form", Constit);
25617 else pragma Assert (Present (Expressions (Constit)));
25618 Constit := First (Expressions (Constit));
25619 while Present (Constit) loop
25620 Analyze_Constituent (Constit);
25625 -- Various forms of a single constituent. Note that these may include
25626 -- malformed constituents.
25629 Analyze_Constituent (Constit);
25632 -- A refined external state is subject to special rules with respect
25633 -- to its properties and constituents.
25635 if Is_External_State (State_Id) then
25637 -- The set of properties that all external constituents yield must
25638 -- match that of the refined state. There are two cases to detect:
25639 -- the refined state lacks a property or has an extra property.
25641 if External_Constit_Seen then
25642 Check_External_Property
25643 (Prop_Nam => Name_Async_Readers,
25644 Enabled => Async_Readers_Enabled (State_Id),
25645 Constit => AR_Constit);
25647 Check_External_Property
25648 (Prop_Nam => Name_Async_Writers,
25649 Enabled => Async_Writers_Enabled (State_Id),
25650 Constit => AW_Constit);
25652 Check_External_Property
25653 (Prop_Nam => Name_Effective_Reads,
25654 Enabled => Effective_Reads_Enabled (State_Id),
25655 Constit => ER_Constit);
25657 Check_External_Property
25658 (Prop_Nam => Name_Effective_Writes,
25659 Enabled => Effective_Writes_Enabled (State_Id),
25660 Constit => EW_Constit);
25662 -- An external state may be refined to null (SPARK RM 7.2.8(2))
25664 elsif Null_Seen then
25667 -- The external state has constituents, but none of them are
25668 -- external (SPARK RM 7.2.8(2)).
25672 ("external state & requires at least one external "
25673 & "constituent or null refinement", State, State_Id);
25676 -- When a refined state is not external, it should not have external
25677 -- constituents (SPARK RM 7.2.8(1)).
25679 elsif External_Constit_Seen then
25681 ("non-external state & cannot contain external constituents in "
25682 & "refinement", State, State_Id);
25685 -- Ensure that all Part_Of candidate constituents have been mentioned
25686 -- in the refinement clause.
25688 Report_Unused_Constituents (Part_Of_Constits);
25689 end Analyze_Refinement_Clause;
25691 -----------------------------
25692 -- Report_Unrefined_States --
25693 -----------------------------
25695 procedure Report_Unrefined_States (States : Elist_Id) is
25696 State_Elmt : Elmt_Id;
25699 if Present (States) then
25700 State_Elmt := First_Elmt (States);
25701 while Present (State_Elmt) loop
25703 ("abstract state & must be refined", Node (State_Elmt));
25705 Next_Elmt (State_Elmt);
25708 end Report_Unrefined_States;
25710 -- Local declarations
25712 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25715 -- Start of processing for Analyze_Refined_State_In_Decl_Part
25718 -- Do not analyze the pragma multiple times
25720 if Is_Analyzed_Pragma (N) then
25724 -- Replicate the abstract states declared by the package because the
25725 -- matching algorithm will consume states.
25727 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
25729 -- Gather all abstract states and objects declared in the visible
25730 -- state space of the package body. These items must be utilized as
25731 -- constituents in a state refinement.
25733 Body_States := Collect_Body_States (Body_Id);
25735 -- Multiple non-null state refinements appear as an aggregate
25737 if Nkind (Clauses) = N_Aggregate then
25738 if Present (Expressions (Clauses)) then
25740 ("state refinements must appear as component associations",
25743 else pragma Assert (Present (Component_Associations (Clauses)));
25744 Clause := First (Component_Associations (Clauses));
25745 while Present (Clause) loop
25746 Analyze_Refinement_Clause (Clause);
25751 -- Various forms of a single state refinement. Note that these may
25752 -- include malformed refinements.
25755 Analyze_Refinement_Clause (Clauses);
25758 -- List all abstract states that were left unrefined
25760 Report_Unrefined_States (Available_States);
25762 -- Ensure that all abstract states and objects declared in the body
25763 -- state space of the related package are utilized as constituents.
25765 Report_Unused_Body_States (Body_Id, Body_States);
25767 Set_Is_Analyzed_Pragma (N);
25768 end Analyze_Refined_State_In_Decl_Part;
25770 ------------------------------------
25771 -- Analyze_Test_Case_In_Decl_Part --
25772 ------------------------------------
25774 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
25775 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25776 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25778 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
25779 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
25780 -- denoted by Arg_Nam.
25782 ------------------------------
25783 -- Preanalyze_Test_Case_Arg --
25784 ------------------------------
25786 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
25790 -- Preanalyze the original aspect argument for ASIS or for a generic
25791 -- subprogram to properly capture global references.
25793 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
25797 Arg_Nam => Arg_Nam,
25798 From_Aspect => True);
25800 if Present (Arg) then
25801 Preanalyze_Assert_Expression
25802 (Expression (Arg), Standard_Boolean);
25806 Arg := Test_Case_Arg (N, Arg_Nam);
25808 if Present (Arg) then
25809 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
25811 end Preanalyze_Test_Case_Arg;
25815 Restore_Scope : Boolean := False;
25817 -- Start of processing for Analyze_Test_Case_In_Decl_Part
25820 -- Do not analyze the pragma multiple times
25822 if Is_Analyzed_Pragma (N) then
25826 -- Ensure that the formal parameters are visible when analyzing all
25827 -- clauses. This falls out of the general rule of aspects pertaining
25828 -- to subprogram declarations.
25830 if not In_Open_Scopes (Spec_Id) then
25831 Restore_Scope := True;
25832 Push_Scope (Spec_Id);
25834 if Is_Generic_Subprogram (Spec_Id) then
25835 Install_Generic_Formals (Spec_Id);
25837 Install_Formals (Spec_Id);
25841 Preanalyze_Test_Case_Arg (Name_Requires);
25842 Preanalyze_Test_Case_Arg (Name_Ensures);
25844 if Restore_Scope then
25848 -- Currently it is not possible to inline pre/postconditions on a
25849 -- subprogram subject to pragma Inline_Always.
25851 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25853 Set_Is_Analyzed_Pragma (N);
25854 end Analyze_Test_Case_In_Decl_Part;
25860 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
25865 if Present (List) then
25866 Elmt := First_Elmt (List);
25867 while Present (Elmt) loop
25868 if Nkind (Node (Elmt)) = N_Defining_Identifier then
25871 Id := Entity_Of (Node (Elmt));
25874 if Id = Item_Id then
25885 -----------------------------
25886 -- Check_Applicable_Policy --
25887 -----------------------------
25889 procedure Check_Applicable_Policy (N : Node_Id) is
25893 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
25896 -- No effect if not valid assertion kind name
25898 if not Is_Valid_Assertion_Kind (Ename) then
25902 -- Loop through entries in check policy list
25904 PP := Opt.Check_Policy_List;
25905 while Present (PP) loop
25907 PPA : constant List_Id := Pragma_Argument_Associations (PP);
25908 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
25912 or else Pnm = Name_Assertion
25913 or else (Pnm = Name_Statement_Assertions
25914 and then Nam_In (Ename, Name_Assert,
25915 Name_Assert_And_Cut,
25917 Name_Loop_Invariant,
25918 Name_Loop_Variant))
25920 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
25923 when Name_Off | Name_Ignore =>
25924 Set_Is_Ignored (N, True);
25925 Set_Is_Checked (N, False);
25927 when Name_On | Name_Check =>
25928 Set_Is_Checked (N, True);
25929 Set_Is_Ignored (N, False);
25931 when Name_Disable =>
25932 Set_Is_Ignored (N, True);
25933 Set_Is_Checked (N, False);
25934 Set_Is_Disabled (N, True);
25936 -- That should be exhaustive, the null here is a defence
25937 -- against a malformed tree from previous errors.
25946 PP := Next_Pragma (PP);
25950 -- If there are no specific entries that matched, then we let the
25951 -- setting of assertions govern. Note that this provides the needed
25952 -- compatibility with the RM for the cases of assertion, invariant,
25953 -- precondition, predicate, and postcondition.
25955 if Assertions_Enabled then
25956 Set_Is_Checked (N, True);
25957 Set_Is_Ignored (N, False);
25959 Set_Is_Checked (N, False);
25960 Set_Is_Ignored (N, True);
25962 end Check_Applicable_Policy;
25964 -------------------------------
25965 -- Check_External_Properties --
25966 -------------------------------
25968 procedure Check_External_Properties
25976 -- All properties enabled
25978 if AR and AW and ER and EW then
25981 -- Async_Readers + Effective_Writes
25982 -- Async_Readers + Async_Writers + Effective_Writes
25984 elsif AR and EW and not ER then
25987 -- Async_Writers + Effective_Reads
25988 -- Async_Readers + Async_Writers + Effective_Reads
25990 elsif AW and ER and not EW then
25993 -- Async_Readers + Async_Writers
25995 elsif AR and AW and not ER and not EW then
26000 elsif AR and not AW and not ER and not EW then
26005 elsif AW and not AR and not ER and not EW then
26010 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26013 end Check_External_Properties;
26019 function Check_Kind (Nam : Name_Id) return Name_Id is
26023 -- Loop through entries in check policy list
26025 PP := Opt.Check_Policy_List;
26026 while Present (PP) loop
26028 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26029 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26033 or else (Pnm = Name_Assertion
26034 and then Is_Valid_Assertion_Kind (Nam))
26035 or else (Pnm = Name_Statement_Assertions
26036 and then Nam_In (Nam, Name_Assert,
26037 Name_Assert_And_Cut,
26039 Name_Loop_Invariant,
26040 Name_Loop_Variant))
26042 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26043 when Name_On | Name_Check =>
26045 when Name_Off | Name_Ignore =>
26046 return Name_Ignore;
26047 when Name_Disable =>
26048 return Name_Disable;
26050 raise Program_Error;
26054 PP := Next_Pragma (PP);
26059 -- If there are no specific entries that matched, then we let the
26060 -- setting of assertions govern. Note that this provides the needed
26061 -- compatibility with the RM for the cases of assertion, invariant,
26062 -- precondition, predicate, and postcondition.
26064 if Assertions_Enabled then
26067 return Name_Ignore;
26071 ---------------------------
26072 -- Check_Missing_Part_Of --
26073 ---------------------------
26075 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26076 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26077 -- Determine whether a package denoted by Pack_Id declares at least one
26080 -----------------------
26081 -- Has_Visible_State --
26082 -----------------------
26084 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26085 Item_Id : Entity_Id;
26088 -- Traverse the entity chain of the package trying to find at least
26089 -- one visible abstract state, variable or a package [instantiation]
26090 -- that declares a visible state.
26092 Item_Id := First_Entity (Pack_Id);
26093 while Present (Item_Id)
26094 and then not In_Private_Part (Item_Id)
26096 -- Do not consider internally generated items
26098 if not Comes_From_Source (Item_Id) then
26101 -- A visible state has been found
26103 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26106 -- Recursively peek into nested packages and instantiations
26108 elsif Ekind (Item_Id) = E_Package
26109 and then Has_Visible_State (Item_Id)
26114 Next_Entity (Item_Id);
26118 end Has_Visible_State;
26122 Pack_Id : Entity_Id;
26123 Placement : State_Space_Kind;
26125 -- Start of processing for Check_Missing_Part_Of
26128 -- Do not consider abstract states, variables or package instantiations
26129 -- coming from an instance as those always inherit the Part_Of indicator
26130 -- of the instance itself.
26132 if In_Instance then
26135 -- Do not consider internally generated entities as these can never
26136 -- have a Part_Of indicator.
26138 elsif not Comes_From_Source (Item_Id) then
26141 -- Perform these checks only when SPARK_Mode is enabled as they will
26142 -- interfere with standard Ada rules and produce false positives.
26144 elsif SPARK_Mode /= On then
26147 -- Do not consider constants, because the compiler cannot accurately
26148 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26149 -- act as a hidden state of a package.
26151 elsif Ekind (Item_Id) = E_Constant then
26155 -- Find where the abstract state, variable or package instantiation
26156 -- lives with respect to the state space.
26158 Find_Placement_In_State_Space
26159 (Item_Id => Item_Id,
26160 Placement => Placement,
26161 Pack_Id => Pack_Id);
26163 -- Items that appear in a non-package construct (subprogram, block, etc)
26164 -- do not require a Part_Of indicator because they can never act as a
26167 if Placement = Not_In_Package then
26170 -- An item declared in the body state space of a package always act as a
26171 -- constituent and does not need explicit Part_Of indicator.
26173 elsif Placement = Body_State_Space then
26176 -- In general an item declared in the visible state space of a package
26177 -- does not require a Part_Of indicator. The only exception is when the
26178 -- related package is a private child unit in which case Part_Of must
26179 -- denote a state in the parent unit or in one of its descendants.
26181 elsif Placement = Visible_State_Space then
26182 if Is_Child_Unit (Pack_Id)
26183 and then Is_Private_Descendant (Pack_Id)
26185 -- A package instantiation does not need a Part_Of indicator when
26186 -- the related generic template has no visible state.
26188 if Ekind (Item_Id) = E_Package
26189 and then Is_Generic_Instance (Item_Id)
26190 and then not Has_Visible_State (Item_Id)
26194 -- All other cases require Part_Of
26198 ("indicator Part_Of is required in this context "
26199 & "(SPARK RM 7.2.6(3))", Item_Id);
26200 Error_Msg_Name_1 := Chars (Pack_Id);
26202 ("\& is declared in the visible part of private child "
26203 & "unit %", Item_Id);
26207 -- When the item appears in the private state space of a packge, it must
26208 -- be a part of some state declared by the said package.
26210 else pragma Assert (Placement = Private_State_Space);
26212 -- The related package does not declare a state, the item cannot act
26213 -- as a Part_Of constituent.
26215 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26218 -- A package instantiation does not need a Part_Of indicator when the
26219 -- related generic template has no visible state.
26221 elsif Ekind (Pack_Id) = E_Package
26222 and then Is_Generic_Instance (Pack_Id)
26223 and then not Has_Visible_State (Pack_Id)
26227 -- All other cases require Part_Of
26231 ("indicator Part_Of is required in this context "
26232 & "(SPARK RM 7.2.6(2))", Item_Id);
26233 Error_Msg_Name_1 := Chars (Pack_Id);
26235 ("\& is declared in the private part of package %", Item_Id);
26238 end Check_Missing_Part_Of;
26240 ---------------------------------------------------
26241 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26242 ---------------------------------------------------
26244 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26246 Spec_Id : Entity_Id)
26249 if Warn_On_Redundant_Constructs
26250 and then Has_Pragma_Inline_Always (Spec_Id)
26252 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
26254 if From_Aspect_Specification (Prag) then
26256 ("aspect % not enforced on inlined subprogram &?r?",
26257 Corresponding_Aspect (Prag), Spec_Id);
26260 ("pragma % not enforced on inlined subprogram &?r?",
26264 end Check_Postcondition_Use_In_Inlined_Subprogram;
26266 -------------------------------------
26267 -- Check_State_And_Constituent_Use --
26268 -------------------------------------
26270 procedure Check_State_And_Constituent_Use
26271 (States : Elist_Id;
26272 Constits : Elist_Id;
26275 function Find_Encapsulating_State
26276 (Constit_Id : Entity_Id) return Entity_Id;
26277 -- Given the entity of a constituent, try to find a corresponding
26278 -- encapsulating state that appears in the same context. The routine
26279 -- returns Empty is no such state is found.
26281 ------------------------------
26282 -- Find_Encapsulating_State --
26283 ------------------------------
26285 function Find_Encapsulating_State
26286 (Constit_Id : Entity_Id) return Entity_Id
26288 State_Id : Entity_Id;
26291 -- Since a constituent may be part of a larger constituent set, climb
26292 -- the encapsulating state chain looking for a state that appears in
26293 -- the same context.
26295 State_Id := Encapsulating_State (Constit_Id);
26296 while Present (State_Id) loop
26297 if Contains (States, State_Id) then
26301 State_Id := Encapsulating_State (State_Id);
26305 end Find_Encapsulating_State;
26309 Constit_Elmt : Elmt_Id;
26310 Constit_Id : Entity_Id;
26311 State_Id : Entity_Id;
26313 -- Start of processing for Check_State_And_Constituent_Use
26316 -- Nothing to do if there are no states or constituents
26318 if No (States) or else No (Constits) then
26322 -- Inspect the list of constituents and try to determine whether its
26323 -- encapsulating state is in list States.
26325 Constit_Elmt := First_Elmt (Constits);
26326 while Present (Constit_Elmt) loop
26327 Constit_Id := Node (Constit_Elmt);
26329 -- Determine whether the constituent is part of an encapsulating
26330 -- state that appears in the same context and if this is the case,
26331 -- emit an error (SPARK RM 7.2.6(7)).
26333 State_Id := Find_Encapsulating_State (Constit_Id);
26335 if Present (State_Id) then
26336 Error_Msg_Name_1 := Chars (Constit_Id);
26338 ("cannot mention state & and its constituent % in the same "
26339 & "context", Context, State_Id);
26343 Next_Elmt (Constit_Elmt);
26345 end Check_State_And_Constituent_Use;
26347 ---------------------------------------
26348 -- Collect_Subprogram_Inputs_Outputs --
26349 ---------------------------------------
26351 procedure Collect_Subprogram_Inputs_Outputs
26352 (Subp_Id : Entity_Id;
26353 Synthesize : Boolean := False;
26354 Subp_Inputs : in out Elist_Id;
26355 Subp_Outputs : in out Elist_Id;
26356 Global_Seen : out Boolean)
26358 procedure Collect_Dependency_Clause (Clause : Node_Id);
26359 -- Collect all relevant items from a dependency clause
26361 procedure Collect_Global_List
26363 Mode : Name_Id := Name_Input);
26364 -- Collect all relevant items from a global list
26366 -------------------------------
26367 -- Collect_Dependency_Clause --
26368 -------------------------------
26370 procedure Collect_Dependency_Clause (Clause : Node_Id) is
26371 procedure Collect_Dependency_Item
26373 Is_Input : Boolean);
26374 -- Add an item to the proper subprogram input or output collection
26376 -----------------------------
26377 -- Collect_Dependency_Item --
26378 -----------------------------
26380 procedure Collect_Dependency_Item
26382 Is_Input : Boolean)
26387 -- Nothing to collect when the item is null
26389 if Nkind (Item) = N_Null then
26392 -- Ditto for attribute 'Result
26394 elsif Is_Attribute_Result (Item) then
26397 -- Multiple items appear as an aggregate
26399 elsif Nkind (Item) = N_Aggregate then
26400 Extra := First (Expressions (Item));
26401 while Present (Extra) loop
26402 Collect_Dependency_Item (Extra, Is_Input);
26406 -- Otherwise this is a solitary item
26410 Append_New_Elmt (Item, Subp_Inputs);
26412 Append_New_Elmt (Item, Subp_Outputs);
26415 end Collect_Dependency_Item;
26417 -- Start of processing for Collect_Dependency_Clause
26420 if Nkind (Clause) = N_Null then
26423 -- A dependency cause appears as component association
26425 elsif Nkind (Clause) = N_Component_Association then
26426 Collect_Dependency_Item
26427 (Item => Expression (Clause),
26430 Collect_Dependency_Item
26431 (Item => First (Choices (Clause)),
26432 Is_Input => False);
26434 -- To accomodate partial decoration of disabled SPARK features, this
26435 -- routine may be called with illegal input. If this is the case, do
26436 -- not raise Program_Error.
26441 end Collect_Dependency_Clause;
26443 -------------------------
26444 -- Collect_Global_List --
26445 -------------------------
26447 procedure Collect_Global_List
26449 Mode : Name_Id := Name_Input)
26451 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
26452 -- Add an item to the proper subprogram input or output collection
26454 -------------------------
26455 -- Collect_Global_Item --
26456 -------------------------
26458 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
26460 if Nam_In (Mode, Name_In_Out, Name_Input) then
26461 Append_New_Elmt (Item, Subp_Inputs);
26464 if Nam_In (Mode, Name_In_Out, Name_Output) then
26465 Append_New_Elmt (Item, Subp_Outputs);
26467 end Collect_Global_Item;
26474 -- Start of processing for Collect_Global_List
26477 if Nkind (List) = N_Null then
26480 -- Single global item declaration
26482 elsif Nkind_In (List, N_Expanded_Name,
26484 N_Selected_Component)
26486 Collect_Global_Item (List, Mode);
26488 -- Simple global list or moded global list declaration
26490 elsif Nkind (List) = N_Aggregate then
26491 if Present (Expressions (List)) then
26492 Item := First (Expressions (List));
26493 while Present (Item) loop
26494 Collect_Global_Item (Item, Mode);
26499 Assoc := First (Component_Associations (List));
26500 while Present (Assoc) loop
26501 Collect_Global_List
26502 (List => Expression (Assoc),
26503 Mode => Chars (First (Choices (Assoc))));
26508 -- To accomodate partial decoration of disabled SPARK features, this
26509 -- routine may be called with illegal input. If this is the case, do
26510 -- not raise Program_Error.
26515 end Collect_Global_List;
26519 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
26520 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26524 Formal : Entity_Id;
26528 -- Start of processing for Collect_Subprogram_Inputs_Outputs
26531 Global_Seen := False;
26533 -- Process all [generic] formal parameters
26535 Formal := First_Entity (Spec_Id);
26536 while Present (Formal) loop
26537 if Ekind_In (Formal, E_Generic_In_Parameter,
26538 E_In_Out_Parameter,
26541 Append_New_Elmt (Formal, Subp_Inputs);
26544 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
26545 E_In_Out_Parameter,
26548 Append_New_Elmt (Formal, Subp_Outputs);
26550 -- Out parameters can act as inputs when the related type is
26551 -- tagged, unconstrained array, unconstrained record or record
26552 -- with unconstrained components.
26554 if Ekind (Formal) = E_Out_Parameter
26555 and then Is_Unconstrained_Or_Tagged_Item (Formal)
26557 Append_New_Elmt (Formal, Subp_Inputs);
26561 Next_Entity (Formal);
26564 -- When processing an entry, subprogram or task body, look for pragmas
26565 -- Refined_Depends and Refined_Global as they specify the inputs and
26568 if Is_Entry_Body (Subp_Id)
26569 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
26571 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
26572 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
26574 -- Subprogram declaration or stand alone body case, look for pragmas
26575 -- Depends and Global
26578 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26579 Global := Get_Pragma (Spec_Id, Pragma_Global);
26582 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
26583 -- because it provides finer granularity of inputs and outputs.
26585 if Present (Global) then
26586 Global_Seen := True;
26587 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
26589 -- When the related subprogram lacks pragma [Refined_]Global, fall back
26590 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
26591 -- the inputs and outputs from [Refined_]Depends.
26593 elsif Synthesize and then Present (Depends) then
26594 Clauses := Expression (Get_Argument (Depends, Spec_Id));
26596 -- Multiple dependency clauses appear as an aggregate
26598 if Nkind (Clauses) = N_Aggregate then
26599 Clause := First (Component_Associations (Clauses));
26600 while Present (Clause) loop
26601 Collect_Dependency_Clause (Clause);
26605 -- Otherwise this is a single dependency clause
26608 Collect_Dependency_Clause (Clauses);
26612 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
26613 Typ := Scope (Spec_Id);
26615 -- A single protected type declaration does not have a current
26616 -- instance because the type is technically an object.
26618 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
26621 -- Otherwise the current instance of the protected type acts as a
26622 -- formal parameter of mode IN for functions and IN OUT for entries
26623 -- and procedures (SPARK RM 6.1.4).
26626 Append_New_Elmt (Typ, Subp_Inputs);
26628 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
26629 Append_New_Elmt (Typ, Subp_Outputs);
26633 elsif Ekind (Spec_Id) = E_Task_Type then
26636 -- A single task type declaration does not have a current instance
26637 -- because the type is technically an object.
26639 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
26642 -- Otherwise the current instance of the task type acts as a formal
26643 -- parameter of mode IN OUT (SPARK RM 6.1.4).
26646 Append_New_Elmt (Typ, Subp_Inputs);
26647 Append_New_Elmt (Typ, Subp_Outputs);
26650 end Collect_Subprogram_Inputs_Outputs;
26652 ---------------------------------
26653 -- Delay_Config_Pragma_Analyze --
26654 ---------------------------------
26656 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
26658 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
26659 Name_Priority_Specific_Dispatching);
26660 end Delay_Config_Pragma_Analyze;
26662 -----------------------
26663 -- Duplication_Error --
26664 -----------------------
26666 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
26667 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
26668 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
26671 Error_Msg_Sloc := Sloc (Prev);
26672 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
26674 -- Emit a precise message to distinguish between source pragmas and
26675 -- pragmas generated from aspects. The ordering of the two pragmas is
26679 -- Prag -- duplicate
26681 -- No error is emitted when both pragmas come from aspects because this
26682 -- is already detected by the general aspect analysis mechanism.
26684 if Prag_From_Asp and Prev_From_Asp then
26686 elsif Prag_From_Asp then
26687 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
26688 elsif Prev_From_Asp then
26689 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
26691 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
26693 end Duplication_Error;
26695 --------------------------
26696 -- Find_Related_Context --
26697 --------------------------
26699 function Find_Related_Context
26701 Do_Checks : Boolean := False) return Node_Id
26706 Stmt := Prev (Prag);
26707 while Present (Stmt) loop
26709 -- Skip prior pragmas, but check for duplicates
26711 if Nkind (Stmt) = N_Pragma then
26712 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
26718 -- Skip internally generated code
26720 elsif not Comes_From_Source (Stmt) then
26722 -- The anonymous object created for a single concurrent type is a
26723 -- suitable context.
26725 if Nkind (Stmt) = N_Object_Declaration
26726 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
26731 -- Return the current source construct
26741 end Find_Related_Context;
26743 --------------------------------------
26744 -- Find_Related_Declaration_Or_Body --
26745 --------------------------------------
26747 function Find_Related_Declaration_Or_Body
26749 Do_Checks : Boolean := False) return Node_Id
26751 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
26753 procedure Expression_Function_Error;
26754 -- Emit an error concerning pragma Prag that illegaly applies to an
26755 -- expression function.
26757 -------------------------------
26758 -- Expression_Function_Error --
26759 -------------------------------
26761 procedure Expression_Function_Error is
26763 Error_Msg_Name_1 := Prag_Nam;
26765 -- Emit a precise message to distinguish between source pragmas and
26766 -- pragmas generated from aspects.
26768 if From_Aspect_Specification (Prag) then
26770 ("aspect % cannot apply to a stand alone expression function",
26774 ("pragma % cannot apply to a stand alone expression function",
26777 end Expression_Function_Error;
26781 Context : constant Node_Id := Parent (Prag);
26784 Look_For_Body : constant Boolean :=
26785 Nam_In (Prag_Nam, Name_Refined_Depends,
26786 Name_Refined_Global,
26787 Name_Refined_Post);
26788 -- Refinement pragmas must be associated with a subprogram body [stub]
26790 -- Start of processing for Find_Related_Declaration_Or_Body
26793 Stmt := Prev (Prag);
26794 while Present (Stmt) loop
26796 -- Skip prior pragmas, but check for duplicates. Pragmas produced
26797 -- by splitting a complex pre/postcondition are not considered to
26800 if Nkind (Stmt) = N_Pragma then
26802 and then not Split_PPC (Stmt)
26803 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
26810 -- Emit an error when a refinement pragma appears on an expression
26811 -- function without a completion.
26814 and then Look_For_Body
26815 and then Nkind (Stmt) = N_Subprogram_Declaration
26816 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
26817 and then not Has_Completion (Defining_Entity (Stmt))
26819 Expression_Function_Error;
26822 -- The refinement pragma applies to a subprogram body stub
26824 elsif Look_For_Body
26825 and then Nkind (Stmt) = N_Subprogram_Body_Stub
26829 -- Skip internally generated code
26831 elsif not Comes_From_Source (Stmt) then
26833 -- The anonymous object created for a single concurrent type is a
26834 -- suitable context.
26836 if Nkind (Stmt) = N_Object_Declaration
26837 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
26841 elsif Nkind (Stmt) = N_Subprogram_Declaration then
26843 -- The subprogram declaration is an internally generated spec
26844 -- for an expression function.
26846 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
26849 -- The subprogram is actually an instance housed within an
26850 -- anonymous wrapper package.
26852 elsif Present (Generic_Parent (Specification (Stmt))) then
26857 -- Return the current construct which is either a subprogram body,
26858 -- a subprogram declaration or is illegal.
26867 -- If we fall through, then the pragma was either the first declaration
26868 -- or it was preceded by other pragmas and no source constructs.
26870 -- The pragma is associated with a library-level subprogram
26872 if Nkind (Context) = N_Compilation_Unit_Aux then
26873 return Unit (Parent (Context));
26875 -- The pragma appears inside the declarations of an entry body
26877 elsif Nkind (Context) = N_Entry_Body then
26880 -- The pragma appears inside the statements of a subprogram body. This
26881 -- placement is the result of subprogram contract expansion.
26883 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
26884 return Parent (Context);
26886 -- The pragma appears inside the declarative part of a subprogram body
26888 elsif Nkind (Context) = N_Subprogram_Body then
26891 -- The pragma appears inside the declarative part of a task body
26893 elsif Nkind (Context) = N_Task_Body then
26896 -- The pragma is a byproduct of aspect expansion, return the related
26897 -- context of the original aspect. This case has a lower priority as
26898 -- the above circuitry pinpoints precisely the related context.
26900 elsif Present (Corresponding_Aspect (Prag)) then
26901 return Parent (Corresponding_Aspect (Prag));
26903 -- No candidate subprogram [body] found
26908 end Find_Related_Declaration_Or_Body;
26910 ----------------------------------
26911 -- Find_Related_Package_Or_Body --
26912 ----------------------------------
26914 function Find_Related_Package_Or_Body
26916 Do_Checks : Boolean := False) return Node_Id
26918 Context : constant Node_Id := Parent (Prag);
26919 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26923 Stmt := Prev (Prag);
26924 while Present (Stmt) loop
26926 -- Skip prior pragmas, but check for duplicates
26928 if Nkind (Stmt) = N_Pragma then
26929 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
26935 -- Skip internally generated code
26937 elsif not Comes_From_Source (Stmt) then
26938 if Nkind (Stmt) = N_Subprogram_Declaration then
26940 -- The subprogram declaration is an internally generated spec
26941 -- for an expression function.
26943 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
26946 -- The subprogram is actually an instance housed within an
26947 -- anonymous wrapper package.
26949 elsif Present (Generic_Parent (Specification (Stmt))) then
26954 -- Return the current source construct which is illegal
26963 -- If we fall through, then the pragma was either the first declaration
26964 -- or it was preceded by other pragmas and no source constructs.
26966 -- The pragma is associated with a package. The immediate context in
26967 -- this case is the specification of the package.
26969 if Nkind (Context) = N_Package_Specification then
26970 return Parent (Context);
26972 -- The pragma appears in the declarations of a package body
26974 elsif Nkind (Context) = N_Package_Body then
26977 -- The pragma appears in the statements of a package body
26979 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
26980 and then Nkind (Parent (Context)) = N_Package_Body
26982 return Parent (Context);
26984 -- The pragma is a byproduct of aspect expansion, return the related
26985 -- context of the original aspect. This case has a lower priority as
26986 -- the above circuitry pinpoints precisely the related context.
26988 elsif Present (Corresponding_Aspect (Prag)) then
26989 return Parent (Corresponding_Aspect (Prag));
26991 -- No candidate packge [body] found
26996 end Find_Related_Package_Or_Body;
27002 function Get_Argument
27004 Context_Id : Entity_Id := Empty) return Node_Id
27006 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27009 -- Use the expression of the original aspect when compiling for ASIS or
27010 -- when analyzing the template of a generic unit. In both cases the
27011 -- aspect's tree must be decorated to allow for ASIS queries or to save
27012 -- the global references in the generic context.
27014 if From_Aspect_Specification (Prag)
27015 and then (ASIS_Mode or else (Present (Context_Id)
27016 and then Is_Generic_Unit (Context_Id)))
27018 return Corresponding_Aspect (Prag);
27020 -- Otherwise use the expression of the pragma
27022 elsif Present (Args) then
27023 return First (Args);
27030 -------------------------
27031 -- Get_Base_Subprogram --
27032 -------------------------
27034 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27035 Result : Entity_Id;
27038 -- Follow subprogram renaming chain
27042 if Is_Subprogram (Result)
27044 Nkind (Parent (Declaration_Node (Result))) =
27045 N_Subprogram_Renaming_Declaration
27046 and then Present (Alias (Result))
27048 Result := Alias (Result);
27052 end Get_Base_Subprogram;
27054 -----------------------
27055 -- Get_SPARK_Mode_Type --
27056 -----------------------
27058 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27060 if N = Name_On then
27062 elsif N = Name_Off then
27065 -- Any other argument is illegal
27068 raise Program_Error;
27070 end Get_SPARK_Mode_Type;
27072 --------------------------------
27073 -- Get_SPARK_Mode_From_Pragma --
27074 --------------------------------
27076 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is
27081 pragma Assert (Nkind (N) = N_Pragma);
27082 Args := Pragma_Argument_Associations (N);
27084 -- Extract the mode from the argument list
27086 if Present (Args) then
27087 Mode := First (Pragma_Argument_Associations (N));
27088 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode)));
27090 -- If SPARK_Mode pragma has no argument, default is ON
27095 end Get_SPARK_Mode_From_Pragma;
27097 ---------------------------
27098 -- Has_Extra_Parentheses --
27099 ---------------------------
27101 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
27105 -- The aggregate should not have an expression list because a clause
27106 -- is always interpreted as a component association. The only way an
27107 -- expression list can sneak in is by adding extra parentheses around
27108 -- the individual clauses:
27110 -- Depends (Output => Input) -- proper form
27111 -- Depends ((Output => Input)) -- extra parentheses
27113 -- Since the extra parentheses are not allowed by the syntax of the
27114 -- pragma, flag them now to avoid emitting misleading errors down the
27117 if Nkind (Clause) = N_Aggregate
27118 and then Present (Expressions (Clause))
27120 Expr := First (Expressions (Clause));
27121 while Present (Expr) loop
27123 -- A dependency clause surrounded by extra parentheses appears
27124 -- as an aggregate of component associations with an optional
27125 -- Paren_Count set.
27127 if Nkind (Expr) = N_Aggregate
27128 and then Present (Component_Associations (Expr))
27131 ("dependency clause contains extra parentheses", Expr);
27133 -- Otherwise the expression is a malformed construct
27136 SPARK_Msg_N ("malformed dependency clause", Expr);
27146 end Has_Extra_Parentheses;
27152 procedure Initialize is
27163 Dummy := Dummy + 1;
27166 -----------------------------
27167 -- Is_Config_Static_String --
27168 -----------------------------
27170 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
27172 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
27173 -- This is an internal recursive function that is just like the outer
27174 -- function except that it adds the string to the name buffer rather
27175 -- than placing the string in the name buffer.
27177 ------------------------------
27178 -- Add_Config_Static_String --
27179 ------------------------------
27181 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
27188 if Nkind (N) = N_Op_Concat then
27189 if Add_Config_Static_String (Left_Opnd (N)) then
27190 N := Right_Opnd (N);
27196 if Nkind (N) /= N_String_Literal then
27197 Error_Msg_N ("string literal expected for pragma argument", N);
27201 for J in 1 .. String_Length (Strval (N)) loop
27202 C := Get_String_Char (Strval (N), J);
27204 if not In_Character_Range (C) then
27206 ("string literal contains invalid wide character",
27207 Sloc (N) + 1 + Source_Ptr (J));
27211 Add_Char_To_Name_Buffer (Get_Character (C));
27216 end Add_Config_Static_String;
27218 -- Start of processing for Is_Config_Static_String
27223 return Add_Config_Static_String (Arg);
27224 end Is_Config_Static_String;
27226 ---------------------
27227 -- Is_CCT_Instance --
27228 ---------------------
27230 function Is_CCT_Instance (Ref : Node_Id) return Boolean is
27231 Ref_Id : constant Entity_Id := Entity (Ref);
27235 -- Climb the scope chain looking for an enclosing concurrent type that
27236 -- matches the referenced entity.
27238 S := Current_Scope;
27239 while Present (S) and then S /= Standard_Standard loop
27240 if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id
27249 end Is_CCT_Instance;
27251 -------------------------------
27252 -- Is_Elaboration_SPARK_Mode --
27253 -------------------------------
27255 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
27258 (Nkind (N) = N_Pragma
27259 and then Pragma_Name (N) = Name_SPARK_Mode
27260 and then Is_List_Member (N));
27262 -- Pragma SPARK_Mode affects the elaboration of a package body when it
27263 -- appears in the statement part of the body.
27266 Present (Parent (N))
27267 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
27268 and then List_Containing (N) = Statements (Parent (N))
27269 and then Present (Parent (Parent (N)))
27270 and then Nkind (Parent (Parent (N))) = N_Package_Body;
27271 end Is_Elaboration_SPARK_Mode;
27273 -----------------------
27274 -- Is_Enabled_Pragma --
27275 -----------------------
27277 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
27281 if Present (Prag) then
27282 Arg := First (Pragma_Argument_Associations (Prag));
27284 if Present (Arg) then
27285 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
27287 -- The lack of a Boolean argument automatically enables the pragma
27293 -- The pragma is missing, therefore it is not enabled
27298 end Is_Enabled_Pragma;
27300 -----------------------------------------
27301 -- Is_Non_Significant_Pragma_Reference --
27302 -----------------------------------------
27304 -- This function makes use of the following static table which indicates
27305 -- whether appearance of some name in a given pragma is to be considered
27306 -- as a reference for the purposes of warnings about unreferenced objects.
27308 -- -1 indicates that appearence in any argument is significant
27309 -- 0 indicates that appearance in any argument is not significant
27310 -- +n indicates that appearance as argument n is significant, but all
27311 -- other arguments are not significant
27312 -- 9n arguments from n on are significant, before n insignificant
27314 Sig_Flags : constant array (Pragma_Id) of Int :=
27315 (Pragma_Abort_Defer => -1,
27316 Pragma_Abstract_State => -1,
27317 Pragma_Ada_83 => -1,
27318 Pragma_Ada_95 => -1,
27319 Pragma_Ada_05 => -1,
27320 Pragma_Ada_2005 => -1,
27321 Pragma_Ada_12 => -1,
27322 Pragma_Ada_2012 => -1,
27323 Pragma_All_Calls_Remote => -1,
27324 Pragma_Allow_Integer_Address => -1,
27325 Pragma_Annotate => 93,
27326 Pragma_Assert => -1,
27327 Pragma_Assert_And_Cut => -1,
27328 Pragma_Assertion_Policy => 0,
27329 Pragma_Assume => -1,
27330 Pragma_Assume_No_Invalid_Values => 0,
27331 Pragma_Async_Readers => 0,
27332 Pragma_Async_Writers => 0,
27333 Pragma_Asynchronous => 0,
27334 Pragma_Atomic => 0,
27335 Pragma_Atomic_Components => 0,
27336 Pragma_Attach_Handler => -1,
27337 Pragma_Attribute_Definition => 92,
27338 Pragma_Check => -1,
27339 Pragma_Check_Float_Overflow => 0,
27340 Pragma_Check_Name => 0,
27341 Pragma_Check_Policy => 0,
27342 Pragma_CPP_Class => 0,
27343 Pragma_CPP_Constructor => 0,
27344 Pragma_CPP_Virtual => 0,
27345 Pragma_CPP_Vtable => 0,
27347 Pragma_C_Pass_By_Copy => 0,
27348 Pragma_Comment => -1,
27349 Pragma_Common_Object => 0,
27350 Pragma_Compile_Time_Error => -1,
27351 Pragma_Compile_Time_Warning => -1,
27352 Pragma_Compiler_Unit => -1,
27353 Pragma_Compiler_Unit_Warning => -1,
27354 Pragma_Complete_Representation => 0,
27355 Pragma_Complex_Representation => 0,
27356 Pragma_Component_Alignment => 0,
27357 Pragma_Constant_After_Elaboration => 0,
27358 Pragma_Contract_Cases => -1,
27359 Pragma_Controlled => 0,
27360 Pragma_Convention => 0,
27361 Pragma_Convention_Identifier => 0,
27362 Pragma_Debug => -1,
27363 Pragma_Debug_Policy => 0,
27364 Pragma_Detect_Blocking => 0,
27365 Pragma_Default_Initial_Condition => -1,
27366 Pragma_Default_Scalar_Storage_Order => 0,
27367 Pragma_Default_Storage_Pool => 0,
27368 Pragma_Depends => -1,
27369 Pragma_Disable_Atomic_Synchronization => 0,
27370 Pragma_Discard_Names => 0,
27371 Pragma_Dispatching_Domain => -1,
27372 Pragma_Effective_Reads => 0,
27373 Pragma_Effective_Writes => 0,
27374 Pragma_Elaborate => 0,
27375 Pragma_Elaborate_All => 0,
27376 Pragma_Elaborate_Body => 0,
27377 Pragma_Elaboration_Checks => 0,
27378 Pragma_Eliminate => 0,
27379 Pragma_Enable_Atomic_Synchronization => 0,
27380 Pragma_Export => -1,
27381 Pragma_Export_Function => -1,
27382 Pragma_Export_Object => -1,
27383 Pragma_Export_Procedure => -1,
27384 Pragma_Export_Value => -1,
27385 Pragma_Export_Valued_Procedure => -1,
27386 Pragma_Extend_System => -1,
27387 Pragma_Extensions_Allowed => 0,
27388 Pragma_Extensions_Visible => 0,
27389 Pragma_External => -1,
27390 Pragma_Favor_Top_Level => 0,
27391 Pragma_External_Name_Casing => 0,
27392 Pragma_Fast_Math => 0,
27393 Pragma_Finalize_Storage_Only => 0,
27395 Pragma_Global => -1,
27396 Pragma_Ident => -1,
27397 Pragma_Ignore_Pragma => 0,
27398 Pragma_Implementation_Defined => -1,
27399 Pragma_Implemented => -1,
27400 Pragma_Implicit_Packing => 0,
27401 Pragma_Import => 93,
27402 Pragma_Import_Function => 0,
27403 Pragma_Import_Object => 0,
27404 Pragma_Import_Procedure => 0,
27405 Pragma_Import_Valued_Procedure => 0,
27406 Pragma_Independent => 0,
27407 Pragma_Independent_Components => 0,
27408 Pragma_Initial_Condition => -1,
27409 Pragma_Initialize_Scalars => 0,
27410 Pragma_Initializes => -1,
27411 Pragma_Inline => 0,
27412 Pragma_Inline_Always => 0,
27413 Pragma_Inline_Generic => 0,
27414 Pragma_Inspection_Point => -1,
27415 Pragma_Interface => 92,
27416 Pragma_Interface_Name => 0,
27417 Pragma_Interrupt_Handler => -1,
27418 Pragma_Interrupt_Priority => -1,
27419 Pragma_Interrupt_State => -1,
27420 Pragma_Invariant => -1,
27421 Pragma_Keep_Names => 0,
27422 Pragma_License => 0,
27423 Pragma_Link_With => -1,
27424 Pragma_Linker_Alias => -1,
27425 Pragma_Linker_Constructor => -1,
27426 Pragma_Linker_Destructor => -1,
27427 Pragma_Linker_Options => -1,
27428 Pragma_Linker_Section => 0,
27430 Pragma_Lock_Free => 0,
27431 Pragma_Locking_Policy => 0,
27432 Pragma_Loop_Invariant => -1,
27433 Pragma_Loop_Optimize => 0,
27434 Pragma_Loop_Variant => -1,
27435 Pragma_Machine_Attribute => -1,
27437 Pragma_Main_Storage => -1,
27438 Pragma_Memory_Size => 0,
27439 Pragma_No_Return => 0,
27440 Pragma_No_Body => 0,
27441 Pragma_No_Elaboration_Code_All => 0,
27442 Pragma_No_Inline => 0,
27443 Pragma_No_Run_Time => -1,
27444 Pragma_No_Strict_Aliasing => -1,
27445 Pragma_No_Tagged_Streams => 0,
27446 Pragma_Normalize_Scalars => 0,
27447 Pragma_Obsolescent => 0,
27448 Pragma_Optimize => 0,
27449 Pragma_Optimize_Alignment => 0,
27450 Pragma_Overflow_Mode => 0,
27451 Pragma_Overriding_Renamings => 0,
27452 Pragma_Ordered => 0,
27455 Pragma_Part_Of => 0,
27456 Pragma_Partition_Elaboration_Policy => 0,
27457 Pragma_Passive => 0,
27458 Pragma_Persistent_BSS => 0,
27459 Pragma_Polling => 0,
27460 Pragma_Prefix_Exception_Messages => 0,
27462 Pragma_Postcondition => -1,
27463 Pragma_Post_Class => -1,
27465 Pragma_Precondition => -1,
27466 Pragma_Predicate => -1,
27467 Pragma_Predicate_Failure => -1,
27468 Pragma_Preelaborable_Initialization => -1,
27469 Pragma_Preelaborate => 0,
27470 Pragma_Pre_Class => -1,
27471 Pragma_Priority => -1,
27472 Pragma_Priority_Specific_Dispatching => 0,
27473 Pragma_Profile => 0,
27474 Pragma_Profile_Warnings => 0,
27475 Pragma_Propagate_Exceptions => 0,
27476 Pragma_Provide_Shift_Operators => 0,
27477 Pragma_Psect_Object => 0,
27479 Pragma_Pure_Function => 0,
27480 Pragma_Queuing_Policy => 0,
27481 Pragma_Rational => 0,
27482 Pragma_Ravenscar => 0,
27483 Pragma_Refined_Depends => -1,
27484 Pragma_Refined_Global => -1,
27485 Pragma_Refined_Post => -1,
27486 Pragma_Refined_State => -1,
27487 Pragma_Relative_Deadline => 0,
27488 Pragma_Remote_Access_Type => -1,
27489 Pragma_Remote_Call_Interface => -1,
27490 Pragma_Remote_Types => -1,
27491 Pragma_Restricted_Run_Time => 0,
27492 Pragma_Restriction_Warnings => 0,
27493 Pragma_Restrictions => 0,
27494 Pragma_Reviewable => -1,
27495 Pragma_Short_Circuit_And_Or => 0,
27496 Pragma_Share_Generic => 0,
27497 Pragma_Shared => 0,
27498 Pragma_Shared_Passive => 0,
27499 Pragma_Short_Descriptors => 0,
27500 Pragma_Simple_Storage_Pool_Type => 0,
27501 Pragma_Source_File_Name => 0,
27502 Pragma_Source_File_Name_Project => 0,
27503 Pragma_Source_Reference => 0,
27504 Pragma_SPARK_Mode => 0,
27505 Pragma_Storage_Size => -1,
27506 Pragma_Storage_Unit => 0,
27507 Pragma_Static_Elaboration_Desired => 0,
27508 Pragma_Stream_Convert => 0,
27509 Pragma_Style_Checks => 0,
27510 Pragma_Subtitle => 0,
27511 Pragma_Suppress => 0,
27512 Pragma_Suppress_Exception_Locations => 0,
27513 Pragma_Suppress_All => 0,
27514 Pragma_Suppress_Debug_Info => 0,
27515 Pragma_Suppress_Initialization => 0,
27516 Pragma_System_Name => 0,
27517 Pragma_Task_Dispatching_Policy => 0,
27518 Pragma_Task_Info => -1,
27519 Pragma_Task_Name => -1,
27520 Pragma_Task_Storage => -1,
27521 Pragma_Test_Case => -1,
27522 Pragma_Thread_Local_Storage => -1,
27523 Pragma_Time_Slice => -1,
27525 Pragma_Type_Invariant => -1,
27526 Pragma_Type_Invariant_Class => -1,
27527 Pragma_Unchecked_Union => 0,
27528 Pragma_Unimplemented_Unit => 0,
27529 Pragma_Universal_Aliasing => 0,
27530 Pragma_Universal_Data => 0,
27531 Pragma_Unmodified => 0,
27532 Pragma_Unreferenced => 0,
27533 Pragma_Unreferenced_Objects => 0,
27534 Pragma_Unreserve_All_Interrupts => 0,
27535 Pragma_Unsuppress => 0,
27536 Pragma_Unevaluated_Use_Of_Old => 0,
27537 Pragma_Use_VADS_Size => 0,
27538 Pragma_Validity_Checks => 0,
27539 Pragma_Volatile => 0,
27540 Pragma_Volatile_Components => 0,
27541 Pragma_Volatile_Full_Access => 0,
27542 Pragma_Volatile_Function => 0,
27543 Pragma_Warning_As_Error => 0,
27544 Pragma_Warnings => 0,
27545 Pragma_Weak_External => 0,
27546 Pragma_Wide_Character_Encoding => 0,
27547 Unknown_Pragma => 0);
27549 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
27555 function Arg_No return Nat;
27556 -- Returns an integer showing what argument we are in. A value of
27557 -- zero means we are not in any of the arguments.
27563 function Arg_No return Nat is
27568 A := First (Pragma_Argument_Associations (Parent (P)));
27582 -- Start of processing for Non_Significant_Pragma_Reference
27587 if Nkind (P) /= N_Pragma_Argument_Association then
27591 Id := Get_Pragma_Id (Parent (P));
27592 C := Sig_Flags (Id);
27607 return AN < (C - 90);
27613 end Is_Non_Significant_Pragma_Reference;
27615 ------------------------------
27616 -- Is_Pragma_String_Literal --
27617 ------------------------------
27619 -- This function returns true if the corresponding pragma argument is a
27620 -- static string expression. These are the only cases in which string
27621 -- literals can appear as pragma arguments. We also allow a string literal
27622 -- as the first argument to pragma Assert (although it will of course
27623 -- always generate a type error).
27625 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
27626 Pragn : constant Node_Id := Parent (Par);
27627 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
27628 Pname : constant Name_Id := Pragma_Name (Pragn);
27634 N := First (Assoc);
27641 if Pname = Name_Assert then
27644 elsif Pname = Name_Export then
27647 elsif Pname = Name_Ident then
27650 elsif Pname = Name_Import then
27653 elsif Pname = Name_Interface_Name then
27656 elsif Pname = Name_Linker_Alias then
27659 elsif Pname = Name_Linker_Section then
27662 elsif Pname = Name_Machine_Attribute then
27665 elsif Pname = Name_Source_File_Name then
27668 elsif Pname = Name_Source_Reference then
27671 elsif Pname = Name_Title then
27674 elsif Pname = Name_Subtitle then
27680 end Is_Pragma_String_Literal;
27682 ---------------------------
27683 -- Is_Private_SPARK_Mode --
27684 ---------------------------
27686 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
27689 (Nkind (N) = N_Pragma
27690 and then Pragma_Name (N) = Name_SPARK_Mode
27691 and then Is_List_Member (N));
27693 -- For pragma SPARK_Mode to be private, it has to appear in the private
27694 -- declarations of a package.
27697 Present (Parent (N))
27698 and then Nkind (Parent (N)) = N_Package_Specification
27699 and then List_Containing (N) = Private_Declarations (Parent (N));
27700 end Is_Private_SPARK_Mode;
27702 -------------------------------------
27703 -- Is_Unconstrained_Or_Tagged_Item --
27704 -------------------------------------
27706 function Is_Unconstrained_Or_Tagged_Item
27707 (Item : Entity_Id) return Boolean
27709 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
27710 -- Determine whether record type Typ has at least one unconstrained
27713 ---------------------------------
27714 -- Has_Unconstrained_Component --
27715 ---------------------------------
27717 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
27721 Comp := First_Component (Typ);
27722 while Present (Comp) loop
27723 if Is_Unconstrained_Or_Tagged_Item (Comp) then
27727 Next_Component (Comp);
27731 end Has_Unconstrained_Component;
27735 Typ : constant Entity_Id := Etype (Item);
27737 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
27740 if Is_Tagged_Type (Typ) then
27743 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
27746 elsif Is_Record_Type (Typ) then
27747 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
27750 return Has_Unconstrained_Component (Typ);
27753 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
27759 end Is_Unconstrained_Or_Tagged_Item;
27761 -----------------------------
27762 -- Is_Valid_Assertion_Kind --
27763 -----------------------------
27765 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
27772 Name_Static_Predicate |
27773 Name_Dynamic_Predicate |
27778 Name_Type_Invariant |
27779 Name_uType_Invariant |
27783 Name_Assert_And_Cut |
27785 Name_Contract_Cases |
27787 Name_Default_Initial_Condition |
27789 Name_Initial_Condition |
27792 Name_Loop_Invariant |
27793 Name_Loop_Variant |
27794 Name_Postcondition |
27795 Name_Precondition |
27797 Name_Refined_Post |
27798 Name_Statement_Assertions => return True;
27800 when others => return False;
27802 end Is_Valid_Assertion_Kind;
27804 --------------------------------------
27805 -- Process_Compilation_Unit_Pragmas --
27806 --------------------------------------
27808 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
27810 -- A special check for pragma Suppress_All, a very strange DEC pragma,
27811 -- strange because it comes at the end of the unit. Rational has the
27812 -- same name for a pragma, but treats it as a program unit pragma, In
27813 -- GNAT we just decide to allow it anywhere at all. If it appeared then
27814 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
27815 -- node, and we insert a pragma Suppress (All_Checks) at the start of
27816 -- the context clause to ensure the correct processing.
27818 if Has_Pragma_Suppress_All (N) then
27819 Prepend_To (Context_Items (N),
27820 Make_Pragma (Sloc (N),
27821 Chars => Name_Suppress,
27822 Pragma_Argument_Associations => New_List (
27823 Make_Pragma_Argument_Association (Sloc (N),
27824 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
27827 -- Nothing else to do at the current time
27829 end Process_Compilation_Unit_Pragmas;
27831 ------------------------------------
27832 -- Record_Possible_Body_Reference --
27833 ------------------------------------
27835 procedure Record_Possible_Body_Reference
27836 (State_Id : Entity_Id;
27840 Spec_Id : Entity_Id;
27843 -- Ensure that we are dealing with a reference to a state
27845 pragma Assert (Ekind (State_Id) = E_Abstract_State);
27847 -- Climb the tree starting from the reference looking for a package body
27848 -- whose spec declares the referenced state. This criteria automatically
27849 -- excludes references in package specs which are legal. Note that it is
27850 -- not wise to emit an error now as the package body may lack pragma
27851 -- Refined_State or the referenced state may not be mentioned in the
27852 -- refinement. This approach avoids the generation of misleading errors.
27855 while Present (Context) loop
27856 if Nkind (Context) = N_Package_Body then
27857 Spec_Id := Corresponding_Spec (Context);
27859 if Present (Abstract_States (Spec_Id))
27860 and then Contains (Abstract_States (Spec_Id), State_Id)
27862 if No (Body_References (State_Id)) then
27863 Set_Body_References (State_Id, New_Elmt_List);
27866 Append_Elmt (Ref, To => Body_References (State_Id));
27871 Context := Parent (Context);
27873 end Record_Possible_Body_Reference;
27875 ------------------------------------------
27876 -- Relocate_Pragmas_To_Anonymous_Object --
27877 ------------------------------------------
27879 procedure Relocate_Pragmas_To_Anonymous_Object
27880 (Typ_Decl : Node_Id;
27881 Obj_Decl : Node_Id)
27885 Next_Decl : Node_Id;
27888 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
27889 Def := Protected_Definition (Typ_Decl);
27891 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
27892 Def := Task_Definition (Typ_Decl);
27895 -- The concurrent definition has a visible declaration list. Inspect it
27896 -- and relocate all canidate pragmas.
27898 if Present (Def) and then Present (Visible_Declarations (Def)) then
27899 Decl := First (Visible_Declarations (Def));
27900 while Present (Decl) loop
27902 -- Preserve the following declaration for iteration purposes due
27903 -- to possible relocation of a pragma.
27905 Next_Decl := Next (Decl);
27907 if Nkind (Decl) = N_Pragma
27908 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
27911 Insert_After (Obj_Decl, Decl);
27913 -- Skip internally generated code
27915 elsif not Comes_From_Source (Decl) then
27918 -- No candidate pragmas are available for relocation
27927 end Relocate_Pragmas_To_Anonymous_Object;
27929 ------------------------------
27930 -- Relocate_Pragmas_To_Body --
27931 ------------------------------
27933 procedure Relocate_Pragmas_To_Body
27934 (Subp_Body : Node_Id;
27935 Target_Body : Node_Id := Empty)
27937 procedure Relocate_Pragma (Prag : Node_Id);
27938 -- Remove a single pragma from its current list and add it to the
27939 -- declarations of the proper body (either Subp_Body or Target_Body).
27941 ---------------------
27942 -- Relocate_Pragma --
27943 ---------------------
27945 procedure Relocate_Pragma (Prag : Node_Id) is
27950 -- When subprogram stubs or expression functions are involves, the
27951 -- destination declaration list belongs to the proper body.
27953 if Present (Target_Body) then
27954 Target := Target_Body;
27956 Target := Subp_Body;
27959 Decls := Declarations (Target);
27963 Set_Declarations (Target, Decls);
27966 -- Unhook the pragma from its current list
27969 Prepend (Prag, Decls);
27970 end Relocate_Pragma;
27974 Body_Id : constant Entity_Id :=
27975 Defining_Unit_Name (Specification (Subp_Body));
27976 Next_Stmt : Node_Id;
27979 -- Start of processing for Relocate_Pragmas_To_Body
27982 -- Do not process a body that comes from a separate unit as no construct
27983 -- can possibly follow it.
27985 if not Is_List_Member (Subp_Body) then
27988 -- Do not relocate pragmas that follow a stub if the stub does not have
27991 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
27992 and then No (Target_Body)
27996 -- Do not process internally generated routine _Postconditions
27998 elsif Ekind (Body_Id) = E_Procedure
27999 and then Chars (Body_Id) = Name_uPostconditions
28004 -- Look at what is following the body. We are interested in certain kind
28005 -- of pragmas (either from source or byproducts of expansion) that can
28006 -- apply to a body [stub].
28008 Stmt := Next (Subp_Body);
28009 while Present (Stmt) loop
28011 -- Preserve the following statement for iteration purposes due to a
28012 -- possible relocation of a pragma.
28014 Next_Stmt := Next (Stmt);
28016 -- Move a candidate pragma following the body to the declarations of
28019 if Nkind (Stmt) = N_Pragma
28020 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28022 Relocate_Pragma (Stmt);
28024 -- Skip internally generated code
28026 elsif not Comes_From_Source (Stmt) then
28029 -- No candidate pragmas are available for relocation
28037 end Relocate_Pragmas_To_Body;
28039 -------------------
28040 -- Resolve_State --
28041 -------------------
28043 procedure Resolve_State (N : Node_Id) is
28048 if Is_Entity_Name (N) and then Present (Entity (N)) then
28049 Func := Entity (N);
28051 -- Handle overloading of state names by functions. Traverse the
28052 -- homonym chain looking for an abstract state.
28054 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
28055 State := Homonym (Func);
28056 while Present (State) loop
28058 -- Resolve the overloading by setting the proper entity of the
28059 -- reference to that of the state.
28061 if Ekind (State) = E_Abstract_State then
28062 Set_Etype (N, Standard_Void_Type);
28063 Set_Entity (N, State);
28064 Set_Associated_Node (N, State);
28068 State := Homonym (State);
28071 -- A function can never act as a state. If the homonym chain does
28072 -- not contain a corresponding state, then something went wrong in
28073 -- the overloading mechanism.
28075 raise Program_Error;
28080 ----------------------------
28081 -- Rewrite_Assertion_Kind --
28082 ----------------------------
28084 procedure Rewrite_Assertion_Kind (N : Node_Id) is
28088 if Nkind (N) = N_Attribute_Reference
28089 and then Attribute_Name (N) = Name_Class
28090 and then Nkind (Prefix (N)) = N_Identifier
28092 case Chars (Prefix (N)) is
28097 when Name_Type_Invariant =>
28098 Nam := Name_uType_Invariant;
28099 when Name_Invariant =>
28100 Nam := Name_uInvariant;
28105 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
28107 end Rewrite_Assertion_Kind;
28115 Dummy := Dummy + 1;
28118 --------------------------------
28119 -- Set_Encoded_Interface_Name --
28120 --------------------------------
28122 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
28123 Str : constant String_Id := Strval (S);
28124 Len : constant Int := String_Length (Str);
28129 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
28132 -- Stores encoded value of character code CC. The encoding we use an
28133 -- underscore followed by four lower case hex digits.
28139 procedure Encode is
28141 Store_String_Char (Get_Char_Code ('_'));
28143 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
28145 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
28147 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
28149 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
28152 -- Start of processing for Set_Encoded_Interface_Name
28155 -- If first character is asterisk, this is a link name, and we leave it
28156 -- completely unmodified. We also ignore null strings (the latter case
28157 -- happens only in error cases) and no encoding should occur for AAMP
28158 -- interface names.
28161 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
28162 or else AAMP_On_Target
28164 Set_Interface_Name (E, S);
28169 CC := Get_String_Char (Str, J);
28171 exit when not In_Character_Range (CC);
28173 C := Get_Character (CC);
28175 exit when C /= '_' and then C /= '$'
28176 and then C not in '0' .. '9'
28177 and then C not in 'a' .. 'z'
28178 and then C not in 'A' .. 'Z';
28181 Set_Interface_Name (E, S);
28189 -- Here we need to encode. The encoding we use as follows:
28190 -- three underscores + four hex digits (lower case)
28194 for J in 1 .. String_Length (Str) loop
28195 CC := Get_String_Char (Str, J);
28197 if not In_Character_Range (CC) then
28200 C := Get_Character (CC);
28202 if C = '_' or else C = '$'
28203 or else C in '0' .. '9'
28204 or else C in 'a' .. 'z'
28205 or else C in 'A' .. 'Z'
28207 Store_String_Char (CC);
28214 Set_Interface_Name (E,
28215 Make_String_Literal (Sloc (S),
28216 Strval => End_String));
28218 end Set_Encoded_Interface_Name;
28220 ------------------------
28221 -- Set_Elab_Unit_Name --
28222 ------------------------
28224 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
28229 if Nkind (N) = N_Identifier
28230 and then Nkind (With_Item) = N_Identifier
28232 Set_Entity (N, Entity (With_Item));
28234 elsif Nkind (N) = N_Selected_Component then
28235 Change_Selected_Component_To_Expanded_Name (N);
28236 Set_Entity (N, Entity (With_Item));
28237 Set_Entity (Selector_Name (N), Entity (N));
28239 Pref := Prefix (N);
28240 Scop := Scope (Entity (N));
28241 while Nkind (Pref) = N_Selected_Component loop
28242 Change_Selected_Component_To_Expanded_Name (Pref);
28243 Set_Entity (Selector_Name (Pref), Scop);
28244 Set_Entity (Pref, Scop);
28245 Pref := Prefix (Pref);
28246 Scop := Scope (Scop);
28249 Set_Entity (Pref, Scop);
28252 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
28253 end Set_Elab_Unit_Name;
28255 -------------------
28256 -- Test_Case_Arg --
28257 -------------------
28259 function Test_Case_Arg
28262 From_Aspect : Boolean := False) return Node_Id
28264 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
28269 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
28274 -- The caller requests the aspect argument
28276 if From_Aspect then
28277 if Present (Aspect)
28278 and then Nkind (Expression (Aspect)) = N_Aggregate
28280 Args := Expression (Aspect);
28282 -- "Name" and "Mode" may appear without an identifier as a
28283 -- positional association.
28285 if Present (Expressions (Args)) then
28286 Arg := First (Expressions (Args));
28288 if Present (Arg) and then Arg_Nam = Name_Name then
28296 if Present (Arg) and then Arg_Nam = Name_Mode then
28301 -- Some or all arguments may appear as component associatons
28303 if Present (Component_Associations (Args)) then
28304 Arg := First (Component_Associations (Args));
28305 while Present (Arg) loop
28306 if Chars (First (Choices (Arg))) = Arg_Nam then
28315 -- Otherwise retrieve the argument directly from the pragma
28318 Arg := First (Pragma_Argument_Associations (Prag));
28320 if Present (Arg) and then Arg_Nam = Name_Name then
28324 -- Skip argument "Name"
28328 if Present (Arg) and then Arg_Nam = Name_Mode then
28332 -- Skip argument "Mode"
28336 -- Arguments "Requires" and "Ensures" are optional and may not be
28339 while Present (Arg) loop
28340 if Chars (Arg) = Arg_Nam then