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 Csets; use Csets;
37 with Debug; use Debug;
38 with Einfo; use Einfo;
39 with Elists; use Elists;
40 with Errout; use Errout;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Util; use Exp_Util;
43 with Freeze; use Freeze;
44 with Ghost; use Ghost;
46 with Lib.Writ; use Lib.Writ;
47 with Lib.Xref; use Lib.Xref;
48 with Namet.Sp; use Namet.Sp;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
51 with Output; use Output;
52 with Par_SCO; use Par_SCO;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
57 with Sem_Aux; use Sem_Aux;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch6; use Sem_Ch6;
60 with Sem_Ch8; use Sem_Ch8;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elim; use Sem_Elim;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Intr; use Sem_Intr;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sem_Warn; use Sem_Warn;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.CN; use Sinfo.CN;
76 with Sinput; use Sinput;
77 with Stringt; use Stringt;
78 with Stylesw; use Stylesw;
80 with Targparm; use Targparm;
81 with Tbuild; use Tbuild;
83 with Uintp; use Uintp;
84 with Uname; use Uname;
85 with Urealp; use Urealp;
86 with Validsw; use Validsw;
87 with Warnsw; use Warnsw;
89 package body Sem_Prag is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all lower case letters.
130 -- Note: the external name specified or implied by any of these special
131 -- Import_xxx or Export_xxx pragmas override an external or link name
132 -- specified in a previous Import or Export pragma.
134 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
135 -- named notation, following the standard rules for subprogram calls, i.e.
136 -- parameters can be given in any order if named notation is used, and
137 -- positional and named notation can be mixed, subject to the rule that all
138 -- positional parameters must appear first.
140 -- Note: All these pragmas are implemented exactly following the DEC design
141 -- and implementation and are intended to be fully compatible with the use
142 -- of these pragmas in the DEC Ada compiler.
144 --------------------------------------------
145 -- Checking for Duplicated External Names --
146 --------------------------------------------
148 -- It is suspicious if two separate Export pragmas use the same external
149 -- name. The following table is used to diagnose this situation so that
150 -- an appropriate warning can be issued.
152 -- The Node_Id stored is for the N_String_Literal node created to hold
153 -- the value of the external name. The Sloc of this node is used to
154 -- cross-reference the location of the duplication.
156 package Externals is new Table.Table (
157 Table_Component_Type => Node_Id,
158 Table_Index_Type => Int,
159 Table_Low_Bound => 0,
160 Table_Initial => 100,
161 Table_Increment => 100,
162 Table_Name => "Name_Externals");
164 -------------------------------------
165 -- Local Subprograms and Variables --
166 -------------------------------------
168 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
169 -- Subsidiary routine to the analysis of pragmas Depends, Global and
170 -- Refined_State. Append an entity to a list. If the list is empty, create
173 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
182 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
183 -- Query whether a particular item appears in a mixed list of nodes and
184 -- entities. It is assumed that all nodes in the list have entities.
186 procedure Check_Postcondition_Use_In_Inlined_Subprogram
188 Spec_Id : Entity_Id);
189 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
190 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
191 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
193 procedure Check_State_And_Constituent_Use
197 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
198 -- Global and Initializes. Determine whether a state from list States and a
199 -- corresponding constituent from list Constits (if any) appear in the same
200 -- context denoted by Context. If this is the case, emit an error.
202 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
203 -- Subsidiary to routines Find_Related_Package_Or_Body and
204 -- Find_Related_Subprogram_Or_Body. Emit an error on pragma Prag that
205 -- duplicates previous pragma Prev.
207 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
208 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
209 -- original one, following the renaming chain) is returned. Otherwise the
210 -- entity is returned unchanged. Should be in Einfo???
212 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
213 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
214 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
217 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
218 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
219 -- Determine whether dependency clause Clause is surrounded by extra
220 -- parentheses. If this is the case, issue an error message.
222 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
223 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
224 -- pragma Depends. Determine whether the type of dependency item Item is
225 -- tagged, unconstrained array, unconstrained record or a record with at
226 -- least one unconstrained component.
228 procedure Record_Possible_Body_Reference
229 (State_Id : Entity_Id;
231 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
232 -- Global. Given an abstract state denoted by State_Id and a reference Ref
233 -- to it, determine whether the reference appears in a package body that
234 -- will eventually refine the state. If this is the case, record the
235 -- reference for future checks (see Analyze_Refined_State_In_Decls).
237 procedure Resolve_State (N : Node_Id);
238 -- Handle the overloading of state names by functions. When N denotes a
239 -- function, this routine finds the corresponding state and sets the entity
240 -- of N to that of the state.
242 procedure Rewrite_Assertion_Kind (N : Node_Id);
243 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
244 -- then it is rewritten as an identifier with the corresponding special
245 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
248 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
249 -- Place semantic information on the argument of an Elaborate/Elaborate_All
250 -- pragma. Entity name for unit and its parents is taken from item in
251 -- previous with_clause that mentions the unit.
253 Dummy : Integer := 0;
254 pragma Volatile (Dummy);
255 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
258 pragma No_Inline (ip);
259 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
260 -- is just to help debugging the front end. If a pragma Inspection_Point
261 -- is added to a source program, then breaking on ip will get you to that
262 -- point in the program.
265 pragma No_Inline (rv);
266 -- This is a dummy function called by the processing for pragma Reviewable.
267 -- It is there for assisting front end debugging. By placing a Reviewable
268 -- pragma in the source program, a breakpoint on rv catches this place in
269 -- the source, allowing convenient stepping to the point of interest.
275 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
277 Append_New_Elmt (Item, To => To_List);
280 -------------------------------
281 -- Adjust_External_Name_Case --
282 -------------------------------
284 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
288 -- Adjust case of literal if required
290 if Opt.External_Name_Exp_Casing = As_Is then
294 -- Copy existing string
300 for J in 1 .. String_Length (Strval (N)) loop
301 CC := Get_String_Char (Strval (N), J);
303 if Opt.External_Name_Exp_Casing = Uppercase
304 and then CC >= Get_Char_Code ('a')
305 and then CC <= Get_Char_Code ('z')
307 Store_String_Char (CC - 32);
309 elsif Opt.External_Name_Exp_Casing = Lowercase
310 and then CC >= Get_Char_Code ('A')
311 and then CC <= Get_Char_Code ('Z')
313 Store_String_Char (CC + 32);
316 Store_String_Char (CC);
321 Make_String_Literal (Sloc (N),
322 Strval => End_String);
324 end Adjust_External_Name_Case;
326 -----------------------------------------
327 -- Analyze_Contract_Cases_In_Decl_Part --
328 -----------------------------------------
330 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
331 Others_Seen : Boolean := False;
333 procedure Analyze_Contract_Case (CCase : Node_Id);
334 -- Verify the legality of a single contract case
336 ---------------------------
337 -- Analyze_Contract_Case --
338 ---------------------------
340 procedure Analyze_Contract_Case (CCase : Node_Id) is
341 Case_Guard : Node_Id;
343 Extra_Guard : Node_Id;
346 if Nkind (CCase) = N_Component_Association then
347 Case_Guard := First (Choices (CCase));
348 Conseq := Expression (CCase);
350 -- Each contract case must have exactly one case guard
352 Extra_Guard := Next (Case_Guard);
354 if Present (Extra_Guard) then
356 ("contract case must have exactly one case guard",
360 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
362 if Nkind (Case_Guard) = N_Others_Choice then
365 ("only one others choice allowed in contract cases",
371 elsif Others_Seen then
373 ("others must be the last choice in contract cases", N);
376 -- Preanalyze the case guard and consequence
378 if Nkind (Case_Guard) /= N_Others_Choice then
379 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
382 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
384 -- The contract case is malformed
387 Error_Msg_N ("wrong syntax in contract case", CCase);
389 end Analyze_Contract_Case;
393 GM : constant Ghost_Mode_Type := Ghost_Mode;
395 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
396 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
397 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
400 Restore_Scope : Boolean := False;
402 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
405 -- Set the Ghost mode in effect from the pragma. Due to the delayed
406 -- analysis of the pragma, the Ghost mode at point of declaration and
407 -- point of analysis may not necessarely be the same. Use the mode in
408 -- effect at the point of declaration.
413 -- Single and multiple contract cases must appear in aggregate form. If
414 -- this is not the case, then either the parser of the analysis of the
415 -- pragma failed to produce an aggregate.
417 pragma Assert (Nkind (CCases) = N_Aggregate);
419 if Present (Component_Associations (CCases)) then
421 -- Ensure that the formal parameters are visible when analyzing all
422 -- clauses. This falls out of the general rule of aspects pertaining
423 -- to subprogram declarations.
425 if not In_Open_Scopes (Spec_Id) then
426 Restore_Scope := True;
427 Push_Scope (Spec_Id);
429 if Is_Generic_Subprogram (Spec_Id) then
430 Install_Generic_Formals (Spec_Id);
432 Install_Formals (Spec_Id);
436 CCase := First (Component_Associations (CCases));
437 while Present (CCase) loop
438 Analyze_Contract_Case (CCase);
442 if Restore_Scope then
446 -- Currently it is not possible to inline pre/postconditions on a
447 -- subprogram subject to pragma Inline_Always.
449 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
451 -- Otherwise the pragma is illegal
454 Error_Msg_N ("wrong syntax for constract cases", N);
457 -- Restore the original Ghost mode once analysis and expansion have
461 end Analyze_Contract_Cases_In_Decl_Part;
463 ----------------------------------
464 -- Analyze_Depends_In_Decl_Part --
465 ----------------------------------
467 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
468 Loc : constant Source_Ptr := Sloc (N);
469 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
470 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
472 All_Inputs_Seen : Elist_Id := No_Elist;
473 -- A list containing the entities of all the inputs processed so far.
474 -- The list is populated with unique entities because the same input
475 -- may appear in multiple input lists.
477 All_Outputs_Seen : Elist_Id := No_Elist;
478 -- A list containing the entities of all the outputs processed so far.
479 -- The list is populated with unique entities because output items are
480 -- unique in a dependence relation.
482 Constits_Seen : Elist_Id := No_Elist;
483 -- A list containing the entities of all constituents processed so far.
484 -- It aids in detecting illegal usage of a state and a corresponding
485 -- constituent in pragma [Refinde_]Depends.
487 Global_Seen : Boolean := False;
488 -- A flag set when pragma Global has been processed
490 Null_Output_Seen : Boolean := False;
491 -- A flag used to track the legality of a null output
493 Result_Seen : Boolean := False;
494 -- A flag set when Spec_Id'Result is processed
496 States_Seen : Elist_Id := No_Elist;
497 -- A list containing the entities of all states processed so far. It
498 -- helps in detecting illegal usage of a state and a corresponding
499 -- constituent in pragma [Refined_]Depends.
501 Subp_Inputs : Elist_Id := No_Elist;
502 Subp_Outputs : Elist_Id := No_Elist;
503 -- Two lists containing the full set of inputs and output of the related
504 -- subprograms. Note that these lists contain both nodes and entities.
506 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
507 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
508 -- to the name buffer. The individual kinds are as follows:
509 -- E_Abstract_State - "state"
510 -- E_Constant - "constant"
511 -- E_Generic_In_Out_Parameter - "generic parameter"
512 -- E_Generic_Out_Parameter - "generic parameter"
513 -- E_In_Parameter - "parameter"
514 -- E_In_Out_Parameter - "parameter"
515 -- E_Out_Parameter - "parameter"
516 -- E_Variable - "global"
518 procedure Analyze_Dependency_Clause
521 -- Verify the legality of a single dependency clause. Flag Is_Last
522 -- denotes whether Clause is the last clause in the relation.
524 procedure Check_Function_Return;
525 -- Verify that Funtion'Result appears as one of the outputs
526 -- (SPARK RM 6.1.5(10)).
533 -- Ensure that an item fulfils its designated input and/or output role
534 -- as specified by pragma Global (if any) or the enclosing context. If
535 -- this is not the case, emit an error. Item and Item_Id denote the
536 -- attributes of an item. Flag Is_Input should be set when item comes
537 -- from an input list. Flag Self_Ref should be set when the item is an
538 -- output and the dependency clause has operator "+".
540 procedure Check_Usage
541 (Subp_Items : Elist_Id;
542 Used_Items : Elist_Id;
544 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
545 -- error if this is not the case.
547 procedure Normalize_Clause (Clause : Node_Id);
548 -- Remove a self-dependency "+" from the input list of a clause
550 -----------------------------
551 -- Add_Item_To_Name_Buffer --
552 -----------------------------
554 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
556 if Ekind (Item_Id) = E_Abstract_State then
557 Add_Str_To_Name_Buffer ("state");
559 elsif Ekind (Item_Id) = E_Constant then
560 Add_Str_To_Name_Buffer ("constant");
562 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
563 E_Generic_In_Parameter)
565 Add_Str_To_Name_Buffer ("generic parameter");
567 elsif Is_Formal (Item_Id) then
568 Add_Str_To_Name_Buffer ("parameter");
570 elsif Ekind (Item_Id) = E_Variable then
571 Add_Str_To_Name_Buffer ("global");
573 -- The routine should not be called with non-SPARK items
578 end Add_Item_To_Name_Buffer;
580 -------------------------------
581 -- Analyze_Dependency_Clause --
582 -------------------------------
584 procedure Analyze_Dependency_Clause
588 procedure Analyze_Input_List (Inputs : Node_Id);
589 -- Verify the legality of a single input list
591 procedure Analyze_Input_Output
596 Seen : in out Elist_Id;
597 Null_Seen : in out Boolean;
598 Non_Null_Seen : in out Boolean);
599 -- Verify the legality of a single input or output item. Flag
600 -- Is_Input should be set whenever Item is an input, False when it
601 -- denotes an output. Flag Self_Ref should be set when the item is an
602 -- output and the dependency clause has a "+". Flag Top_Level should
603 -- be set whenever Item appears immediately within an input or output
604 -- list. Seen is a collection of all abstract states, objects and
605 -- formals processed so far. Flag Null_Seen denotes whether a null
606 -- input or output has been encountered. Flag Non_Null_Seen denotes
607 -- whether a non-null input or output has been encountered.
609 ------------------------
610 -- Analyze_Input_List --
611 ------------------------
613 procedure Analyze_Input_List (Inputs : Node_Id) is
614 Inputs_Seen : Elist_Id := No_Elist;
615 -- A list containing the entities of all inputs that appear in the
616 -- current input list.
618 Non_Null_Input_Seen : Boolean := False;
619 Null_Input_Seen : Boolean := False;
620 -- Flags used to check the legality of an input list
625 -- Multiple inputs appear as an aggregate
627 if Nkind (Inputs) = N_Aggregate then
628 if Present (Component_Associations (Inputs)) then
630 ("nested dependency relations not allowed", Inputs);
632 elsif Present (Expressions (Inputs)) then
633 Input := First (Expressions (Inputs));
634 while Present (Input) loop
641 Null_Seen => Null_Input_Seen,
642 Non_Null_Seen => Non_Null_Input_Seen);
647 -- Syntax error, always report
650 Error_Msg_N ("malformed input dependency list", Inputs);
653 -- Process a solitary input
662 Null_Seen => Null_Input_Seen,
663 Non_Null_Seen => Non_Null_Input_Seen);
666 -- Detect an illegal dependency clause of the form
670 if Null_Output_Seen and then Null_Input_Seen then
672 ("null dependency clause cannot have a null input list",
675 end Analyze_Input_List;
677 --------------------------
678 -- Analyze_Input_Output --
679 --------------------------
681 procedure Analyze_Input_Output
686 Seen : in out Elist_Id;
687 Null_Seen : in out Boolean;
688 Non_Null_Seen : in out Boolean)
690 Is_Output : constant Boolean := not Is_Input;
695 -- Multiple input or output items appear as an aggregate
697 if Nkind (Item) = N_Aggregate then
698 if not Top_Level then
699 SPARK_Msg_N ("nested grouping of items not allowed", Item);
701 elsif Present (Component_Associations (Item)) then
703 ("nested dependency relations not allowed", Item);
705 -- Recursively analyze the grouped items
707 elsif Present (Expressions (Item)) then
708 Grouped := First (Expressions (Item));
709 while Present (Grouped) loop
712 Is_Input => Is_Input,
713 Self_Ref => Self_Ref,
716 Null_Seen => Null_Seen,
717 Non_Null_Seen => Non_Null_Seen);
722 -- Syntax error, always report
725 Error_Msg_N ("malformed dependency list", Item);
728 -- Process attribute 'Result in the context of a dependency clause
730 elsif Is_Attribute_Result (Item) then
731 Non_Null_Seen := True;
735 -- Attribute 'Result is allowed to appear on the output side of
736 -- a dependency clause (SPARK RM 6.1.5(6)).
739 SPARK_Msg_N ("function result cannot act as input", Item);
743 ("cannot mix null and non-null dependency items", Item);
749 -- Detect multiple uses of null in a single dependency list or
750 -- throughout the whole relation. Verify the placement of a null
751 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
753 elsif Nkind (Item) = N_Null then
756 ("multiple null dependency relations not allowed", Item);
758 elsif Non_Null_Seen then
760 ("cannot mix null and non-null dependency items", Item);
768 ("null output list must be the last clause in a "
769 & "dependency relation", Item);
771 -- Catch a useless dependence of the form:
776 ("useless dependence, null depends on itself", Item);
784 Non_Null_Seen := True;
787 SPARK_Msg_N ("cannot mix null and non-null items", Item);
791 Resolve_State (Item);
793 -- Find the entity of the item. If this is a renaming, climb
794 -- the renaming chain to reach the root object. Renamings of
795 -- non-entire objects do not yield an entity (Empty).
797 Item_Id := Entity_Of (Item);
799 if Present (Item_Id) then
800 if Ekind_In (Item_Id, E_Abstract_State,
802 E_Generic_In_Out_Parameter,
803 E_Generic_In_Parameter,
809 -- Ensure that the item fulfils its role as input and/or
810 -- output as specified by pragma Global or the enclosing
813 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
815 -- Detect multiple uses of the same state, variable or
816 -- formal parameter. If this is not the case, add the
817 -- item to the list of processed relations.
819 if Contains (Seen, Item_Id) then
821 ("duplicate use of item &", Item, Item_Id);
823 Add_Item (Item_Id, Seen);
826 -- Detect illegal use of an input related to a null
827 -- output. Such input items cannot appear in other
828 -- input lists (SPARK RM 6.1.5(13)).
831 and then Null_Output_Seen
832 and then Contains (All_Inputs_Seen, Item_Id)
835 ("input of a null output list cannot appear in "
836 & "multiple input lists", Item);
839 -- Add an input or a self-referential output to the list
840 -- of all processed inputs.
842 if Is_Input or else Self_Ref then
843 Add_Item (Item_Id, All_Inputs_Seen);
846 -- State related checks (SPARK RM 6.1.5(3))
848 if Ekind (Item_Id) = E_Abstract_State then
850 -- Package and subprogram bodies are instantiated
851 -- individually in a separate compiler pass. Due to
852 -- this mode of instantiation, the refinement of a
853 -- state may no longer be visible when a subprogram
854 -- body contract is instantiated. Since the generic
855 -- template is legal, do not perform this check in
856 -- the instance to circumvent this oddity.
858 if Is_Generic_Instance (Spec_Id) then
861 -- An abstract state with visible refinement cannot
862 -- appear in pragma [Refined_]Depends as its place
863 -- must be taken by some of its constituents
864 -- (SPARK RM 6.1.4(7)).
866 elsif Has_Visible_Refinement (Item_Id) then
868 ("cannot mention state & in dependence relation",
870 SPARK_Msg_N ("\use its constituents instead", Item);
873 -- If the reference to the abstract state appears in
874 -- an enclosing package body that will eventually
875 -- refine the state, record the reference for future
879 Record_Possible_Body_Reference
880 (State_Id => Item_Id,
885 -- When the item renames an entire object, replace the
886 -- item with a reference to the object.
888 if Entity (Item) /= Item_Id then
890 New_Occurrence_Of (Item_Id, Sloc (Item)));
894 -- Add the entity of the current item to the list of
897 if Ekind (Item_Id) = E_Abstract_State then
898 Add_Item (Item_Id, States_Seen);
901 if Ekind_In (Item_Id, E_Abstract_State,
904 and then Present (Encapsulating_State (Item_Id))
906 Add_Item (Item_Id, Constits_Seen);
909 -- All other input/output items are illegal
910 -- (SPARK RM 6.1.5(1)).
914 ("item must denote parameter, variable, or state",
918 -- All other input/output items are illegal
919 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
923 ("item must denote parameter, variable, or state", Item);
926 end Analyze_Input_Output;
934 Non_Null_Output_Seen : Boolean := False;
935 -- Flag used to check the legality of an output list
937 -- Start of processing for Analyze_Dependency_Clause
940 Inputs := Expression (Clause);
943 -- An input list with a self-dependency appears as operator "+" where
944 -- the actuals inputs are the right operand.
946 if Nkind (Inputs) = N_Op_Plus then
947 Inputs := Right_Opnd (Inputs);
951 -- Process the output_list of a dependency_clause
953 Output := First (Choices (Clause));
954 while Present (Output) loop
958 Self_Ref => Self_Ref,
960 Seen => All_Outputs_Seen,
961 Null_Seen => Null_Output_Seen,
962 Non_Null_Seen => Non_Null_Output_Seen);
967 -- Process the input_list of a dependency_clause
969 Analyze_Input_List (Inputs);
970 end Analyze_Dependency_Clause;
972 ---------------------------
973 -- Check_Function_Return --
974 ---------------------------
976 procedure Check_Function_Return is
978 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
979 and then not Result_Seen
982 ("result of & must appear in exactly one output list",
985 end Check_Function_Return;
998 (Item_Is_Input : out Boolean;
999 Item_Is_Output : out Boolean);
1000 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1001 -- Item_Is_Output are set depending on the role.
1003 procedure Role_Error
1004 (Item_Is_Input : Boolean;
1005 Item_Is_Output : Boolean);
1006 -- Emit an error message concerning the incorrect use of Item in
1007 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1008 -- denote whether the item is an input and/or an output.
1015 (Item_Is_Input : out Boolean;
1016 Item_Is_Output : out Boolean)
1019 Item_Is_Input := False;
1020 Item_Is_Output := False;
1022 -- Abstract state cases
1024 if Ekind (Item_Id) = E_Abstract_State then
1026 -- When pragma Global is present, the mode of the state may be
1027 -- further constrained by setting a more restrictive mode.
1030 if Appears_In (Subp_Inputs, Item_Id) then
1031 Item_Is_Input := True;
1034 if Appears_In (Subp_Outputs, Item_Id) then
1035 Item_Is_Output := True;
1038 -- Otherwise the state has a default IN OUT mode
1041 Item_Is_Input := True;
1042 Item_Is_Output := True;
1047 elsif Ekind (Item_Id) = E_Constant then
1048 Item_Is_Input := True;
1050 -- Generic parameter cases
1052 elsif Ekind (Item_Id) = E_Generic_In_Parameter then
1053 Item_Is_Input := True;
1055 elsif Ekind (Item_Id) = E_Generic_In_Out_Parameter then
1056 Item_Is_Input := True;
1057 Item_Is_Output := True;
1061 elsif Ekind (Item_Id) = E_In_Parameter then
1062 Item_Is_Input := True;
1064 elsif Ekind (Item_Id) = E_In_Out_Parameter then
1065 Item_Is_Input := True;
1066 Item_Is_Output := True;
1068 elsif Ekind (Item_Id) = E_Out_Parameter then
1069 if Scope (Item_Id) = Spec_Id then
1071 -- An OUT parameter of the related subprogram has mode IN
1072 -- if its type is unconstrained or tagged because array
1073 -- bounds, discriminants or tags can be read.
1075 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1076 Item_Is_Input := True;
1079 Item_Is_Output := True;
1081 -- An OUT parameter of an enclosing subprogram behaves as a
1082 -- read-write variable in which case the mode is IN OUT.
1085 Item_Is_Input := True;
1086 Item_Is_Output := True;
1091 else pragma Assert (Ekind (Item_Id) = E_Variable);
1093 -- When pragma Global is present, the mode of the variable may
1094 -- be further constrained by setting a more restrictive mode.
1098 -- A variable has mode IN when its type is unconstrained or
1099 -- tagged because array bounds, discriminants or tags can be
1102 if Appears_In (Subp_Inputs, Item_Id)
1103 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1105 Item_Is_Input := True;
1108 if Appears_In (Subp_Outputs, Item_Id) then
1109 Item_Is_Output := True;
1112 -- Otherwise the variable has a default IN OUT mode
1115 Item_Is_Input := True;
1116 Item_Is_Output := True;
1125 procedure Role_Error
1126 (Item_Is_Input : Boolean;
1127 Item_Is_Output : Boolean)
1129 Error_Msg : Name_Id;
1134 -- When the item is not part of the input and the output set of
1135 -- the related subprogram, then it appears as extra in pragma
1136 -- [Refined_]Depends.
1138 if not Item_Is_Input and then not Item_Is_Output then
1139 Add_Item_To_Name_Buffer (Item_Id);
1140 Add_Str_To_Name_Buffer
1141 (" & cannot appear in dependence relation");
1143 Error_Msg := Name_Find;
1144 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1146 Error_Msg_Name_1 := Chars (Spec_Id);
1148 ("\& is not part of the input or output set of subprogram %",
1151 -- The mode of the item and its role in pragma [Refined_]Depends
1152 -- are in conflict. Construct a detailed message explaining the
1153 -- illegality (SPARK RM 6.1.5(5-6)).
1156 if Item_Is_Input then
1157 Add_Str_To_Name_Buffer ("read-only");
1159 Add_Str_To_Name_Buffer ("write-only");
1162 Add_Char_To_Name_Buffer (' ');
1163 Add_Item_To_Name_Buffer (Item_Id);
1164 Add_Str_To_Name_Buffer (" & cannot appear as ");
1166 if Item_Is_Input then
1167 Add_Str_To_Name_Buffer ("output");
1169 Add_Str_To_Name_Buffer ("input");
1172 Add_Str_To_Name_Buffer (" in dependence relation");
1173 Error_Msg := Name_Find;
1174 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1180 Item_Is_Input : Boolean;
1181 Item_Is_Output : Boolean;
1183 -- Start of processing for Check_Role
1186 Find_Role (Item_Is_Input, Item_Is_Output);
1191 if not Item_Is_Input then
1192 Role_Error (Item_Is_Input, Item_Is_Output);
1195 -- Self-referential item
1198 if not Item_Is_Input or else not Item_Is_Output then
1199 Role_Error (Item_Is_Input, Item_Is_Output);
1204 elsif not Item_Is_Output then
1205 Role_Error (Item_Is_Input, Item_Is_Output);
1213 procedure Check_Usage
1214 (Subp_Items : Elist_Id;
1215 Used_Items : Elist_Id;
1218 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
1219 -- Emit an error concerning the illegal usage of an item
1225 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1226 Error_Msg : Name_Id;
1233 -- Unconstrained and tagged items are not part of the explicit
1234 -- input set of the related subprogram, they do not have to be
1235 -- present in a dependence relation and should not be flagged
1236 -- (SPARK RM 6.1.5(8)).
1238 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1241 Add_Item_To_Name_Buffer (Item_Id);
1242 Add_Str_To_Name_Buffer
1243 (" & must appear in at least one input dependence list");
1245 Error_Msg := Name_Find;
1246 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1249 -- Output case (SPARK RM 6.1.5(10))
1254 Add_Item_To_Name_Buffer (Item_Id);
1255 Add_Str_To_Name_Buffer
1256 (" & must appear in exactly one output dependence list");
1258 Error_Msg := Name_Find;
1259 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1267 Item_Id : Entity_Id;
1269 -- Start of processing for Check_Usage
1272 if No (Subp_Items) then
1276 -- Each input or output of the subprogram must appear in a dependency
1279 Elmt := First_Elmt (Subp_Items);
1280 while Present (Elmt) loop
1281 Item := Node (Elmt);
1283 if Nkind (Item) = N_Defining_Identifier then
1286 Item_Id := Entity_Of (Item);
1289 -- The item does not appear in a dependency
1291 if Present (Item_Id)
1292 and then not Contains (Used_Items, Item_Id)
1294 if Is_Formal (Item_Id) then
1295 Usage_Error (Item, Item_Id);
1297 -- States and global objects are not used properly only when
1298 -- the subprogram is subject to pragma Global.
1300 elsif Global_Seen then
1301 Usage_Error (Item, Item_Id);
1309 ----------------------
1310 -- Normalize_Clause --
1311 ----------------------
1313 procedure Normalize_Clause (Clause : Node_Id) is
1314 procedure Create_Or_Modify_Clause
1320 Multiple : Boolean);
1321 -- Create a brand new clause to represent the self-reference or
1322 -- modify the input and/or output lists of an existing clause. Output
1323 -- denotes a self-referencial output. Outputs is the output list of a
1324 -- clause. Inputs is the input list of a clause. After denotes the
1325 -- clause after which the new clause is to be inserted. Flag In_Place
1326 -- should be set when normalizing the last output of an output list.
1327 -- Flag Multiple should be set when Output comes from a list with
1330 -----------------------------
1331 -- Create_Or_Modify_Clause --
1332 -----------------------------
1334 procedure Create_Or_Modify_Clause
1342 procedure Propagate_Output
1345 -- Handle the various cases of output propagation to the input
1346 -- list. Output denotes a self-referencial output item. Inputs
1347 -- is the input list of a clause.
1349 ----------------------
1350 -- Propagate_Output --
1351 ----------------------
1353 procedure Propagate_Output
1357 function In_Input_List
1359 Inputs : List_Id) return Boolean;
1360 -- Determine whether a particulat item appears in the input
1361 -- list of a clause.
1367 function In_Input_List
1369 Inputs : List_Id) return Boolean
1374 Elmt := First (Inputs);
1375 while Present (Elmt) loop
1376 if Entity_Of (Elmt) = Item then
1388 Output_Id : constant Entity_Id := Entity_Of (Output);
1391 -- Start of processing for Propagate_Output
1394 -- The clause is of the form:
1396 -- (Output =>+ null)
1398 -- Remove null input and replace it with a copy of the output:
1400 -- (Output => Output)
1402 if Nkind (Inputs) = N_Null then
1403 Rewrite (Inputs, New_Copy_Tree (Output));
1405 -- The clause is of the form:
1407 -- (Output =>+ (Input1, ..., InputN))
1409 -- Determine whether the output is not already mentioned in the
1410 -- input list and if not, add it to the list of inputs:
1412 -- (Output => (Output, Input1, ..., InputN))
1414 elsif Nkind (Inputs) = N_Aggregate then
1415 Grouped := Expressions (Inputs);
1417 if not In_Input_List
1421 Prepend_To (Grouped, New_Copy_Tree (Output));
1424 -- The clause is of the form:
1426 -- (Output =>+ Input)
1428 -- If the input does not mention the output, group the two
1431 -- (Output => (Output, Input))
1433 elsif Entity_Of (Inputs) /= Output_Id then
1435 Make_Aggregate (Loc,
1436 Expressions => New_List (
1437 New_Copy_Tree (Output),
1438 New_Copy_Tree (Inputs))));
1440 end Propagate_Output;
1444 Loc : constant Source_Ptr := Sloc (Clause);
1445 New_Clause : Node_Id;
1447 -- Start of processing for Create_Or_Modify_Clause
1450 -- A null output depending on itself does not require any
1453 if Nkind (Output) = N_Null then
1456 -- A function result cannot depend on itself because it cannot
1457 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1459 elsif Is_Attribute_Result (Output) then
1460 SPARK_Msg_N ("function result cannot depend on itself", Output);
1464 -- When performing the transformation in place, simply add the
1465 -- output to the list of inputs (if not already there). This
1466 -- case arises when dealing with the last output of an output
1467 -- list. Perform the normalization in place to avoid generating
1468 -- a malformed tree.
1471 Propagate_Output (Output, Inputs);
1473 -- A list with multiple outputs is slowly trimmed until only
1474 -- one element remains. When this happens, replace aggregate
1475 -- with the element itself.
1479 Rewrite (Outputs, Output);
1485 -- Unchain the output from its output list as it will appear in
1486 -- a new clause. Note that we cannot simply rewrite the output
1487 -- as null because this will violate the semantics of pragma
1492 -- Generate a new clause of the form:
1493 -- (Output => Inputs)
1496 Make_Component_Association (Loc,
1497 Choices => New_List (Output),
1498 Expression => New_Copy_Tree (Inputs));
1500 -- The new clause contains replicated content that has already
1501 -- been analyzed. There is not need to reanalyze or renormalize
1504 Set_Analyzed (New_Clause);
1507 (Output => First (Choices (New_Clause)),
1508 Inputs => Expression (New_Clause));
1510 Insert_After (After, New_Clause);
1512 end Create_Or_Modify_Clause;
1516 Outputs : constant Node_Id := First (Choices (Clause));
1518 Last_Output : Node_Id;
1519 Next_Output : Node_Id;
1522 -- Start of processing for Normalize_Clause
1525 -- A self-dependency appears as operator "+". Remove the "+" from the
1526 -- tree by moving the real inputs to their proper place.
1528 if Nkind (Expression (Clause)) = N_Op_Plus then
1529 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1530 Inputs := Expression (Clause);
1532 -- Multiple outputs appear as an aggregate
1534 if Nkind (Outputs) = N_Aggregate then
1535 Last_Output := Last (Expressions (Outputs));
1537 Output := First (Expressions (Outputs));
1538 while Present (Output) loop
1540 -- Normalization may remove an output from its list,
1541 -- preserve the subsequent output now.
1543 Next_Output := Next (Output);
1545 Create_Or_Modify_Clause
1550 In_Place => Output = Last_Output,
1553 Output := Next_Output;
1559 Create_Or_Modify_Clause
1568 end Normalize_Clause;
1572 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1573 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1577 Last_Clause : Node_Id;
1578 Restore_Scope : Boolean := False;
1580 -- Start of processing for Analyze_Depends_In_Decl_Part
1585 -- Empty dependency list
1587 if Nkind (Deps) = N_Null then
1589 -- Gather all states, objects and formal parameters that the
1590 -- subprogram may depend on. These items are obtained from the
1591 -- parameter profile or pragma [Refined_]Global (if available).
1593 Collect_Subprogram_Inputs_Outputs
1594 (Subp_Id => Subp_Id,
1595 Subp_Inputs => Subp_Inputs,
1596 Subp_Outputs => Subp_Outputs,
1597 Global_Seen => Global_Seen);
1599 -- Verify that every input or output of the subprogram appear in a
1602 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1603 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1604 Check_Function_Return;
1606 -- Dependency clauses appear as component associations of an aggregate
1608 elsif Nkind (Deps) = N_Aggregate then
1610 -- Do not attempt to perform analysis of a syntactically illegal
1611 -- clause as this will lead to misleading errors.
1613 if Has_Extra_Parentheses (Deps) then
1617 if Present (Component_Associations (Deps)) then
1618 Last_Clause := Last (Component_Associations (Deps));
1620 -- Gather all states, objects and formal parameters that the
1621 -- subprogram may depend on. These items are obtained from the
1622 -- parameter profile or pragma [Refined_]Global (if available).
1624 Collect_Subprogram_Inputs_Outputs
1625 (Subp_Id => Subp_Id,
1626 Subp_Inputs => Subp_Inputs,
1627 Subp_Outputs => Subp_Outputs,
1628 Global_Seen => Global_Seen);
1630 -- Ensure that the formal parameters are visible when analyzing
1631 -- all clauses. This falls out of the general rule of aspects
1632 -- pertaining to subprogram declarations.
1634 if not In_Open_Scopes (Spec_Id) then
1635 Restore_Scope := True;
1636 Push_Scope (Spec_Id);
1638 if Is_Generic_Subprogram (Spec_Id) then
1639 Install_Generic_Formals (Spec_Id);
1641 Install_Formals (Spec_Id);
1645 Clause := First (Component_Associations (Deps));
1646 while Present (Clause) loop
1647 Errors := Serious_Errors_Detected;
1649 -- The normalization mechanism may create extra clauses that
1650 -- contain replicated input and output names. There is no need
1651 -- to reanalyze them.
1653 if not Analyzed (Clause) then
1654 Set_Analyzed (Clause);
1656 Analyze_Dependency_Clause
1658 Is_Last => Clause = Last_Clause);
1661 -- Do not normalize a clause if errors were detected (count
1662 -- of Serious_Errors has increased) because the inputs and/or
1663 -- outputs may denote illegal items. Normalization is disabled
1664 -- in ASIS mode as it alters the tree by introducing new nodes
1665 -- similar to expansion.
1667 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1668 Normalize_Clause (Clause);
1674 if Restore_Scope then
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 -- The dependency list is malformed. This is a syntax error, always
1689 Error_Msg_N ("malformed dependency relation", Deps);
1693 -- The top level dependency relation is malformed. This is a syntax
1694 -- error, always report.
1697 Error_Msg_N ("malformed dependency relation", Deps);
1701 -- Ensure that a state and a corresponding constituent do not appear
1702 -- together in pragma [Refined_]Depends.
1704 Check_State_And_Constituent_Use
1705 (States => States_Seen,
1706 Constits => Constits_Seen,
1708 end Analyze_Depends_In_Decl_Part;
1710 --------------------------------------------
1711 -- Analyze_External_Property_In_Decl_Part --
1712 --------------------------------------------
1714 procedure Analyze_External_Property_In_Decl_Part
1716 Expr_Val : out Boolean)
1718 GM : constant Ghost_Mode_Type := Ghost_Mode;
1719 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1720 Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
1721 Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1));
1724 -- Set the Ghost mode in effect from the pragma. Due to the delayed
1725 -- analysis of the pragma, the Ghost mode at point of declaration and
1726 -- point of analysis may not necessarely be the same. Use the mode in
1727 -- effect at the point of declaration.
1730 Error_Msg_Name_1 := Pragma_Name (N);
1732 -- An external property pragma must apply to an effectively volatile
1733 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1734 -- The check is performed at the end of the declarative region due to a
1735 -- possible out-of-order arrangement of pragmas:
1738 -- pragma Async_Readers (Obj);
1739 -- pragma Volatile (Obj);
1741 if not Is_Effectively_Volatile (Obj_Id) then
1743 ("external property % must apply to a volatile object", N);
1746 -- Ensure that the Boolean expression (if present) is static. A missing
1747 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1751 if Present (Expr) then
1752 Analyze_And_Resolve (Expr, Standard_Boolean);
1754 if Is_OK_Static_Expression (Expr) then
1755 Expr_Val := Is_True (Expr_Value (Expr));
1757 SPARK_Msg_N ("expression of % must be static", Expr);
1761 -- Restore the original Ghost mode once analysis and expansion have
1765 end Analyze_External_Property_In_Decl_Part;
1767 ---------------------------------
1768 -- Analyze_Global_In_Decl_Part --
1769 ---------------------------------
1771 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1772 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
1773 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
1774 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1776 Constits_Seen : Elist_Id := No_Elist;
1777 -- A list containing the entities of all constituents processed so far.
1778 -- It aids in detecting illegal usage of a state and a corresponding
1779 -- constituent in pragma [Refinde_]Global.
1781 Seen : Elist_Id := No_Elist;
1782 -- A list containing the entities of all the items processed so far. It
1783 -- plays a role in detecting distinct entities.
1785 States_Seen : Elist_Id := No_Elist;
1786 -- A list containing the entities of all states processed so far. It
1787 -- helps in detecting illegal usage of a state and a corresponding
1788 -- constituent in pragma [Refined_]Global.
1790 In_Out_Seen : Boolean := False;
1791 Input_Seen : Boolean := False;
1792 Output_Seen : Boolean := False;
1793 Proof_Seen : Boolean := False;
1794 -- Flags used to verify the consistency of modes
1796 procedure Analyze_Global_List
1798 Global_Mode : Name_Id := Name_Input);
1799 -- Verify the legality of a single global list declaration. Global_Mode
1800 -- denotes the current mode in effect.
1802 -------------------------
1803 -- Analyze_Global_List --
1804 -------------------------
1806 procedure Analyze_Global_List
1808 Global_Mode : Name_Id := Name_Input)
1810 procedure Analyze_Global_Item
1812 Global_Mode : Name_Id);
1813 -- Verify the legality of a single global item declaration denoted by
1814 -- Item. Global_Mode denotes the current mode in effect.
1816 procedure Check_Duplicate_Mode
1818 Status : in out Boolean);
1819 -- Flag Status denotes whether a particular mode has been seen while
1820 -- processing a global list. This routine verifies that Mode is not a
1821 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1823 procedure Check_Mode_Restriction_In_Enclosing_Context
1825 Item_Id : Entity_Id);
1826 -- Verify that an item of mode In_Out or Output does not appear as an
1827 -- input in the Global aspect of an enclosing subprogram. If this is
1828 -- the case, emit an error. Item and Item_Id are respectively the
1829 -- item and its entity.
1831 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1832 -- Mode denotes either In_Out or Output. Depending on the kind of the
1833 -- related subprogram, emit an error if those two modes apply to a
1834 -- function (SPARK RM 6.1.4(10)).
1836 -------------------------
1837 -- Analyze_Global_Item --
1838 -------------------------
1840 procedure Analyze_Global_Item
1842 Global_Mode : Name_Id)
1844 Item_Id : Entity_Id;
1847 -- Detect one of the following cases
1849 -- with Global => (null, Name)
1850 -- with Global => (Name_1, null, Name_2)
1851 -- with Global => (Name, null)
1853 if Nkind (Item) = N_Null then
1854 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
1859 Resolve_State (Item);
1861 -- Find the entity of the item. If this is a renaming, climb the
1862 -- renaming chain to reach the root object. Renamings of non-
1863 -- entire objects do not yield an entity (Empty).
1865 Item_Id := Entity_Of (Item);
1867 if Present (Item_Id) then
1869 -- A global item may denote a formal parameter of an enclosing
1870 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1871 -- provide a better error diagnostic.
1873 if Is_Formal (Item_Id) then
1874 if Scope (Item_Id) = Spec_Id then
1876 ("global item cannot reference parameter of "
1877 & "subprogram &", Item, Spec_Id);
1881 -- A formal object may act as a global item inside a generic
1883 elsif Is_Formal_Object (Item_Id) then
1886 -- The only legal references are those to abstract states and
1887 -- objects (SPARK RM 6.1.4(4)).
1889 elsif not Ekind_In (Item_Id, E_Abstract_State,
1894 ("global item must denote object or state", Item);
1898 -- State related checks
1900 if Ekind (Item_Id) = E_Abstract_State then
1902 -- Package and subprogram bodies are instantiated
1903 -- individually in a separate compiler pass. Due to this
1904 -- mode of instantiation, the refinement of a state may
1905 -- no longer be visible when a subprogram body contract
1906 -- is instantiated. Since the generic template is legal,
1907 -- do not perform this check in the instance to circumvent
1910 if Is_Generic_Instance (Spec_Id) then
1913 -- An abstract state with visible refinement cannot appear
1914 -- in pragma [Refined_]Global as its place must be taken by
1915 -- some of its constituents (SPARK RM 6.1.4(7)).
1917 elsif Has_Visible_Refinement (Item_Id) then
1919 ("cannot mention state & in global refinement",
1921 SPARK_Msg_N ("\use its constituents instead", Item);
1924 -- If the reference to the abstract state appears in an
1925 -- enclosing package body that will eventually refine the
1926 -- state, record the reference for future checks.
1929 Record_Possible_Body_Reference
1930 (State_Id => Item_Id,
1934 -- Constant related checks
1936 elsif Ekind (Item_Id) = E_Constant then
1938 -- A constant is read-only item, therefore it cannot act as
1941 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1943 ("constant & cannot act as output", Item, Item_Id);
1947 -- Variable related checks. These are only relevant when
1948 -- SPARK_Mode is on as they are not standard Ada legality
1951 elsif SPARK_Mode = On
1952 and then Ekind (Item_Id) = E_Variable
1953 and then Is_Effectively_Volatile (Item_Id)
1955 -- An effectively volatile object cannot appear as a global
1956 -- item of a function (SPARK RM 7.1.3(9)).
1958 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
1960 ("volatile object & cannot act as global item of a "
1961 & "function", Item, Item_Id);
1964 -- An effectively volatile object with external property
1965 -- Effective_Reads set to True must have mode Output or
1966 -- In_Out (SPARK RM 7.1.3(11)).
1968 elsif Effective_Reads_Enabled (Item_Id)
1969 and then Global_Mode = Name_Input
1972 ("volatile object & with property Effective_Reads must "
1973 & "have mode In_Out or Output", Item, Item_Id);
1978 -- When the item renames an entire object, replace the item
1979 -- with a reference to the object.
1981 if Entity (Item) /= Item_Id then
1982 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
1986 -- Some form of illegal construct masquerading as a name
1987 -- (SPARK RM 6.1.4(4)).
1990 Error_Msg_N ("global item must denote object or state", Item);
1994 -- Verify that an output does not appear as an input in an
1995 -- enclosing subprogram.
1997 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1998 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2001 -- The same entity might be referenced through various way.
2002 -- Check the entity of the item rather than the item itself
2003 -- (SPARK RM 6.1.4(10)).
2005 if Contains (Seen, Item_Id) then
2006 SPARK_Msg_N ("duplicate global item", Item);
2008 -- Add the entity of the current item to the list of processed
2012 Add_Item (Item_Id, Seen);
2014 if Ekind (Item_Id) = E_Abstract_State then
2015 Add_Item (Item_Id, States_Seen);
2018 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2019 and then Present (Encapsulating_State (Item_Id))
2021 Add_Item (Item_Id, Constits_Seen);
2024 end Analyze_Global_Item;
2026 --------------------------
2027 -- Check_Duplicate_Mode --
2028 --------------------------
2030 procedure Check_Duplicate_Mode
2032 Status : in out Boolean)
2036 SPARK_Msg_N ("duplicate global mode", Mode);
2040 end Check_Duplicate_Mode;
2042 -------------------------------------------------
2043 -- Check_Mode_Restriction_In_Enclosing_Context --
2044 -------------------------------------------------
2046 procedure Check_Mode_Restriction_In_Enclosing_Context
2048 Item_Id : Entity_Id)
2050 Context : Entity_Id;
2052 Inputs : Elist_Id := No_Elist;
2053 Outputs : Elist_Id := No_Elist;
2056 -- Traverse the scope stack looking for enclosing subprograms
2057 -- subject to pragma [Refined_]Global.
2059 Context := Scope (Subp_Id);
2060 while Present (Context) and then Context /= Standard_Standard loop
2061 if Is_Subprogram (Context)
2063 (Present (Get_Pragma (Context, Pragma_Global))
2065 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2067 Collect_Subprogram_Inputs_Outputs
2068 (Subp_Id => Context,
2069 Subp_Inputs => Inputs,
2070 Subp_Outputs => Outputs,
2071 Global_Seen => Dummy);
2073 -- The item is classified as In_Out or Output but appears as
2074 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2076 if Appears_In (Inputs, Item_Id)
2077 and then not Appears_In (Outputs, Item_Id)
2080 ("global item & cannot have mode In_Out or Output",
2083 ("\item already appears as input of subprogram &",
2086 -- Stop the traversal once an error has been detected
2092 Context := Scope (Context);
2094 end Check_Mode_Restriction_In_Enclosing_Context;
2096 ----------------------------------------
2097 -- Check_Mode_Restriction_In_Function --
2098 ----------------------------------------
2100 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2102 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2104 ("global mode & is not applicable to functions", Mode);
2106 end Check_Mode_Restriction_In_Function;
2114 -- Start of processing for Analyze_Global_List
2117 if Nkind (List) = N_Null then
2118 Set_Analyzed (List);
2120 -- Single global item declaration
2122 elsif Nkind_In (List, N_Expanded_Name,
2124 N_Selected_Component)
2126 Analyze_Global_Item (List, Global_Mode);
2128 -- Simple global list or moded global list declaration
2130 elsif Nkind (List) = N_Aggregate then
2131 Set_Analyzed (List);
2133 -- The declaration of a simple global list appear as a collection
2136 if Present (Expressions (List)) then
2137 if Present (Component_Associations (List)) then
2139 ("cannot mix moded and non-moded global lists", List);
2142 Item := First (Expressions (List));
2143 while Present (Item) loop
2144 Analyze_Global_Item (Item, Global_Mode);
2148 -- The declaration of a moded global list appears as a collection
2149 -- of component associations where individual choices denote
2152 elsif Present (Component_Associations (List)) then
2153 if Present (Expressions (List)) then
2155 ("cannot mix moded and non-moded global lists", List);
2158 Assoc := First (Component_Associations (List));
2159 while Present (Assoc) loop
2160 Mode := First (Choices (Assoc));
2162 if Nkind (Mode) = N_Identifier then
2163 if Chars (Mode) = Name_In_Out then
2164 Check_Duplicate_Mode (Mode, In_Out_Seen);
2165 Check_Mode_Restriction_In_Function (Mode);
2167 elsif Chars (Mode) = Name_Input then
2168 Check_Duplicate_Mode (Mode, Input_Seen);
2170 elsif Chars (Mode) = Name_Output then
2171 Check_Duplicate_Mode (Mode, Output_Seen);
2172 Check_Mode_Restriction_In_Function (Mode);
2174 elsif Chars (Mode) = Name_Proof_In then
2175 Check_Duplicate_Mode (Mode, Proof_Seen);
2178 SPARK_Msg_N ("invalid mode selector", Mode);
2182 SPARK_Msg_N ("invalid mode selector", Mode);
2185 -- Items in a moded list appear as a collection of
2186 -- expressions. Reuse the existing machinery to analyze
2190 (List => Expression (Assoc),
2191 Global_Mode => Chars (Mode));
2199 raise Program_Error;
2202 -- Any other attempt to declare a global item is illegal. This is a
2203 -- syntax error, always report.
2206 Error_Msg_N ("malformed global list", List);
2208 end Analyze_Global_List;
2212 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2214 Restore_Scope : Boolean := False;
2216 -- Start of processing for Analyze_Global_In_Decl_Part
2221 -- There is nothing to be done for a null global list
2223 if Nkind (Items) = N_Null then
2224 Set_Analyzed (Items);
2226 -- Analyze the various forms of global lists and items. Note that some
2227 -- of these may be malformed in which case the analysis emits error
2231 -- Ensure that the formal parameters are visible when processing an
2232 -- item. This falls out of the general rule of aspects pertaining to
2233 -- subprogram declarations.
2235 if not In_Open_Scopes (Spec_Id) then
2236 Restore_Scope := True;
2237 Push_Scope (Spec_Id);
2239 if Is_Generic_Subprogram (Spec_Id) then
2240 Install_Generic_Formals (Spec_Id);
2242 Install_Formals (Spec_Id);
2246 Analyze_Global_List (Items);
2248 if Restore_Scope then
2253 -- Ensure that a state and a corresponding constituent do not appear
2254 -- together in pragma [Refined_]Global.
2256 Check_State_And_Constituent_Use
2257 (States => States_Seen,
2258 Constits => Constits_Seen,
2260 end Analyze_Global_In_Decl_Part;
2262 --------------------------------------------
2263 -- Analyze_Initial_Condition_In_Decl_Part --
2264 --------------------------------------------
2266 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2267 GM : constant Ghost_Mode_Type := Ghost_Mode;
2268 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2269 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2270 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2273 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2274 -- analysis of the pragma, the Ghost mode at point of declaration and
2275 -- point of analysis may not necessarely be the same. Use the mode in
2276 -- effect at the point of declaration.
2281 -- The expression is preanalyzed because it has not been moved to its
2282 -- final place yet. A direct analysis may generate side effects and this
2283 -- is not desired at this point.
2285 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2287 -- Restore the original Ghost mode once analysis and expansion have
2291 end Analyze_Initial_Condition_In_Decl_Part;
2293 --------------------------------------
2294 -- Analyze_Initializes_In_Decl_Part --
2295 --------------------------------------
2297 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2298 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2299 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2301 Constits_Seen : Elist_Id := No_Elist;
2302 -- A list containing the entities of all constituents processed so far.
2303 -- It aids in detecting illegal usage of a state and a corresponding
2304 -- constituent in pragma Initializes.
2306 Items_Seen : Elist_Id := No_Elist;
2307 -- A list of all initialization items processed so far. This list is
2308 -- used to detect duplicate items.
2310 Non_Null_Seen : Boolean := False;
2311 Null_Seen : Boolean := False;
2312 -- Flags used to check the legality of a null initialization list
2314 States_And_Objs : Elist_Id := No_Elist;
2315 -- A list of all abstract states and objects declared in the visible
2316 -- declarations of the related package. This list is used to detect the
2317 -- legality of initialization items.
2319 States_Seen : Elist_Id := No_Elist;
2320 -- A list containing the entities of all states processed so far. It
2321 -- helps in detecting illegal usage of a state and a corresponding
2322 -- constituent in pragma Initializes.
2324 procedure Analyze_Initialization_Item (Item : Node_Id);
2325 -- Verify the legality of a single initialization item
2327 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2328 -- Verify the legality of a single initialization item followed by a
2329 -- list of input items.
2331 procedure Collect_States_And_Objects;
2332 -- Inspect the visible declarations of the related package and gather
2333 -- the entities of all abstract states and objects in States_And_Objs.
2335 ---------------------------------
2336 -- Analyze_Initialization_Item --
2337 ---------------------------------
2339 procedure Analyze_Initialization_Item (Item : Node_Id) is
2340 Item_Id : Entity_Id;
2343 -- Null initialization list
2345 if Nkind (Item) = N_Null then
2347 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2349 elsif Non_Null_Seen then
2351 ("cannot mix null and non-null initialization items", Item);
2356 -- Initialization item
2359 Non_Null_Seen := True;
2363 ("cannot mix null and non-null initialization items", Item);
2367 Resolve_State (Item);
2369 if Is_Entity_Name (Item) then
2370 Item_Id := Entity_Of (Item);
2372 if Ekind_In (Item_Id, E_Abstract_State,
2376 -- The state or variable must be declared in the visible
2377 -- declarations of the package (SPARK RM 7.1.5(7)).
2379 if not Contains (States_And_Objs, Item_Id) then
2380 Error_Msg_Name_1 := Chars (Pack_Id);
2382 ("initialization item & must appear in the visible "
2383 & "declarations of package %", Item, Item_Id);
2385 -- Detect a duplicate use of the same initialization item
2386 -- (SPARK RM 7.1.5(5)).
2388 elsif Contains (Items_Seen, Item_Id) then
2389 SPARK_Msg_N ("duplicate initialization item", Item);
2391 -- The item is legal, add it to the list of processed states
2395 Add_Item (Item_Id, Items_Seen);
2397 if Ekind (Item_Id) = E_Abstract_State then
2398 Add_Item (Item_Id, States_Seen);
2401 if Present (Encapsulating_State (Item_Id)) then
2402 Add_Item (Item_Id, Constits_Seen);
2406 -- The item references something that is not a state or object
2407 -- (SPARK RM 7.1.5(3)).
2411 ("initialization item must denote object or state", Item);
2414 -- Some form of illegal construct masquerading as a name
2415 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2419 ("initialization item must denote object or state", Item);
2422 end Analyze_Initialization_Item;
2424 ---------------------------------------------
2425 -- Analyze_Initialization_Item_With_Inputs --
2426 ---------------------------------------------
2428 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2429 Inputs_Seen : Elist_Id := No_Elist;
2430 -- A list of all inputs processed so far. This list is used to detect
2431 -- duplicate uses of an input.
2433 Non_Null_Seen : Boolean := False;
2434 Null_Seen : Boolean := False;
2435 -- Flags used to check the legality of an input list
2437 procedure Analyze_Input_Item (Input : Node_Id);
2438 -- Verify the legality of a single input item
2440 ------------------------
2441 -- Analyze_Input_Item --
2442 ------------------------
2444 procedure Analyze_Input_Item (Input : Node_Id) is
2445 Input_Id : Entity_Id;
2450 if Nkind (Input) = N_Null then
2453 ("multiple null initializations not allowed", Item);
2455 elsif Non_Null_Seen then
2457 ("cannot mix null and non-null initialization item", Item);
2465 Non_Null_Seen := True;
2469 ("cannot mix null and non-null initialization item", Item);
2473 Resolve_State (Input);
2475 if Is_Entity_Name (Input) then
2476 Input_Id := Entity_Of (Input);
2478 if Ekind_In (Input_Id, E_Abstract_State,
2485 -- The input cannot denote states or objects declared
2486 -- within the related package (SPARK RM 7.1.5(4)).
2488 if Within_Scope (Input_Id, Current_Scope) then
2489 Error_Msg_Name_1 := Chars (Pack_Id);
2491 ("input item & cannot denote a visible object or "
2492 & "state of package %", Input, Input_Id);
2494 -- Detect a duplicate use of the same input item
2495 -- (SPARK RM 7.1.5(5)).
2497 elsif Contains (Inputs_Seen, Input_Id) then
2498 SPARK_Msg_N ("duplicate input item", Input);
2500 -- Input is legal, add it to the list of processed inputs
2503 Add_Item (Input_Id, Inputs_Seen);
2505 if Ekind (Input_Id) = E_Abstract_State then
2506 Add_Item (Input_Id, States_Seen);
2509 if Ekind_In (Input_Id, E_Abstract_State,
2512 and then Present (Encapsulating_State (Input_Id))
2514 Add_Item (Input_Id, Constits_Seen);
2518 -- The input references something that is not a state or an
2519 -- object (SPARK RM 7.1.5(3)).
2523 ("input item must denote object or state", Input);
2526 -- Some form of illegal construct masquerading as a name
2527 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2531 ("input item must denote object or state", Input);
2534 end Analyze_Input_Item;
2538 Inputs : constant Node_Id := Expression (Item);
2542 Name_Seen : Boolean := False;
2543 -- A flag used to detect multiple item names
2545 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2548 -- Inspect the name of an item with inputs
2550 Elmt := First (Choices (Item));
2551 while Present (Elmt) loop
2553 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2556 Analyze_Initialization_Item (Elmt);
2562 -- Multiple input items appear as an aggregate
2564 if Nkind (Inputs) = N_Aggregate then
2565 if Present (Expressions (Inputs)) then
2566 Input := First (Expressions (Inputs));
2567 while Present (Input) loop
2568 Analyze_Input_Item (Input);
2573 if Present (Component_Associations (Inputs)) then
2575 ("inputs must appear in named association form", Inputs);
2578 -- Single input item
2581 Analyze_Input_Item (Inputs);
2583 end Analyze_Initialization_Item_With_Inputs;
2585 --------------------------------
2586 -- Collect_States_And_Objects --
2587 --------------------------------
2589 procedure Collect_States_And_Objects is
2590 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
2594 -- Collect the abstract states defined in the package (if any)
2596 if Present (Abstract_States (Pack_Id)) then
2597 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
2600 -- Collect all objects the appear in the visible declarations of the
2603 if Present (Visible_Declarations (Pack_Spec)) then
2604 Decl := First (Visible_Declarations (Pack_Spec));
2605 while Present (Decl) loop
2606 if Comes_From_Source (Decl)
2607 and then Nkind (Decl) = N_Object_Declaration
2609 Add_Item (Defining_Entity (Decl), States_And_Objs);
2615 end Collect_States_And_Objects;
2619 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2622 -- Start of processing for Analyze_Initializes_In_Decl_Part
2627 -- Nothing to do when the initialization list is empty
2629 if Nkind (Inits) = N_Null then
2633 -- Single and multiple initialization clauses appear as an aggregate. If
2634 -- this is not the case, then either the parser or the analysis of the
2635 -- pragma failed to produce an aggregate.
2637 pragma Assert (Nkind (Inits) = N_Aggregate);
2639 -- Initialize the various lists used during analysis
2641 Collect_States_And_Objects;
2643 if Present (Expressions (Inits)) then
2644 Init := First (Expressions (Inits));
2645 while Present (Init) loop
2646 Analyze_Initialization_Item (Init);
2651 if Present (Component_Associations (Inits)) then
2652 Init := First (Component_Associations (Inits));
2653 while Present (Init) loop
2654 Analyze_Initialization_Item_With_Inputs (Init);
2659 -- Ensure that a state and a corresponding constituent do not appear
2660 -- together in pragma Initializes.
2662 Check_State_And_Constituent_Use
2663 (States => States_Seen,
2664 Constits => Constits_Seen,
2666 end Analyze_Initializes_In_Decl_Part;
2668 --------------------
2669 -- Analyze_Pragma --
2670 --------------------
2672 procedure Analyze_Pragma (N : Node_Id) is
2673 Loc : constant Source_Ptr := Sloc (N);
2674 Prag_Id : Pragma_Id;
2677 -- Name of the source pragma, or name of the corresponding aspect for
2678 -- pragmas which originate in a source aspect. In the latter case, the
2679 -- name may be different from the pragma name.
2681 Pragma_Exit : exception;
2682 -- This exception is used to exit pragma processing completely. It
2683 -- is used when an error is detected, and no further processing is
2684 -- required. It is also used if an earlier error has left the tree in
2685 -- a state where the pragma should not be processed.
2688 -- Number of pragma argument associations
2694 -- First four pragma arguments (pragma argument association nodes, or
2695 -- Empty if the corresponding argument does not exist).
2697 type Name_List is array (Natural range <>) of Name_Id;
2698 type Args_List is array (Natural range <>) of Node_Id;
2699 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2701 -----------------------
2702 -- Local Subprograms --
2703 -----------------------
2705 procedure Acquire_Warning_Match_String (Arg : Node_Id);
2706 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2707 -- get the given string argument, and place it in Name_Buffer, adding
2708 -- leading and trailing asterisks if they are not already present. The
2709 -- caller has already checked that Arg is a static string expression.
2711 procedure Ada_2005_Pragma;
2712 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2713 -- Ada 95 mode, these are implementation defined pragmas, so should be
2714 -- caught by the No_Implementation_Pragmas restriction.
2716 procedure Ada_2012_Pragma;
2717 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2718 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2719 -- should be caught by the No_Implementation_Pragmas restriction.
2721 procedure Analyze_Depends_Global;
2722 -- Subsidiary to the analysis of pragma Depends and Global
2724 procedure Analyze_Part_Of
2725 (Item_Id : Entity_Id;
2728 Legal : out Boolean);
2729 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2730 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2731 -- an abstract state, object, or package instantiation. State is the
2732 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2733 -- set when the indicator is legal.
2735 procedure Analyze_Pre_Post_Condition;
2736 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
2738 procedure Analyze_Refined_Depends_Global_Post
2739 (Spec_Id : out Entity_Id;
2740 Body_Id : out Entity_Id;
2741 Legal : out Boolean);
2742 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2743 -- Refined_Global and Refined_Post. Check the placement and related
2744 -- context of the pragma. Spec_Id is the entity of the related
2745 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2746 -- Legal is set when the pragma is properly placed.
2748 procedure Check_Ada_83_Warning;
2749 -- Issues a warning message for the current pragma if operating in Ada
2750 -- 83 mode (used for language pragmas that are not a standard part of
2751 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
2754 procedure Check_Arg_Count (Required : Nat);
2755 -- Check argument count for pragma is equal to given parameter. If not,
2756 -- then issue an error message and raise Pragma_Exit.
2758 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2759 -- Arg which can either be a pragma argument association, in which case
2760 -- the check is applied to the expression of the association or an
2761 -- expression directly.
2763 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2764 -- Check that an argument has the right form for an EXTERNAL_NAME
2765 -- parameter of an extended import/export pragma. The rule is that the
2766 -- name must be an identifier or string literal (in Ada 83 mode) or a
2767 -- static string expression (in Ada 95 mode).
2769 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2770 -- Check the specified argument Arg to make sure that it is an
2771 -- identifier. If not give error and raise Pragma_Exit.
2773 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2774 -- Check the specified argument Arg to make sure that it is an integer
2775 -- literal. If not give error and raise Pragma_Exit.
2777 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2778 -- Check the specified argument Arg to make sure that it has the proper
2779 -- syntactic form for a local name and meets the semantic requirements
2780 -- for a local name. The local name is analyzed as part of the
2781 -- processing for this call. In addition, the local name is required
2782 -- to represent an entity at the library level.
2784 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2785 -- Check the specified argument Arg to make sure that it has the proper
2786 -- syntactic form for a local name and meets the semantic requirements
2787 -- for a local name. The local name is analyzed as part of the
2788 -- processing for this call.
2790 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2791 -- Check the specified argument Arg to make sure that it is a valid
2792 -- locking policy name. If not give error and raise Pragma_Exit.
2794 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2795 -- Check the specified argument Arg to make sure that it is a valid
2796 -- elaboration policy name. If not give error and raise Pragma_Exit.
2798 procedure Check_Arg_Is_One_Of
2801 procedure Check_Arg_Is_One_Of
2803 N1, N2, N3 : Name_Id);
2804 procedure Check_Arg_Is_One_Of
2806 N1, N2, N3, N4 : Name_Id);
2807 procedure Check_Arg_Is_One_Of
2809 N1, N2, N3, N4, N5 : Name_Id);
2810 -- Check the specified argument Arg to make sure that it is an
2811 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2812 -- present). If not then give error and raise Pragma_Exit.
2814 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2815 -- Check the specified argument Arg to make sure that it is a valid
2816 -- queuing policy name. If not give error and raise Pragma_Exit.
2818 procedure Check_Arg_Is_OK_Static_Expression
2820 Typ : Entity_Id := Empty);
2821 -- Check the specified argument Arg to make sure that it is a static
2822 -- expression of the given type (i.e. it will be analyzed and resolved
2823 -- using this type, which can be any valid argument to Resolve, e.g.
2824 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2825 -- Typ is left Empty, then any static expression is allowed. Includes
2826 -- checking that the argument does not raise Constraint_Error.
2828 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2829 -- Check the specified argument Arg to make sure that it is a valid task
2830 -- dispatching policy name. If not give error and raise Pragma_Exit.
2832 procedure Check_Arg_Order (Names : Name_List);
2833 -- Checks for an instance of two arguments with identifiers for the
2834 -- current pragma which are not in the sequence indicated by Names,
2835 -- and if so, generates a fatal message about bad order of arguments.
2837 procedure Check_At_Least_N_Arguments (N : Nat);
2838 -- Check there are at least N arguments present
2840 procedure Check_At_Most_N_Arguments (N : Nat);
2841 -- Check there are no more than N arguments present
2843 procedure Check_Component
2846 In_Variant_Part : Boolean := False);
2847 -- Examine an Unchecked_Union component for correct use of per-object
2848 -- constrained subtypes, and for restrictions on finalizable components.
2849 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2850 -- should be set when Comp comes from a record variant.
2852 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id);
2853 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2854 -- Initial_Condition and Initializes. Determine whether pragma First
2855 -- appears before pragma Second. If this is not the case, emit an error.
2857 procedure Check_Duplicate_Pragma (E : Entity_Id);
2858 -- Check if a rep item of the same name as the current pragma is already
2859 -- chained as a rep pragma to the given entity. If so give a message
2860 -- about the duplicate, and then raise Pragma_Exit so does not return.
2861 -- Note that if E is a type, then this routine avoids flagging a pragma
2862 -- which applies to a parent type from which E is derived.
2864 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
2865 -- Nam is an N_String_Literal node containing the external name set by
2866 -- an Import or Export pragma (or extended Import or Export pragma).
2867 -- This procedure checks for possible duplications if this is the export
2868 -- case, and if found, issues an appropriate error message.
2870 procedure Check_Expr_Is_OK_Static_Expression
2872 Typ : Entity_Id := Empty);
2873 -- Check the specified expression Expr to make sure that it is a static
2874 -- expression of the given type (i.e. it will be analyzed and resolved
2875 -- using this type, which can be any valid argument to Resolve, e.g.
2876 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2877 -- Typ is left Empty, then any static expression is allowed. Includes
2878 -- checking that the expression does not raise Constraint_Error.
2880 procedure Check_First_Subtype (Arg : Node_Id);
2881 -- Checks that Arg, whose expression is an entity name, references a
2884 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
2885 -- Checks that the given argument has an identifier, and if so, requires
2886 -- it to match the given identifier name. If there is no identifier, or
2887 -- a non-matching identifier, then an error message is given and
2888 -- Pragma_Exit is raised.
2890 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
2891 -- Checks that the given argument has an identifier, and if so, requires
2892 -- it to match one of the given identifier names. If there is no
2893 -- identifier, or a non-matching identifier, then an error message is
2894 -- given and Pragma_Exit is raised.
2896 procedure Check_In_Main_Program;
2897 -- Common checks for pragmas that appear within a main program
2898 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2900 procedure Check_Interrupt_Or_Attach_Handler;
2901 -- Common processing for first argument of pragma Interrupt_Handler or
2902 -- pragma Attach_Handler.
2904 procedure Check_Loop_Pragma_Placement;
2905 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2906 -- appear immediately within a construct restricted to loops, and that
2907 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2909 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
2910 -- Check that pragma appears in a declarative part, or in a package
2911 -- specification, i.e. that it does not occur in a statement sequence
2914 procedure Check_No_Identifier (Arg : Node_Id);
2915 -- Checks that the given argument does not have an identifier. If
2916 -- an identifier is present, then an error message is issued, and
2917 -- Pragma_Exit is raised.
2919 procedure Check_No_Identifiers;
2920 -- Checks that none of the arguments to the pragma has an identifier.
2921 -- If any argument has an identifier, then an error message is issued,
2922 -- and Pragma_Exit is raised.
2924 procedure Check_No_Link_Name;
2925 -- Checks that no link name is specified
2927 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
2928 -- Checks if the given argument has an identifier, and if so, requires
2929 -- it to match the given identifier name. If there is a non-matching
2930 -- identifier, then an error message is given and Pragma_Exit is raised.
2932 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
2933 -- Checks if the given argument has an identifier, and if so, requires
2934 -- it to match the given identifier name. If there is a non-matching
2935 -- identifier, then an error message is given and Pragma_Exit is raised.
2936 -- In this version of the procedure, the identifier name is given as
2937 -- a string with lower case letters.
2939 procedure Check_Static_Constraint (Constr : Node_Id);
2940 -- Constr is a constraint from an N_Subtype_Indication node from a
2941 -- component constraint in an Unchecked_Union type. This routine checks
2942 -- that the constraint is static as required by the restrictions for
2945 procedure Check_Valid_Configuration_Pragma;
2946 -- Legality checks for placement of a configuration pragma
2948 procedure Check_Valid_Library_Unit_Pragma;
2949 -- Legality checks for library unit pragmas. A special case arises for
2950 -- pragmas in generic instances that come from copies of the original
2951 -- library unit pragmas in the generic templates. In the case of other
2952 -- than library level instantiations these can appear in contexts which
2953 -- would normally be invalid (they only apply to the original template
2954 -- and to library level instantiations), and they are simply ignored,
2955 -- which is implemented by rewriting them as null statements.
2957 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
2958 -- Check an Unchecked_Union variant for lack of nested variants and
2959 -- presence of at least one component. UU_Typ is the related Unchecked_
2962 procedure Ensure_Aggregate_Form (Arg : Node_Id);
2963 -- Subsidiary routine to the processing of pragmas Abstract_State,
2964 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
2965 -- Refined_Global and Refined_State. Transform argument Arg into
2966 -- an aggregate if not one already. N_Null is never transformed.
2967 -- Arg may denote an aspect specification or a pragma argument
2970 procedure Error_Pragma (Msg : String);
2971 pragma No_Return (Error_Pragma);
2972 -- Outputs error message for current pragma. The message contains a %
2973 -- that will be replaced with the pragma name, and the flag is placed
2974 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2975 -- calls Fix_Error (see spec of that procedure for details).
2977 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
2978 pragma No_Return (Error_Pragma_Arg);
2979 -- Outputs error message for current pragma. The message may contain
2980 -- a % that will be replaced with the pragma name. The parameter Arg
2981 -- may either be a pragma argument association, in which case the flag
2982 -- is placed on the expression of this association, or an expression,
2983 -- in which case the flag is placed directly on the expression. The
2984 -- message is placed using Error_Msg_N, so the message may also contain
2985 -- an & insertion character which will reference the given Arg value.
2986 -- After placing the message, Pragma_Exit is raised. Note: this routine
2987 -- calls Fix_Error (see spec of that procedure for details).
2989 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
2990 pragma No_Return (Error_Pragma_Arg);
2991 -- Similar to above form of Error_Pragma_Arg except that two messages
2992 -- are provided, the second is a continuation comment starting with \.
2994 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
2995 pragma No_Return (Error_Pragma_Arg_Ident);
2996 -- Outputs error message for current pragma. The message may contain a %
2997 -- that will be replaced with the pragma name. The parameter Arg must be
2998 -- a pragma argument association with a non-empty identifier (i.e. its
2999 -- Chars field must be set), and the error message is placed on the
3000 -- identifier. The message is placed using Error_Msg_N so the message
3001 -- may also contain an & insertion character which will reference
3002 -- the identifier. After placing the message, Pragma_Exit is raised.
3003 -- Note: this routine calls Fix_Error (see spec of that procedure for
3006 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3007 pragma No_Return (Error_Pragma_Ref);
3008 -- Outputs error message for current pragma. The message may contain
3009 -- a % that will be replaced with the pragma name. The parameter Ref
3010 -- must be an entity whose name can be referenced by & and sloc by #.
3011 -- After placing the message, Pragma_Exit is raised. Note: this routine
3012 -- calls Fix_Error (see spec of that procedure for details).
3014 function Find_Lib_Unit_Name return Entity_Id;
3015 -- Used for a library unit pragma to find the entity to which the
3016 -- library unit pragma applies, returns the entity found.
3018 procedure Find_Program_Unit_Name (Id : Node_Id);
3019 -- If the pragma is a compilation unit pragma, the id must denote the
3020 -- compilation unit in the same compilation, and the pragma must appear
3021 -- in the list of preceding or trailing pragmas. If it is a program
3022 -- unit pragma that is not a compilation unit pragma, then the
3023 -- identifier must be visible.
3025 function Find_Unique_Parameterless_Procedure
3027 Arg : Node_Id) return Entity_Id;
3028 -- Used for a procedure pragma to find the unique parameterless
3029 -- procedure identified by Name, returns it if it exists, otherwise
3030 -- errors out and uses Arg as the pragma argument for the message.
3032 function Fix_Error (Msg : String) return String;
3033 -- This is called prior to issuing an error message. Msg is the normal
3034 -- error message issued in the pragma case. This routine checks for the
3035 -- case of a pragma coming from an aspect in the source, and returns a
3036 -- message suitable for the aspect case as follows:
3038 -- Each substring "pragma" is replaced by "aspect"
3040 -- If "argument of" is at the start of the error message text, it is
3041 -- replaced by "entity for".
3043 -- If "argument" is at the start of the error message text, it is
3044 -- replaced by "entity".
3046 -- So for example, "argument of pragma X must be discrete type"
3047 -- returns "entity for aspect X must be a discrete type".
3049 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3050 -- be different from the pragma name). If the current pragma results
3051 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3052 -- original pragma name.
3054 procedure Gather_Associations
3056 Args : out Args_List);
3057 -- This procedure is used to gather the arguments for a pragma that
3058 -- permits arbitrary ordering of parameters using the normal rules
3059 -- for named and positional parameters. The Names argument is a list
3060 -- of Name_Id values that corresponds to the allowed pragma argument
3061 -- association identifiers in order. The result returned in Args is
3062 -- a list of corresponding expressions that are the pragma arguments.
3063 -- Note that this is a list of expressions, not of pragma argument
3064 -- associations (Gather_Associations has completely checked all the
3065 -- optional identifiers when it returns). An entry in Args is Empty
3066 -- on return if the corresponding argument is not present.
3068 procedure GNAT_Pragma;
3069 -- Called for all GNAT defined pragmas to check the relevant restriction
3070 -- (No_Implementation_Pragmas).
3072 function Is_Before_First_Decl
3073 (Pragma_Node : Node_Id;
3074 Decls : List_Id) return Boolean;
3075 -- Return True if Pragma_Node is before the first declarative item in
3076 -- Decls where Decls is the list of declarative items.
3078 function Is_Configuration_Pragma return Boolean;
3079 -- Determines if the placement of the current pragma is appropriate
3080 -- for a configuration pragma.
3082 function Is_In_Context_Clause return Boolean;
3083 -- Returns True if pragma appears within the context clause of a unit,
3084 -- and False for any other placement (does not generate any messages).
3086 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3087 -- Analyzes the argument, and determines if it is a static string
3088 -- expression, returns True if so, False if non-static or not String.
3089 -- A special case is that a string literal returns True in Ada 83 mode
3090 -- (which has no such thing as static string expressions). Note that
3091 -- the call analyzes its argument, so this cannot be used for the case
3092 -- where an identifier might not be declared.
3094 procedure Pragma_Misplaced;
3095 pragma No_Return (Pragma_Misplaced);
3096 -- Issue fatal error message for misplaced pragma
3098 procedure Process_Atomic_Independent_Shared_Volatile;
3099 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3100 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3101 -- and treated as being identical in effect to pragma Atomic.
3103 procedure Process_Compile_Time_Warning_Or_Error;
3104 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3106 procedure Process_Convention
3107 (C : out Convention_Id;
3108 Ent : out Entity_Id);
3109 -- Common processing for Convention, Interface, Import and Export.
3110 -- Checks first two arguments of pragma, and sets the appropriate
3111 -- convention value in the specified entity or entities. On return
3112 -- C is the convention, Ent is the referenced entity.
3114 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3115 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3116 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3118 procedure Process_Extended_Import_Export_Object_Pragma
3119 (Arg_Internal : Node_Id;
3120 Arg_External : Node_Id;
3121 Arg_Size : Node_Id);
3122 -- Common processing for the pragmas Import/Export_Object. The three
3123 -- arguments correspond to the three named parameters of the pragmas. An
3124 -- argument is empty if the corresponding parameter is not present in
3127 procedure Process_Extended_Import_Export_Internal_Arg
3128 (Arg_Internal : Node_Id := Empty);
3129 -- Common processing for all extended Import and Export pragmas. The
3130 -- argument is the pragma parameter for the Internal argument. If
3131 -- Arg_Internal is empty or inappropriate, an error message is posted.
3132 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3133 -- set to identify the referenced entity.
3135 procedure Process_Extended_Import_Export_Subprogram_Pragma
3136 (Arg_Internal : Node_Id;
3137 Arg_External : Node_Id;
3138 Arg_Parameter_Types : Node_Id;
3139 Arg_Result_Type : Node_Id := Empty;
3140 Arg_Mechanism : Node_Id;
3141 Arg_Result_Mechanism : Node_Id := Empty);
3142 -- Common processing for all extended Import and Export pragmas applying
3143 -- to subprograms. The caller omits any arguments that do not apply to
3144 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3145 -- only in the Import_Function and Export_Function cases). The argument
3146 -- names correspond to the allowed pragma association identifiers.
3148 procedure Process_Generic_List;
3149 -- Common processing for Share_Generic and Inline_Generic
3151 procedure Process_Import_Or_Interface;
3152 -- Common processing for Import or Interface
3154 procedure Process_Import_Predefined_Type;
3155 -- Processing for completing a type with pragma Import. This is used
3156 -- to declare types that match predefined C types, especially for cases
3157 -- without corresponding Ada predefined type.
3159 type Inline_Status is (Suppressed, Disabled, Enabled);
3160 -- Inline status of a subprogram, indicated as follows:
3161 -- Suppressed: inlining is suppressed for the subprogram
3162 -- Disabled: no inlining is requested for the subprogram
3163 -- Enabled: inlining is requested/required for the subprogram
3165 procedure Process_Inline (Status : Inline_Status);
3166 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3167 -- indicates the inline status specified by the pragma.
3169 procedure Process_Interface_Name
3170 (Subprogram_Def : Entity_Id;
3172 Link_Arg : Node_Id);
3173 -- Given the last two arguments of pragma Import, pragma Export, or
3174 -- pragma Interface_Name, performs validity checks and sets the
3175 -- Interface_Name field of the given subprogram entity to the
3176 -- appropriate external or link name, depending on the arguments given.
3177 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3178 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3179 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3180 -- nor Link_Arg is present, the interface name is set to the default
3181 -- from the subprogram name.
3183 procedure Process_Interrupt_Or_Attach_Handler;
3184 -- Common processing for Interrupt and Attach_Handler pragmas
3186 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3187 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3188 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3189 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3190 -- is not set in the Restrictions case.
3192 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3193 -- Common processing for Suppress and Unsuppress. The boolean parameter
3194 -- Suppress_Case is True for the Suppress case, and False for the
3197 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3198 -- Subsidiary to the analysis of pragmas Independent[_Components].
3199 -- Record such a pragma N applied to entity E for future checks.
3201 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3202 -- This procedure sets the Is_Exported flag for the given entity,
3203 -- checking that the entity was not previously imported. Arg is
3204 -- the argument that specified the entity. A check is also made
3205 -- for exporting inappropriate entities.
3207 procedure Set_Extended_Import_Export_External_Name
3208 (Internal_Ent : Entity_Id;
3209 Arg_External : Node_Id);
3210 -- Common processing for all extended import export pragmas. The first
3211 -- argument, Internal_Ent, is the internal entity, which has already
3212 -- been checked for validity by the caller. Arg_External is from the
3213 -- Import or Export pragma, and may be null if no External parameter
3214 -- was present. If Arg_External is present and is a non-null string
3215 -- (a null string is treated as the default), then the Interface_Name
3216 -- field of Internal_Ent is set appropriately.
3218 procedure Set_Imported (E : Entity_Id);
3219 -- This procedure sets the Is_Imported flag for the given entity,
3220 -- checking that it is not previously exported or imported.
3222 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3223 -- Mech is a parameter passing mechanism (see Import_Function syntax
3224 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3225 -- has the right form, and if not issues an error message. If the
3226 -- argument has the right form then the Mechanism field of Ent is
3227 -- set appropriately.
3229 procedure Set_Rational_Profile;
3230 -- Activate the set of configuration pragmas and permissions that make
3231 -- up the Rational profile.
3233 procedure Set_Ravenscar_Profile (N : Node_Id);
3234 -- Activate the set of configuration pragmas and restrictions that make
3235 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3236 -- is used for error messages on any constructs violating the profile.
3238 ----------------------------------
3239 -- Acquire_Warning_Match_String --
3240 ----------------------------------
3242 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3244 String_To_Name_Buffer
3245 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3247 -- Add asterisk at start if not already there
3249 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3250 Name_Buffer (2 .. Name_Len + 1) :=
3251 Name_Buffer (1 .. Name_Len);
3252 Name_Buffer (1) := '*';
3253 Name_Len := Name_Len + 1;
3256 -- Add asterisk at end if not already there
3258 if Name_Buffer (Name_Len) /= '*' then
3259 Name_Len := Name_Len + 1;
3260 Name_Buffer (Name_Len) := '*';
3262 end Acquire_Warning_Match_String;
3264 ---------------------
3265 -- Ada_2005_Pragma --
3266 ---------------------
3268 procedure Ada_2005_Pragma is
3270 if Ada_Version <= Ada_95 then
3271 Check_Restriction (No_Implementation_Pragmas, N);
3273 end Ada_2005_Pragma;
3275 ---------------------
3276 -- Ada_2012_Pragma --
3277 ---------------------
3279 procedure Ada_2012_Pragma is
3281 if Ada_Version <= Ada_2005 then
3282 Check_Restriction (No_Implementation_Pragmas, N);
3284 end Ada_2012_Pragma;
3286 ----------------------------
3287 -- Analyze_Depends_Global --
3288 ----------------------------
3290 procedure Analyze_Depends_Global is
3291 Spec_Id : Entity_Id;
3292 Subp_Decl : Node_Id;
3296 Check_Arg_Count (1);
3298 -- Ensure the proper placement of the pragma. Depends/Global must be
3299 -- associated with a subprogram declaration or a body that acts as a
3302 Subp_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3304 -- Generic subprogram
3306 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
3309 -- Body acts as spec
3311 elsif Nkind (Subp_Decl) = N_Subprogram_Body
3312 and then No (Corresponding_Spec (Subp_Decl))
3316 -- Body stub acts as spec
3318 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3319 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
3323 -- Subprogram declaration
3325 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
3333 Spec_Id := Corresponding_Spec_Of (Subp_Decl);
3335 -- A pragma that applies to a Ghost entity becomes Ghost for the
3336 -- purposes of legality checks and removal of ignored Ghost code.
3338 Mark_Pragma_As_Ghost (N, Spec_Id);
3339 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
3341 -- Fully analyze the pragma when it appears inside a subprogram body
3342 -- because it cannot benefit from forward references.
3344 if Nkind (Subp_Decl) = N_Subprogram_Body then
3345 if Pragma_Name (N) = Name_Depends then
3346 Analyze_Depends_In_Decl_Part (N);
3348 else pragma Assert (Pname = Name_Global);
3349 Analyze_Global_In_Decl_Part (N);
3353 -- Chain the pragma on the contract for further processing by
3354 -- Analyze_Depends_In_Decl_Part/Analyze_Global_In_Decl_Part.
3356 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
3357 end Analyze_Depends_Global;
3359 ---------------------
3360 -- Analyze_Part_Of --
3361 ---------------------
3363 procedure Analyze_Part_Of
3364 (Item_Id : Entity_Id;
3367 Legal : out Boolean)
3369 Pack_Id : Entity_Id;
3370 Placement : State_Space_Kind;
3371 Parent_Unit : Entity_Id;
3372 State_Id : Entity_Id;
3375 -- Assume that the pragma/option is illegal
3379 if Nkind_In (State, N_Expanded_Name,
3381 N_Selected_Component)
3384 Resolve_State (State);
3386 if Is_Entity_Name (State)
3387 and then Ekind (Entity (State)) = E_Abstract_State
3389 State_Id := Entity (State);
3393 ("indicator Part_Of must denote an abstract state", State);
3397 -- This is a syntax error, always report
3401 ("indicator Part_Of must denote an abstract state", State);
3405 -- Determine where the state, object or the package instantiation
3406 -- lives with respect to the enclosing packages or package bodies (if
3407 -- any). This placement dictates the legality of the encapsulating
3410 Find_Placement_In_State_Space
3411 (Item_Id => Item_Id,
3412 Placement => Placement,
3413 Pack_Id => Pack_Id);
3415 -- The item appears in a non-package construct with a declarative
3416 -- part (subprogram, block, etc). As such, the item is not allowed
3417 -- to be a part of an encapsulating state because the item is not
3420 if Placement = Not_In_Package then
3422 ("indicator Part_Of cannot appear in this context "
3423 & "(SPARK RM 7.2.6(5))", Indic);
3424 Error_Msg_Name_1 := Chars (Scope (State_Id));
3426 ("\& is not part of the hidden state of package %",
3429 -- The item appears in the visible state space of some package. In
3430 -- general this scenario does not warrant Part_Of except when the
3431 -- package is a private child unit and the encapsulating state is
3432 -- declared in a parent unit or a public descendant of that parent
3435 elsif Placement = Visible_State_Space then
3436 if Is_Child_Unit (Pack_Id)
3437 and then Is_Private_Descendant (Pack_Id)
3439 -- A variable or state abstraction which is part of the
3440 -- visible state of a private child unit (or one of its public
3441 -- descendants) must have its Part_Of indicator specified. The
3442 -- Part_Of indicator must denote a state abstraction declared
3443 -- by either the parent unit of the private unit or by a public
3444 -- descendant of that parent unit.
3446 -- Find nearest private ancestor (which can be the current unit
3449 Parent_Unit := Pack_Id;
3450 while Present (Parent_Unit) loop
3451 exit when Private_Present
3452 (Parent (Unit_Declaration_Node (Parent_Unit)));
3453 Parent_Unit := Scope (Parent_Unit);
3456 Parent_Unit := Scope (Parent_Unit);
3458 if not Is_Child_Or_Sibling (Pack_Id, Scope (State_Id)) then
3460 ("indicator Part_Of must denote an abstract state of& "
3461 & "or public descendant (SPARK RM 7.2.6(3))",
3462 Indic, Parent_Unit);
3464 elsif Scope (State_Id) = Parent_Unit
3465 or else (Is_Ancestor_Package (Parent_Unit, Scope (State_Id))
3467 not Is_Private_Descendant (Scope (State_Id)))
3473 ("indicator Part_Of must denote an abstract state of& "
3474 & "or public descendant (SPARK RM 7.2.6(3))",
3475 Indic, Parent_Unit);
3478 -- Indicator Part_Of is not needed when the related package is not
3479 -- a private child unit or a public descendant thereof.
3483 ("indicator Part_Of cannot appear in this context "
3484 & "(SPARK RM 7.2.6(5))", Indic);
3485 Error_Msg_Name_1 := Chars (Pack_Id);
3487 ("\& is declared in the visible part of package %",
3491 -- When the item appears in the private state space of a package, the
3492 -- encapsulating state must be declared in the same package.
3494 elsif Placement = Private_State_Space then
3495 if Scope (State_Id) /= Pack_Id then
3497 ("indicator Part_Of must designate an abstract state of "
3498 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3499 Error_Msg_Name_1 := Chars (Pack_Id);
3501 ("\& is declared in the private part of package %",
3505 -- Items declared in the body state space of a package do not need
3506 -- Part_Of indicators as the refinement has already been seen.
3510 ("indicator Part_Of cannot appear in this context "
3511 & "(SPARK RM 7.2.6(5))", Indic);
3513 if Scope (State_Id) = Pack_Id then
3514 Error_Msg_Name_1 := Chars (Pack_Id);
3516 ("\& is declared in the body of package %", Indic, Item_Id);
3521 end Analyze_Part_Of;
3523 --------------------------------
3524 -- Analyze_Pre_Post_Condition --
3525 --------------------------------
3527 procedure Analyze_Pre_Post_Condition is
3528 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
3529 Subp_Decl : Node_Id;
3530 Subp_Id : Entity_Id;
3532 Duplicates_OK : Boolean := False;
3533 -- Flag set when a pre/postcondition allows multiple pragmas of the
3536 In_Body_OK : Boolean := False;
3537 -- Flag set when a pre/postcondition is allowed to appear on a body
3538 -- even though the subprogram may have a spec.
3540 Is_Pre_Post : Boolean := False;
3541 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
3545 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
3546 -- offer uniformity among the various kinds of pre/postconditions by
3547 -- rewriting the pragma identifier. This allows the retrieval of the
3548 -- original pragma name by routine Original_Aspect_Pragma_Name.
3550 if Comes_From_Source (N) then
3551 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
3552 Is_Pre_Post := True;
3553 Set_Class_Present (N, Pname = Name_Pre_Class);
3554 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
3556 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
3557 Is_Pre_Post := True;
3558 Set_Class_Present (N, Pname = Name_Post_Class);
3559 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
3563 -- Determine the semantics with respect to duplicates and placement
3564 -- in a body. Pragmas Precondition and Postcondition were introduced
3565 -- before aspects and are not subject to the same aspect-like rules.
3567 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
3568 Duplicates_OK := True;
3574 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
3575 -- argument without an identifier.
3578 Check_Arg_Count (1);
3579 Check_No_Identifiers;
3581 -- Pragmas Precondition and Postcondition have complex argument
3585 Check_At_Least_N_Arguments (1);
3586 Check_At_Most_N_Arguments (2);
3587 Check_Optional_Identifier (Arg1, Name_Check);
3589 if Present (Arg2) then
3590 Check_Optional_Identifier (Arg2, Name_Message);
3591 Preanalyze_Spec_Expression
3592 (Get_Pragma_Arg (Arg2), Standard_String);
3596 -- For a pragma PPC in the extended main source unit, record enabled
3598 -- ??? nothing checks that the pragma is in the main source unit
3600 if Is_Checked (N) and then not Split_PPC (N) then
3601 Set_SCO_Pragma_Enabled (Loc);
3604 -- Ensure the proper placement of the pragma
3607 Find_Related_Subprogram_Or_Body (N, Do_Checks => not Duplicates_OK);
3609 -- When a pre/postcondition pragma applies to an abstract subprogram,
3610 -- its original form must be an aspect with 'Class.
3612 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
3613 if not From_Aspect_Specification (N) then
3615 ("pragma % cannot be applied to abstract subprogram");
3617 elsif not Class_Present (N) then
3619 ("aspect % requires ''Class for abstract subprogram");
3622 -- Entry declaration
3624 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
3627 -- Generic subprogram declaration
3629 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
3634 elsif Nkind (Subp_Decl) = N_Subprogram_Body
3635 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
3639 -- Subprogram body stub
3641 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3642 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
3646 -- Subprogram declaration
3648 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
3650 -- AI05-0230: When a pre/postcondition pragma applies to a null
3651 -- procedure, its original form must be an aspect with 'Class.
3653 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
3654 and then Null_Present (Specification (Subp_Decl))
3655 and then From_Aspect_Specification (N)
3656 and then not Class_Present (N)
3658 Error_Pragma ("aspect % requires ''Class for null procedure");
3661 -- Otherwise the placement is illegal
3668 Subp_Id := Defining_Entity (Subp_Decl);
3670 -- A pragma that applies to a Ghost entity becomes Ghost for the
3671 -- purposes of legality checks and removal of ignored Ghost code.
3673 Mark_Pragma_As_Ghost (N, Subp_Id);
3675 -- Fully analyze the pragma when it appears inside a subprogram
3676 -- body because it cannot benefit from forward references.
3678 if Nkind_In (Subp_Decl, N_Subprogram_Body,
3679 N_Subprogram_Body_Stub)
3681 Analyze_Pre_Post_Condition_In_Decl_Part (N);
3684 -- Chain the pragma on the contract for further processing by
3685 -- Analyze_Pre_Post_Condition_In_Decl_Part.
3687 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
3688 end Analyze_Pre_Post_Condition;
3690 -----------------------------------------
3691 -- Analyze_Refined_Depends_Global_Post --
3692 -----------------------------------------
3694 procedure Analyze_Refined_Depends_Global_Post
3695 (Spec_Id : out Entity_Id;
3696 Body_Id : out Entity_Id;
3697 Legal : out Boolean)
3699 Body_Decl : Node_Id;
3700 Spec_Decl : Node_Id;
3703 -- Assume that the pragma is illegal
3710 Check_Arg_Count (1);
3711 Check_No_Identifiers;
3713 -- Verify the placement of the pragma and check for duplicates. The
3714 -- pragma must apply to a subprogram body [stub].
3716 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3718 -- Extract the entities of the spec and body
3720 if Nkind (Body_Decl) = N_Subprogram_Body then
3721 Body_Id := Defining_Entity (Body_Decl);
3722 Spec_Id := Corresponding_Spec (Body_Decl);
3724 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
3725 Body_Id := Defining_Entity (Body_Decl);
3726 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
3733 -- The pragma must apply to the second declaration of a subprogram.
3734 -- In other words, the body [stub] cannot acts as a spec.
3736 if No (Spec_Id) then
3737 Error_Pragma ("pragma % cannot apply to a stand alone body");
3740 -- Catch the case where the subprogram body is a subunit and acts as
3741 -- the third declaration of the subprogram.
3743 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
3744 Error_Pragma ("pragma % cannot apply to a subunit");
3748 -- The pragma can only apply to the body [stub] of a subprogram
3749 -- declared in the visible part of a package. Retrieve the context of
3750 -- the subprogram declaration.
3752 Spec_Decl := Unit_Declaration_Node (Spec_Id);
3754 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
3756 ("pragma % must apply to the body of a subprogram declared in a "
3757 & "package specification");
3761 -- A pragma that applies to a Ghost entity becomes Ghost for the
3762 -- purposes of legality checks and removal of ignored Ghost code.
3764 Mark_Pragma_As_Ghost (N, Spec_Id);
3766 -- If we get here, then the pragma is legal
3768 if Nam_In (Pname, Name_Refined_Depends,
3769 Name_Refined_Global,
3772 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
3776 end Analyze_Refined_Depends_Global_Post;
3778 --------------------------
3779 -- Check_Ada_83_Warning --
3780 --------------------------
3782 procedure Check_Ada_83_Warning is
3784 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3785 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
3787 end Check_Ada_83_Warning;
3789 ---------------------
3790 -- Check_Arg_Count --
3791 ---------------------
3793 procedure Check_Arg_Count (Required : Nat) is
3795 if Arg_Count /= Required then
3796 Error_Pragma ("wrong number of arguments for pragma%");
3798 end Check_Arg_Count;
3800 --------------------------------
3801 -- Check_Arg_Is_External_Name --
3802 --------------------------------
3804 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
3805 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3808 if Nkind (Argx) = N_Identifier then
3812 Analyze_And_Resolve (Argx, Standard_String);
3814 if Is_OK_Static_Expression (Argx) then
3817 elsif Etype (Argx) = Any_Type then
3820 -- An interesting special case, if we have a string literal and
3821 -- we are in Ada 83 mode, then we allow it even though it will
3822 -- not be flagged as static. This allows expected Ada 83 mode
3823 -- use of external names which are string literals, even though
3824 -- technically these are not static in Ada 83.
3826 elsif Ada_Version = Ada_83
3827 and then Nkind (Argx) = N_String_Literal
3831 -- Static expression that raises Constraint_Error. This has
3832 -- already been flagged, so just exit from pragma processing.
3834 elsif Is_OK_Static_Expression (Argx) then
3837 -- Here we have a real error (non-static expression)
3840 Error_Msg_Name_1 := Pname;
3843 Msg : constant String :=
3844 "argument for pragma% must be a identifier or "
3845 & "static string expression!";
3847 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
3852 end Check_Arg_Is_External_Name;
3854 -----------------------------
3855 -- Check_Arg_Is_Identifier --
3856 -----------------------------
3858 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3859 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3861 if Nkind (Argx) /= N_Identifier then
3863 ("argument for pragma% must be identifier", Argx);
3865 end Check_Arg_Is_Identifier;
3867 ----------------------------------
3868 -- Check_Arg_Is_Integer_Literal --
3869 ----------------------------------
3871 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3872 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3874 if Nkind (Argx) /= N_Integer_Literal then
3876 ("argument for pragma% must be integer literal", Argx);
3878 end Check_Arg_Is_Integer_Literal;
3880 -------------------------------------------
3881 -- Check_Arg_Is_Library_Level_Local_Name --
3882 -------------------------------------------
3886 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3887 -- | library_unit_NAME
3889 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3891 Check_Arg_Is_Local_Name (Arg);
3893 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3894 and then Comes_From_Source (N)
3897 ("argument for pragma% must be library level entity", Arg);
3899 end Check_Arg_Is_Library_Level_Local_Name;
3901 -----------------------------
3902 -- Check_Arg_Is_Local_Name --
3903 -----------------------------
3907 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3908 -- | library_unit_NAME
3910 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3911 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3916 if Nkind (Argx) not in N_Direct_Name
3917 and then (Nkind (Argx) /= N_Attribute_Reference
3918 or else Present (Expressions (Argx))
3919 or else Nkind (Prefix (Argx)) /= N_Identifier)
3920 and then (not Is_Entity_Name (Argx)
3921 or else not Is_Compilation_Unit (Entity (Argx)))
3923 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3926 -- No further check required if not an entity name
3928 if not Is_Entity_Name (Argx) then
3934 Ent : constant Entity_Id := Entity (Argx);
3935 Scop : constant Entity_Id := Scope (Ent);
3938 -- Case of a pragma applied to a compilation unit: pragma must
3939 -- occur immediately after the program unit in the compilation.
3941 if Is_Compilation_Unit (Ent) then
3943 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3946 -- Case of pragma placed immediately after spec
3948 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3951 -- Case of pragma placed immediately after body
3953 elsif Nkind (Decl) = N_Subprogram_Declaration
3954 and then Present (Corresponding_Body (Decl))
3958 (Parent (Unit_Declaration_Node
3959 (Corresponding_Body (Decl))));
3961 -- All other cases are illegal
3968 -- Special restricted placement rule from 10.2.1(11.8/2)
3970 elsif Is_Generic_Formal (Ent)
3971 and then Prag_Id = Pragma_Preelaborable_Initialization
3973 OK := List_Containing (N) =
3974 Generic_Formal_Declarations
3975 (Unit_Declaration_Node (Scop));
3977 -- If this is an aspect applied to a subprogram body, the
3978 -- pragma is inserted in its declarative part.
3980 elsif From_Aspect_Specification (N)
3981 and then Ent = Current_Scope
3983 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
3987 -- If the aspect is a predicate (possibly others ???) and the
3988 -- context is a record type, this is a discriminant expression
3989 -- within a type declaration, that freezes the predicated
3992 elsif From_Aspect_Specification (N)
3993 and then Prag_Id = Pragma_Predicate
3994 and then Ekind (Current_Scope) = E_Record_Type
3995 and then Scop = Scope (Current_Scope)
3999 -- Default case, just check that the pragma occurs in the scope
4000 -- of the entity denoted by the name.
4003 OK := Current_Scope = Scop;
4008 ("pragma% argument must be in same declarative part", Arg);
4012 end Check_Arg_Is_Local_Name;
4014 ---------------------------------
4015 -- Check_Arg_Is_Locking_Policy --
4016 ---------------------------------
4018 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
4019 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4022 Check_Arg_Is_Identifier (Argx);
4024 if not Is_Locking_Policy_Name (Chars (Argx)) then
4025 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
4027 end Check_Arg_Is_Locking_Policy;
4029 -----------------------------------------------
4030 -- Check_Arg_Is_Partition_Elaboration_Policy --
4031 -----------------------------------------------
4033 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
4034 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4037 Check_Arg_Is_Identifier (Argx);
4039 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
4041 ("& is not a valid partition elaboration policy name", Argx);
4043 end Check_Arg_Is_Partition_Elaboration_Policy;
4045 -------------------------
4046 -- Check_Arg_Is_One_Of --
4047 -------------------------
4049 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4050 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4053 Check_Arg_Is_Identifier (Argx);
4055 if not Nam_In (Chars (Argx), N1, N2) then
4056 Error_Msg_Name_2 := N1;
4057 Error_Msg_Name_3 := N2;
4058 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
4060 end Check_Arg_Is_One_Of;
4062 procedure Check_Arg_Is_One_Of
4064 N1, N2, N3 : Name_Id)
4066 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4069 Check_Arg_Is_Identifier (Argx);
4071 if not Nam_In (Chars (Argx), N1, N2, N3) then
4072 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4074 end Check_Arg_Is_One_Of;
4076 procedure Check_Arg_Is_One_Of
4078 N1, N2, N3, N4 : Name_Id)
4080 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4083 Check_Arg_Is_Identifier (Argx);
4085 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
4086 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4088 end Check_Arg_Is_One_Of;
4090 procedure Check_Arg_Is_One_Of
4092 N1, N2, N3, N4, N5 : Name_Id)
4094 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4097 Check_Arg_Is_Identifier (Argx);
4099 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
4100 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4102 end Check_Arg_Is_One_Of;
4104 ---------------------------------
4105 -- Check_Arg_Is_Queuing_Policy --
4106 ---------------------------------
4108 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
4109 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4112 Check_Arg_Is_Identifier (Argx);
4114 if not Is_Queuing_Policy_Name (Chars (Argx)) then
4115 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
4117 end Check_Arg_Is_Queuing_Policy;
4119 ---------------------------------------
4120 -- Check_Arg_Is_OK_Static_Expression --
4121 ---------------------------------------
4123 procedure Check_Arg_Is_OK_Static_Expression
4125 Typ : Entity_Id := Empty)
4128 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4129 end Check_Arg_Is_OK_Static_Expression;
4131 ------------------------------------------
4132 -- Check_Arg_Is_Task_Dispatching_Policy --
4133 ------------------------------------------
4135 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4136 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4139 Check_Arg_Is_Identifier (Argx);
4141 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4143 ("& is not an allowed task dispatching policy name", Argx);
4145 end Check_Arg_Is_Task_Dispatching_Policy;
4147 ---------------------
4148 -- Check_Arg_Order --
4149 ---------------------
4151 procedure Check_Arg_Order (Names : Name_List) is
4154 Highest_So_Far : Natural := 0;
4155 -- Highest index in Names seen do far
4159 for J in 1 .. Arg_Count loop
4160 if Chars (Arg) /= No_Name then
4161 for K in Names'Range loop
4162 if Chars (Arg) = Names (K) then
4163 if K < Highest_So_Far then
4164 Error_Msg_Name_1 := Pname;
4166 ("parameters out of order for pragma%", Arg);
4167 Error_Msg_Name_1 := Names (K);
4168 Error_Msg_Name_2 := Names (Highest_So_Far);
4169 Error_Msg_N ("\% must appear before %", Arg);
4173 Highest_So_Far := K;
4181 end Check_Arg_Order;
4183 --------------------------------
4184 -- Check_At_Least_N_Arguments --
4185 --------------------------------
4187 procedure Check_At_Least_N_Arguments (N : Nat) is
4189 if Arg_Count < N then
4190 Error_Pragma ("too few arguments for pragma%");
4192 end Check_At_Least_N_Arguments;
4194 -------------------------------
4195 -- Check_At_Most_N_Arguments --
4196 -------------------------------
4198 procedure Check_At_Most_N_Arguments (N : Nat) is
4201 if Arg_Count > N then
4203 for J in 1 .. N loop
4205 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4208 end Check_At_Most_N_Arguments;
4210 ---------------------
4211 -- Check_Component --
4212 ---------------------
4214 procedure Check_Component
4217 In_Variant_Part : Boolean := False)
4219 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4220 Sindic : constant Node_Id :=
4221 Subtype_Indication (Component_Definition (Comp));
4222 Typ : constant Entity_Id := Etype (Comp_Id);
4225 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4226 -- object constraint, then the component type shall be an Unchecked_
4229 if Nkind (Sindic) = N_Subtype_Indication
4230 and then Has_Per_Object_Constraint (Comp_Id)
4231 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4234 ("component subtype subject to per-object constraint "
4235 & "must be an Unchecked_Union", Comp);
4237 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4238 -- the body of a generic unit, or within the body of any of its
4239 -- descendant library units, no part of the type of a component
4240 -- declared in a variant_part of the unchecked union type shall be of
4241 -- a formal private type or formal private extension declared within
4242 -- the formal part of the generic unit.
4244 elsif Ada_Version >= Ada_2012
4245 and then In_Generic_Body (UU_Typ)
4246 and then In_Variant_Part
4247 and then Is_Private_Type (Typ)
4248 and then Is_Generic_Type (Typ)
4251 ("component of unchecked union cannot be of generic type", Comp);
4253 elsif Needs_Finalization (Typ) then
4255 ("component of unchecked union cannot be controlled", Comp);
4257 elsif Has_Task (Typ) then
4259 ("component of unchecked union cannot have tasks", Comp);
4261 end Check_Component;
4263 -----------------------------
4264 -- Check_Declaration_Order --
4265 -----------------------------
4267 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is
4268 procedure Check_Aspect_Specification_Order;
4269 -- Inspect the aspect specifications of the context to determine the
4272 --------------------------------------
4273 -- Check_Aspect_Specification_Order --
4274 --------------------------------------
4276 procedure Check_Aspect_Specification_Order is
4277 Asp_First : constant Node_Id := Corresponding_Aspect (First);
4278 Asp_Second : constant Node_Id := Corresponding_Aspect (Second);
4282 -- Both aspects must be part of the same aspect specification list
4285 (List_Containing (Asp_First) = List_Containing (Asp_Second));
4287 -- Try to reach Second starting from First in a left to right
4288 -- traversal of the aspect specifications.
4290 Asp := Next (Asp_First);
4291 while Present (Asp) loop
4293 -- The order is ok, First is followed by Second
4295 if Asp = Asp_Second then
4302 -- If we get here, then the aspects are out of order
4304 SPARK_Msg_N ("aspect % cannot come after aspect %", First);
4305 end Check_Aspect_Specification_Order;
4311 -- Start of processing for Check_Declaration_Order
4314 -- Cannot check the order if one of the pragmas is missing
4316 if No (First) or else No (Second) then
4320 -- Set up the error names in case the order is incorrect
4322 Error_Msg_Name_1 := Pragma_Name (First);
4323 Error_Msg_Name_2 := Pragma_Name (Second);
4325 if From_Aspect_Specification (First) then
4327 -- Both pragmas are actually aspects, check their declaration
4328 -- order in the associated aspect specification list. Otherwise
4329 -- First is an aspect and Second a source pragma.
4331 if From_Aspect_Specification (Second) then
4332 Check_Aspect_Specification_Order;
4335 -- Abstract_States is a source pragma
4338 if From_Aspect_Specification (Second) then
4339 SPARK_Msg_N ("pragma % cannot come after aspect %", First);
4341 -- Both pragmas are source constructs. Try to reach First from
4342 -- Second by traversing the declarations backwards.
4345 Stmt := Prev (Second);
4346 while Present (Stmt) loop
4348 -- The order is ok, First is followed by Second
4350 if Stmt = First then
4357 -- If we get here, then the pragmas are out of order
4359 SPARK_Msg_N ("pragma % cannot come after pragma %", First);
4362 end Check_Declaration_Order;
4364 ----------------------------
4365 -- Check_Duplicate_Pragma --
4366 ----------------------------
4368 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4369 Id : Entity_Id := E;
4373 -- Nothing to do if this pragma comes from an aspect specification,
4374 -- since we could not be duplicating a pragma, and we dealt with the
4375 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4377 if From_Aspect_Specification (N) then
4381 -- Otherwise current pragma may duplicate previous pragma or a
4382 -- previously given aspect specification or attribute definition
4383 -- clause for the same pragma.
4385 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4389 -- If the entity is a type, then we have to make sure that the
4390 -- ostensible duplicate is not for a parent type from which this
4394 if Nkind (P) = N_Pragma then
4396 Args : constant List_Id :=
4397 Pragma_Argument_Associations (P);
4400 and then Is_Entity_Name (Expression (First (Args)))
4401 and then Is_Type (Entity (Expression (First (Args))))
4402 and then Entity (Expression (First (Args))) /= E
4408 elsif Nkind (P) = N_Aspect_Specification
4409 and then Is_Type (Entity (P))
4410 and then Entity (P) /= E
4416 -- Here we have a definite duplicate
4418 Error_Msg_Name_1 := Pragma_Name (N);
4419 Error_Msg_Sloc := Sloc (P);
4421 -- For a single protected or a single task object, the error is
4422 -- issued on the original entity.
4424 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4425 Id := Defining_Identifier (Original_Node (Parent (Id)));
4428 if Nkind (P) = N_Aspect_Specification
4429 or else From_Aspect_Specification (P)
4431 Error_Msg_NE ("aspect% for & previously given#", N, Id);
4433 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
4438 end Check_Duplicate_Pragma;
4440 ----------------------------------
4441 -- Check_Duplicated_Export_Name --
4442 ----------------------------------
4444 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
4445 String_Val : constant String_Id := Strval (Nam);
4448 -- We are only interested in the export case, and in the case of
4449 -- generics, it is the instance, not the template, that is the
4450 -- problem (the template will generate a warning in any case).
4452 if not Inside_A_Generic
4453 and then (Prag_Id = Pragma_Export
4455 Prag_Id = Pragma_Export_Procedure
4457 Prag_Id = Pragma_Export_Valued_Procedure
4459 Prag_Id = Pragma_Export_Function)
4461 for J in Externals.First .. Externals.Last loop
4462 if String_Equal (String_Val, Strval (Externals.Table (J))) then
4463 Error_Msg_Sloc := Sloc (Externals.Table (J));
4464 Error_Msg_N ("external name duplicates name given#", Nam);
4469 Externals.Append (Nam);
4471 end Check_Duplicated_Export_Name;
4473 ----------------------------------------
4474 -- Check_Expr_Is_OK_Static_Expression --
4475 ----------------------------------------
4477 procedure Check_Expr_Is_OK_Static_Expression
4479 Typ : Entity_Id := Empty)
4482 if Present (Typ) then
4483 Analyze_And_Resolve (Expr, Typ);
4485 Analyze_And_Resolve (Expr);
4488 if Is_OK_Static_Expression (Expr) then
4491 elsif Etype (Expr) = Any_Type then
4494 -- An interesting special case, if we have a string literal and we
4495 -- are in Ada 83 mode, then we allow it even though it will not be
4496 -- flagged as static. This allows the use of Ada 95 pragmas like
4497 -- Import in Ada 83 mode. They will of course be flagged with
4498 -- warnings as usual, but will not cause errors.
4500 elsif Ada_Version = Ada_83
4501 and then Nkind (Expr) = N_String_Literal
4505 -- Static expression that raises Constraint_Error. This has already
4506 -- been flagged, so just exit from pragma processing.
4508 elsif Is_OK_Static_Expression (Expr) then
4511 -- Finally, we have a real error
4514 Error_Msg_Name_1 := Pname;
4515 Flag_Non_Static_Expr
4516 (Fix_Error ("argument for pragma% must be a static expression!"),
4520 end Check_Expr_Is_OK_Static_Expression;
4522 -------------------------
4523 -- Check_First_Subtype --
4524 -------------------------
4526 procedure Check_First_Subtype (Arg : Node_Id) is
4527 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4528 Ent : constant Entity_Id := Entity (Argx);
4531 if Is_First_Subtype (Ent) then
4534 elsif Is_Type (Ent) then
4536 ("pragma% cannot apply to subtype", Argx);
4538 elsif Is_Object (Ent) then
4540 ("pragma% cannot apply to object, requires a type", Argx);
4544 ("pragma% cannot apply to&, requires a type", Argx);
4546 end Check_First_Subtype;
4548 ----------------------
4549 -- Check_Identifier --
4550 ----------------------
4552 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
4555 and then Nkind (Arg) = N_Pragma_Argument_Association
4557 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
4558 Error_Msg_Name_1 := Pname;
4559 Error_Msg_Name_2 := Id;
4560 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4564 end Check_Identifier;
4566 --------------------------------
4567 -- Check_Identifier_Is_One_Of --
4568 --------------------------------
4570 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4573 and then Nkind (Arg) = N_Pragma_Argument_Association
4575 if Chars (Arg) = No_Name then
4576 Error_Msg_Name_1 := Pname;
4577 Error_Msg_N ("pragma% argument expects an identifier", Arg);
4580 elsif Chars (Arg) /= N1
4581 and then Chars (Arg) /= N2
4583 Error_Msg_Name_1 := Pname;
4584 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
4588 end Check_Identifier_Is_One_Of;
4590 ---------------------------
4591 -- Check_In_Main_Program --
4592 ---------------------------
4594 procedure Check_In_Main_Program is
4595 P : constant Node_Id := Parent (N);
4598 -- Must be at in subprogram body
4600 if Nkind (P) /= N_Subprogram_Body then
4601 Error_Pragma ("% pragma allowed only in subprogram");
4603 -- Otherwise warn if obviously not main program
4605 elsif Present (Parameter_Specifications (Specification (P)))
4606 or else not Is_Compilation_Unit (Defining_Entity (P))
4608 Error_Msg_Name_1 := Pname;
4610 ("??pragma% is only effective in main program", N);
4612 end Check_In_Main_Program;
4614 ---------------------------------------
4615 -- Check_Interrupt_Or_Attach_Handler --
4616 ---------------------------------------
4618 procedure Check_Interrupt_Or_Attach_Handler is
4619 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4620 Handler_Proc, Proc_Scope : Entity_Id;
4625 if Prag_Id = Pragma_Interrupt_Handler then
4626 Check_Restriction (No_Dynamic_Attachment, N);
4629 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4630 Proc_Scope := Scope (Handler_Proc);
4632 -- On AAMP only, a pragma Interrupt_Handler is supported for
4633 -- nonprotected parameterless procedures.
4635 if not AAMP_On_Target
4636 or else Prag_Id = Pragma_Attach_Handler
4638 if Ekind (Proc_Scope) /= E_Protected_Type then
4640 ("argument of pragma% must be protected procedure", Arg1);
4643 -- For pragma case (as opposed to access case), check placement.
4644 -- We don't need to do that for aspects, because we have the
4645 -- check that they aspect applies an appropriate procedure.
4647 if not From_Aspect_Specification (N)
4648 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
4650 Error_Pragma ("pragma% must be in protected definition");
4654 if not Is_Library_Level_Entity (Proc_Scope)
4655 or else (AAMP_On_Target
4656 and then not Is_Library_Level_Entity (Handler_Proc))
4659 ("argument for pragma% must be library level entity", Arg1);
4662 -- AI05-0033: A pragma cannot appear within a generic body, because
4663 -- instance can be in a nested scope. The check that protected type
4664 -- is itself a library-level declaration is done elsewhere.
4666 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4667 -- handle code prior to AI-0033. Analysis tools typically are not
4668 -- interested in this pragma in any case, so no need to worry too
4669 -- much about its placement.
4671 if Inside_A_Generic then
4672 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4673 and then In_Package_Body (Scope (Current_Scope))
4674 and then not Relaxed_RM_Semantics
4676 Error_Pragma ("pragma% cannot be used inside a generic");
4679 end Check_Interrupt_Or_Attach_Handler;
4681 ---------------------------------
4682 -- Check_Loop_Pragma_Placement --
4683 ---------------------------------
4685 procedure Check_Loop_Pragma_Placement is
4686 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
4687 -- Verify whether the current pragma is properly grouped with other
4688 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4689 -- related loop where the pragma appears.
4691 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
4692 -- Determine whether an arbitrary statement Stmt denotes pragma
4693 -- Loop_Invariant or Loop_Variant.
4695 procedure Placement_Error (Constr : Node_Id);
4696 pragma No_Return (Placement_Error);
4697 -- Node Constr denotes the last loop restricted construct before we
4698 -- encountered an illegal relation between enclosing constructs. Emit
4699 -- an error depending on what Constr was.
4701 --------------------------------
4702 -- Check_Loop_Pragma_Grouping --
4703 --------------------------------
4705 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
4706 Stop_Search : exception;
4707 -- This exception is used to terminate the recursive descent of
4708 -- routine Check_Grouping.
4710 procedure Check_Grouping (L : List_Id);
4711 -- Find the first group of pragmas in list L and if successful,
4712 -- ensure that the current pragma is part of that group. The
4713 -- routine raises Stop_Search once such a check is performed to
4714 -- halt the recursive descent.
4716 procedure Grouping_Error (Prag : Node_Id);
4717 pragma No_Return (Grouping_Error);
4718 -- Emit an error concerning the current pragma indicating that it
4719 -- should be placed after pragma Prag.
4721 --------------------
4722 -- Check_Grouping --
4723 --------------------
4725 procedure Check_Grouping (L : List_Id) is
4731 -- Inspect the list of declarations or statements looking for
4732 -- the first grouping of pragmas:
4735 -- pragma Loop_Invariant ...;
4736 -- pragma Loop_Variant ...;
4738 -- pragma Loop_Variant ...; -- current pragma
4740 -- If the current pragma is not in the grouping, then it must
4741 -- either appear in a different declarative or statement list
4742 -- or the construct at (1) is separating the pragma from the
4746 while Present (Stmt) loop
4748 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4749 -- inside a loop or a block housed inside a loop. Inspect
4750 -- the declarations and statements of the block as they may
4751 -- contain the first grouping.
4753 if Nkind (Stmt) = N_Block_Statement then
4754 HSS := Handled_Statement_Sequence (Stmt);
4756 Check_Grouping (Declarations (Stmt));
4758 if Present (HSS) then
4759 Check_Grouping (Statements (HSS));
4762 -- First pragma of the first topmost grouping has been found
4764 elsif Is_Loop_Pragma (Stmt) then
4766 -- The group and the current pragma are not in the same
4767 -- declarative or statement list.
4769 if List_Containing (Stmt) /= List_Containing (N) then
4770 Grouping_Error (Stmt);
4772 -- Try to reach the current pragma from the first pragma
4773 -- of the grouping while skipping other members:
4775 -- pragma Loop_Invariant ...; -- first pragma
4776 -- pragma Loop_Variant ...; -- member
4778 -- pragma Loop_Variant ...; -- current pragma
4781 while Present (Stmt) loop
4783 -- The current pragma is either the first pragma
4784 -- of the group or is a member of the group. Stop
4785 -- the search as the placement is legal.
4790 -- Skip group members, but keep track of the last
4791 -- pragma in the group.
4793 elsif Is_Loop_Pragma (Stmt) then
4796 -- A non-pragma is separating the group from the
4797 -- current pragma, the placement is illegal.
4800 Grouping_Error (Prag);
4806 -- If the traversal did not reach the current pragma,
4807 -- then the list must be malformed.
4809 raise Program_Error;
4817 --------------------
4818 -- Grouping_Error --
4819 --------------------
4821 procedure Grouping_Error (Prag : Node_Id) is
4823 Error_Msg_Sloc := Sloc (Prag);
4824 Error_Pragma ("pragma% must appear next to pragma#");
4827 -- Start of processing for Check_Loop_Pragma_Grouping
4830 -- Inspect the statements of the loop or nested blocks housed
4831 -- within to determine whether the current pragma is part of the
4832 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4834 Check_Grouping (Statements (Loop_Stmt));
4837 when Stop_Search => null;
4838 end Check_Loop_Pragma_Grouping;
4840 --------------------
4841 -- Is_Loop_Pragma --
4842 --------------------
4844 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
4846 -- Inspect the original node as Loop_Invariant and Loop_Variant
4847 -- pragmas are rewritten to null when assertions are disabled.
4849 if Nkind (Original_Node (Stmt)) = N_Pragma then
4851 Nam_In (Pragma_Name (Original_Node (Stmt)),
4852 Name_Loop_Invariant,
4859 ---------------------
4860 -- Placement_Error --
4861 ---------------------
4863 procedure Placement_Error (Constr : Node_Id) is
4864 LA : constant String := " with Loop_Entry";
4867 if Prag_Id = Pragma_Assert then
4868 Error_Msg_String (1 .. LA'Length) := LA;
4869 Error_Msg_Strlen := LA'Length;
4871 Error_Msg_Strlen := 0;
4874 if Nkind (Constr) = N_Pragma then
4876 ("pragma %~ must appear immediately within the statements "
4880 ("block containing pragma %~ must appear immediately within "
4881 & "the statements of a loop", Constr);
4883 end Placement_Error;
4885 -- Local declarations
4890 -- Start of processing for Check_Loop_Pragma_Placement
4893 -- Check that pragma appears immediately within a loop statement,
4894 -- ignoring intervening block statements.
4898 while Present (Stmt) loop
4900 -- The pragma or previous block must appear immediately within the
4901 -- current block's declarative or statement part.
4903 if Nkind (Stmt) = N_Block_Statement then
4904 if (No (Declarations (Stmt))
4905 or else List_Containing (Prev) /= Declarations (Stmt))
4907 List_Containing (Prev) /=
4908 Statements (Handled_Statement_Sequence (Stmt))
4910 Placement_Error (Prev);
4913 -- Keep inspecting the parents because we are now within a
4914 -- chain of nested blocks.
4918 Stmt := Parent (Stmt);
4921 -- The pragma or previous block must appear immediately within the
4922 -- statements of the loop.
4924 elsif Nkind (Stmt) = N_Loop_Statement then
4925 if List_Containing (Prev) /= Statements (Stmt) then
4926 Placement_Error (Prev);
4929 -- Stop the traversal because we reached the innermost loop
4930 -- regardless of whether we encountered an error or not.
4934 -- Ignore a handled statement sequence. Note that this node may
4935 -- be related to a subprogram body in which case we will emit an
4936 -- error on the next iteration of the search.
4938 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
4939 Stmt := Parent (Stmt);
4941 -- Any other statement breaks the chain from the pragma to the
4945 Placement_Error (Prev);
4950 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4951 -- grouped together with other such pragmas.
4953 if Is_Loop_Pragma (N) then
4955 -- The previous check should have located the related loop
4957 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
4958 Check_Loop_Pragma_Grouping (Stmt);
4960 end Check_Loop_Pragma_Placement;
4962 -------------------------------------------
4963 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4964 -------------------------------------------
4966 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
4975 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4978 elsif Nkind_In (P, N_Package_Specification,
4983 -- Note: the following tests seem a little peculiar, because
4984 -- they test for bodies, but if we were in the statement part
4985 -- of the body, we would already have hit the handled statement
4986 -- sequence, so the only way we get here is by being in the
4987 -- declarative part of the body.
4989 elsif Nkind_In (P, N_Subprogram_Body,
5000 Error_Pragma ("pragma% is not in declarative part or package spec");
5001 end Check_Is_In_Decl_Part_Or_Package_Spec;
5003 -------------------------
5004 -- Check_No_Identifier --
5005 -------------------------
5007 procedure Check_No_Identifier (Arg : Node_Id) is
5009 if Nkind (Arg) = N_Pragma_Argument_Association
5010 and then Chars (Arg) /= No_Name
5012 Error_Pragma_Arg_Ident
5013 ("pragma% does not permit identifier& here", Arg);
5015 end Check_No_Identifier;
5017 --------------------------
5018 -- Check_No_Identifiers --
5019 --------------------------
5021 procedure Check_No_Identifiers is
5025 for J in 1 .. Arg_Count loop
5026 Check_No_Identifier (Arg_Node);
5029 end Check_No_Identifiers;
5031 ------------------------
5032 -- Check_No_Link_Name --
5033 ------------------------
5035 procedure Check_No_Link_Name is
5037 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5041 if Present (Arg4) then
5043 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5045 end Check_No_Link_Name;
5047 -------------------------------
5048 -- Check_Optional_Identifier --
5049 -------------------------------
5051 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5054 and then Nkind (Arg) = N_Pragma_Argument_Association
5055 and then Chars (Arg) /= No_Name
5057 if Chars (Arg) /= Id then
5058 Error_Msg_Name_1 := Pname;
5059 Error_Msg_Name_2 := Id;
5060 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5064 end Check_Optional_Identifier;
5066 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5068 Name_Buffer (1 .. Id'Length) := Id;
5069 Name_Len := Id'Length;
5070 Check_Optional_Identifier (Arg, Name_Find);
5071 end Check_Optional_Identifier;
5073 -----------------------------
5074 -- Check_Static_Constraint --
5075 -----------------------------
5077 -- Note: for convenience in writing this procedure, in addition to
5078 -- the officially (i.e. by spec) allowed argument which is always a
5079 -- constraint, it also allows ranges and discriminant associations.
5080 -- Above is not clear ???
5082 procedure Check_Static_Constraint (Constr : Node_Id) is
5084 procedure Require_Static (E : Node_Id);
5085 -- Require given expression to be static expression
5087 --------------------
5088 -- Require_Static --
5089 --------------------
5091 procedure Require_Static (E : Node_Id) is
5093 if not Is_OK_Static_Expression (E) then
5094 Flag_Non_Static_Expr
5095 ("non-static constraint not allowed in Unchecked_Union!", E);
5100 -- Start of processing for Check_Static_Constraint
5103 case Nkind (Constr) is
5104 when N_Discriminant_Association =>
5105 Require_Static (Expression (Constr));
5108 Require_Static (Low_Bound (Constr));
5109 Require_Static (High_Bound (Constr));
5111 when N_Attribute_Reference =>
5112 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5113 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5115 when N_Range_Constraint =>
5116 Check_Static_Constraint (Range_Expression (Constr));
5118 when N_Index_Or_Discriminant_Constraint =>
5122 IDC := First (Constraints (Constr));
5123 while Present (IDC) loop
5124 Check_Static_Constraint (IDC);
5132 end Check_Static_Constraint;
5134 --------------------------------------
5135 -- Check_Valid_Configuration_Pragma --
5136 --------------------------------------
5138 -- A configuration pragma must appear in the context clause of a
5139 -- compilation unit, and only other pragmas may precede it. Note that
5140 -- the test also allows use in a configuration pragma file.
5142 procedure Check_Valid_Configuration_Pragma is
5144 if not Is_Configuration_Pragma then
5145 Error_Pragma ("incorrect placement for configuration pragma%");
5147 end Check_Valid_Configuration_Pragma;
5149 -------------------------------------
5150 -- Check_Valid_Library_Unit_Pragma --
5151 -------------------------------------
5153 procedure Check_Valid_Library_Unit_Pragma is
5155 Parent_Node : Node_Id;
5156 Unit_Name : Entity_Id;
5157 Unit_Kind : Node_Kind;
5158 Unit_Node : Node_Id;
5159 Sindex : Source_File_Index;
5162 if not Is_List_Member (N) then
5166 Plist := List_Containing (N);
5167 Parent_Node := Parent (Plist);
5169 if Parent_Node = Empty then
5172 -- Case of pragma appearing after a compilation unit. In this case
5173 -- it must have an argument with the corresponding name and must
5174 -- be part of the following pragmas of its parent.
5176 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5177 if Plist /= Pragmas_After (Parent_Node) then
5180 elsif Arg_Count = 0 then
5182 ("argument required if outside compilation unit");
5185 Check_No_Identifiers;
5186 Check_Arg_Count (1);
5187 Unit_Node := Unit (Parent (Parent_Node));
5188 Unit_Kind := Nkind (Unit_Node);
5190 Analyze (Get_Pragma_Arg (Arg1));
5192 if Unit_Kind = N_Generic_Subprogram_Declaration
5193 or else Unit_Kind = N_Subprogram_Declaration
5195 Unit_Name := Defining_Entity (Unit_Node);
5197 elsif Unit_Kind in N_Generic_Instantiation then
5198 Unit_Name := Defining_Entity (Unit_Node);
5201 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5204 if Chars (Unit_Name) /=
5205 Chars (Entity (Get_Pragma_Arg (Arg1)))
5208 ("pragma% argument is not current unit name", Arg1);
5211 if Ekind (Unit_Name) = E_Package
5212 and then Present (Renamed_Entity (Unit_Name))
5214 Error_Pragma ("pragma% not allowed for renamed package");
5218 -- Pragma appears other than after a compilation unit
5221 -- Here we check for the generic instantiation case and also
5222 -- for the case of processing a generic formal package. We
5223 -- detect these cases by noting that the Sloc on the node
5224 -- does not belong to the current compilation unit.
5226 Sindex := Source_Index (Current_Sem_Unit);
5228 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5229 Rewrite (N, Make_Null_Statement (Loc));
5232 -- If before first declaration, the pragma applies to the
5233 -- enclosing unit, and the name if present must be this name.
5235 elsif Is_Before_First_Decl (N, Plist) then
5236 Unit_Node := Unit_Declaration_Node (Current_Scope);
5237 Unit_Kind := Nkind (Unit_Node);
5239 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5242 elsif Unit_Kind = N_Subprogram_Body
5243 and then not Acts_As_Spec (Unit_Node)
5247 elsif Nkind (Parent_Node) = N_Package_Body then
5250 elsif Nkind (Parent_Node) = N_Package_Specification
5251 and then Plist = Private_Declarations (Parent_Node)
5255 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5256 or else Nkind (Parent_Node) =
5257 N_Generic_Subprogram_Declaration)
5258 and then Plist = Generic_Formal_Declarations (Parent_Node)
5262 elsif Arg_Count > 0 then
5263 Analyze (Get_Pragma_Arg (Arg1));
5265 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5267 ("name in pragma% must be enclosing unit", Arg1);
5270 -- It is legal to have no argument in this context
5276 -- Error if not before first declaration. This is because a
5277 -- library unit pragma argument must be the name of a library
5278 -- unit (RM 10.1.5(7)), but the only names permitted in this
5279 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5280 -- generic subprogram declarations or generic instantiations.
5284 ("pragma% misplaced, must be before first declaration");
5288 end Check_Valid_Library_Unit_Pragma;
5294 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5295 Clist : constant Node_Id := Component_List (Variant);
5299 Comp := First (Component_Items (Clist));
5300 while Present (Comp) loop
5301 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5306 ---------------------------
5307 -- Ensure_Aggregate_Form --
5308 ---------------------------
5310 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5311 CFSD : constant Boolean := Get_Comes_From_Source_Default;
5312 Expr : constant Node_Id := Expression (Arg);
5313 Loc : constant Source_Ptr := Sloc (Expr);
5314 Comps : List_Id := No_List;
5315 Exprs : List_Id := No_List;
5316 Nam : Name_Id := No_Name;
5317 Nam_Loc : Source_Ptr;
5320 -- The pragma argument is in positional form:
5322 -- pragma Depends (Nam => ...)
5326 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5327 -- argument association.
5329 if Nkind (Arg) = N_Pragma_Argument_Association then
5331 Nam_Loc := Sloc (Arg);
5333 -- Remove the pragma argument name as this will be captured in the
5336 Set_Chars (Arg, No_Name);
5339 -- The argument is already in aggregate form, but the presence of a
5340 -- name causes this to be interpreted as named association which in
5341 -- turn must be converted into an aggregate.
5343 -- pragma Global (In_Out => (A, B, C))
5347 -- pragma Global ((In_Out => (A, B, C)))
5349 -- aggregate aggregate
5351 if Nkind (Expr) = N_Aggregate then
5352 if Nam = No_Name then
5356 -- Do not transform a null argument into an aggregate as N_Null has
5357 -- special meaning in formal verification pragmas.
5359 elsif Nkind (Expr) = N_Null then
5363 -- Everything comes from source if the original comes from source
5365 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
5367 -- Positional argument is transformed into an aggregate with an
5368 -- Expressions list.
5370 if Nam = No_Name then
5371 Exprs := New_List (Relocate_Node (Expr));
5373 -- An associative argument is transformed into an aggregate with
5374 -- Component_Associations.
5378 Make_Component_Association (Loc,
5379 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
5380 Expression => Relocate_Node (Expr)));
5383 Set_Expression (Arg,
5384 Make_Aggregate (Loc,
5385 Component_Associations => Comps,
5386 Expressions => Exprs));
5388 -- Restore Comes_From_Source default
5390 Set_Comes_From_Source_Default (CFSD);
5391 end Ensure_Aggregate_Form;
5397 procedure Error_Pragma (Msg : String) is
5399 Error_Msg_Name_1 := Pname;
5400 Error_Msg_N (Fix_Error (Msg), N);
5404 ----------------------
5405 -- Error_Pragma_Arg --
5406 ----------------------
5408 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5410 Error_Msg_Name_1 := Pname;
5411 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5413 end Error_Pragma_Arg;
5415 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5417 Error_Msg_Name_1 := Pname;
5418 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
5419 Error_Pragma_Arg (Msg2, Arg);
5420 end Error_Pragma_Arg;
5422 ----------------------------
5423 -- Error_Pragma_Arg_Ident --
5424 ----------------------------
5426 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5428 Error_Msg_Name_1 := Pname;
5429 Error_Msg_N (Fix_Error (Msg), Arg);
5431 end Error_Pragma_Arg_Ident;
5433 ----------------------
5434 -- Error_Pragma_Ref --
5435 ----------------------
5437 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5439 Error_Msg_Name_1 := Pname;
5440 Error_Msg_Sloc := Sloc (Ref);
5441 Error_Msg_NE (Fix_Error (Msg), N, Ref);
5443 end Error_Pragma_Ref;
5445 ------------------------
5446 -- Find_Lib_Unit_Name --
5447 ------------------------
5449 function Find_Lib_Unit_Name return Entity_Id is
5451 -- Return inner compilation unit entity, for case of nested
5452 -- categorization pragmas. This happens in generic unit.
5454 if Nkind (Parent (N)) = N_Package_Specification
5455 and then Defining_Entity (Parent (N)) /= Current_Scope
5457 return Defining_Entity (Parent (N));
5459 return Current_Scope;
5461 end Find_Lib_Unit_Name;
5463 ----------------------------
5464 -- Find_Program_Unit_Name --
5465 ----------------------------
5467 procedure Find_Program_Unit_Name (Id : Node_Id) is
5468 Unit_Name : Entity_Id;
5469 Unit_Kind : Node_Kind;
5470 P : constant Node_Id := Parent (N);
5473 if Nkind (P) = N_Compilation_Unit then
5474 Unit_Kind := Nkind (Unit (P));
5476 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
5477 N_Package_Declaration)
5478 or else Unit_Kind in N_Generic_Declaration
5480 Unit_Name := Defining_Entity (Unit (P));
5482 if Chars (Id) = Chars (Unit_Name) then
5483 Set_Entity (Id, Unit_Name);
5484 Set_Etype (Id, Etype (Unit_Name));
5486 Set_Etype (Id, Any_Type);
5488 ("cannot find program unit referenced by pragma%");
5492 Set_Etype (Id, Any_Type);
5493 Error_Pragma ("pragma% inapplicable to this unit");
5499 end Find_Program_Unit_Name;
5501 -----------------------------------------
5502 -- Find_Unique_Parameterless_Procedure --
5503 -----------------------------------------
5505 function Find_Unique_Parameterless_Procedure
5507 Arg : Node_Id) return Entity_Id
5509 Proc : Entity_Id := Empty;
5512 -- The body of this procedure needs some comments ???
5514 if not Is_Entity_Name (Name) then
5516 ("argument of pragma% must be entity name", Arg);
5518 elsif not Is_Overloaded (Name) then
5519 Proc := Entity (Name);
5521 if Ekind (Proc) /= E_Procedure
5522 or else Present (First_Formal (Proc))
5525 ("argument of pragma% must be parameterless procedure", Arg);
5530 Found : Boolean := False;
5532 Index : Interp_Index;
5535 Get_First_Interp (Name, Index, It);
5536 while Present (It.Nam) loop
5539 if Ekind (Proc) = E_Procedure
5540 and then No (First_Formal (Proc))
5544 Set_Entity (Name, Proc);
5545 Set_Is_Overloaded (Name, False);
5548 ("ambiguous handler name for pragma% ", Arg);
5552 Get_Next_Interp (Index, It);
5557 ("argument of pragma% must be parameterless procedure",
5560 Proc := Entity (Name);
5566 end Find_Unique_Parameterless_Procedure;
5572 function Fix_Error (Msg : String) return String is
5573 Res : String (Msg'Range) := Msg;
5574 Res_Last : Natural := Msg'Last;
5578 -- If we have a rewriting of another pragma, go to that pragma
5580 if Is_Rewrite_Substitution (N)
5581 and then Nkind (Original_Node (N)) = N_Pragma
5583 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5586 -- Case where pragma comes from an aspect specification
5588 if From_Aspect_Specification (N) then
5590 -- Change appearence of "pragma" in message to "aspect"
5593 while J <= Res_Last - 5 loop
5594 if Res (J .. J + 5) = "pragma" then
5595 Res (J .. J + 5) := "aspect";
5603 -- Change "argument of" at start of message to "entity for"
5606 and then Res (Res'First .. Res'First + 10) = "argument of"
5608 Res (Res'First .. Res'First + 9) := "entity for";
5609 Res (Res'First + 10 .. Res_Last - 1) :=
5610 Res (Res'First + 11 .. Res_Last);
5611 Res_Last := Res_Last - 1;
5614 -- Change "argument" at start of message to "entity"
5617 and then Res (Res'First .. Res'First + 7) = "argument"
5619 Res (Res'First .. Res'First + 5) := "entity";
5620 Res (Res'First + 6 .. Res_Last - 2) :=
5621 Res (Res'First + 8 .. Res_Last);
5622 Res_Last := Res_Last - 2;
5625 -- Get name from corresponding aspect
5627 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
5630 -- Return possibly modified message
5632 return Res (Res'First .. Res_Last);
5635 -------------------------
5636 -- Gather_Associations --
5637 -------------------------
5639 procedure Gather_Associations
5641 Args : out Args_List)
5646 -- Initialize all parameters to Empty
5648 for J in Args'Range loop
5652 -- That's all we have to do if there are no argument associations
5654 if No (Pragma_Argument_Associations (N)) then
5658 -- Otherwise first deal with any positional parameters present
5660 Arg := First (Pragma_Argument_Associations (N));
5661 for Index in Args'Range loop
5662 exit when No (Arg) or else Chars (Arg) /= No_Name;
5663 Args (Index) := Get_Pragma_Arg (Arg);
5667 -- Positional parameters all processed, if any left, then we
5668 -- have too many positional parameters.
5670 if Present (Arg) and then Chars (Arg) = No_Name then
5672 ("too many positional associations for pragma%", Arg);
5675 -- Process named parameters if any are present
5677 while Present (Arg) loop
5678 if Chars (Arg) = No_Name then
5680 ("positional association cannot follow named association",
5684 for Index in Names'Range loop
5685 if Names (Index) = Chars (Arg) then
5686 if Present (Args (Index)) then
5688 ("duplicate argument association for pragma%", Arg);
5690 Args (Index) := Get_Pragma_Arg (Arg);
5695 if Index = Names'Last then
5696 Error_Msg_Name_1 := Pname;
5697 Error_Msg_N ("pragma% does not allow & argument", Arg);
5699 -- Check for possible misspelling
5701 for Index1 in Names'Range loop
5702 if Is_Bad_Spelling_Of
5703 (Chars (Arg), Names (Index1))
5705 Error_Msg_Name_1 := Names (Index1);
5706 Error_Msg_N -- CODEFIX
5707 ("\possible misspelling of%", Arg);
5719 end Gather_Associations;
5725 procedure GNAT_Pragma is
5727 -- We need to check the No_Implementation_Pragmas restriction for
5728 -- the case of a pragma from source. Note that the case of aspects
5729 -- generating corresponding pragmas marks these pragmas as not being
5730 -- from source, so this test also catches that case.
5732 if Comes_From_Source (N) then
5733 Check_Restriction (No_Implementation_Pragmas, N);
5737 --------------------------
5738 -- Is_Before_First_Decl --
5739 --------------------------
5741 function Is_Before_First_Decl
5742 (Pragma_Node : Node_Id;
5743 Decls : List_Id) return Boolean
5745 Item : Node_Id := First (Decls);
5748 -- Only other pragmas can come before this pragma
5751 if No (Item) or else Nkind (Item) /= N_Pragma then
5754 elsif Item = Pragma_Node then
5760 end Is_Before_First_Decl;
5762 -----------------------------
5763 -- Is_Configuration_Pragma --
5764 -----------------------------
5766 -- A configuration pragma must appear in the context clause of a
5767 -- compilation unit, and only other pragmas may precede it. Note that
5768 -- the test below also permits use in a configuration pragma file.
5770 function Is_Configuration_Pragma return Boolean is
5771 Lis : constant List_Id := List_Containing (N);
5772 Par : constant Node_Id := Parent (N);
5776 -- If no parent, then we are in the configuration pragma file,
5777 -- so the placement is definitely appropriate.
5782 -- Otherwise we must be in the context clause of a compilation unit
5783 -- and the only thing allowed before us in the context list is more
5784 -- configuration pragmas.
5786 elsif Nkind (Par) = N_Compilation_Unit
5787 and then Context_Items (Par) = Lis
5794 elsif Nkind (Prg) /= N_Pragma then
5804 end Is_Configuration_Pragma;
5806 --------------------------
5807 -- Is_In_Context_Clause --
5808 --------------------------
5810 function Is_In_Context_Clause return Boolean is
5812 Parent_Node : Node_Id;
5815 if not Is_List_Member (N) then
5819 Plist := List_Containing (N);
5820 Parent_Node := Parent (Plist);
5822 if Parent_Node = Empty
5823 or else Nkind (Parent_Node) /= N_Compilation_Unit
5824 or else Context_Items (Parent_Node) /= Plist
5831 end Is_In_Context_Clause;
5833 ---------------------------------
5834 -- Is_Static_String_Expression --
5835 ---------------------------------
5837 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
5838 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5839 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
5842 Analyze_And_Resolve (Argx);
5844 -- Special case Ada 83, where the expression will never be static,
5845 -- but we will return true if we had a string literal to start with.
5847 if Ada_Version = Ada_83 then
5850 -- Normal case, true only if we end up with a string literal that
5851 -- is marked as being the result of evaluating a static expression.
5854 return Is_OK_Static_Expression (Argx)
5855 and then Nkind (Argx) = N_String_Literal;
5858 end Is_Static_String_Expression;
5860 ----------------------
5861 -- Pragma_Misplaced --
5862 ----------------------
5864 procedure Pragma_Misplaced is
5866 Error_Pragma ("incorrect placement of pragma%");
5867 end Pragma_Misplaced;
5869 ------------------------------------------------
5870 -- Process_Atomic_Independent_Shared_Volatile --
5871 ------------------------------------------------
5873 procedure Process_Atomic_Independent_Shared_Volatile is
5879 procedure Set_Atomic_VFA (E : Entity_Id);
5880 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
5881 -- no explicit alignment was given, set alignment to unknown, since
5882 -- back end knows what the alignment requirements are for atomic and
5883 -- full access arrays. Note: this is necessary for derived types.
5885 --------------------
5886 -- Set_Atomic_VFA --
5887 --------------------
5889 procedure Set_Atomic_VFA (E : Entity_Id) is
5891 if Prag_Id = Pragma_Volatile_Full_Access then
5892 Set_Is_Volatile_Full_Access (E);
5897 if not Has_Alignment_Clause (E) then
5898 Set_Alignment (E, Uint_0);
5902 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
5905 Check_Ada_83_Warning;
5906 Check_No_Identifiers;
5907 Check_Arg_Count (1);
5908 Check_Arg_Is_Local_Name (Arg1);
5909 E_Id := Get_Pragma_Arg (Arg1);
5911 if Etype (E_Id) = Any_Type then
5916 D := Declaration_Node (E);
5919 -- A pragma that applies to a Ghost entity becomes Ghost for the
5920 -- purposes of legality checks and removal of ignored Ghost code.
5922 Mark_Pragma_As_Ghost (N, E);
5924 -- Check duplicate before we chain ourselves
5926 Check_Duplicate_Pragma (E);
5928 -- Check Atomic and VFA used together
5930 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
5931 or else (Is_Volatile_Full_Access (E)
5932 and then (Prag_Id = Pragma_Atomic
5934 Prag_Id = Pragma_Shared))
5937 ("cannot have Volatile_Full_Access and Atomic for same entity");
5940 -- Check for applying VFA to an entity which has aliased component
5942 if Prag_Id = Pragma_Volatile_Full_Access then
5945 Aliased_Comp : Boolean := False;
5946 -- Set True if aliased component present
5949 if Is_Array_Type (Etype (E)) then
5950 Aliased_Comp := Has_Aliased_Components (Etype (E));
5952 -- Record case, too bad Has_Aliased_Components is not also
5953 -- set for records, should it be ???
5955 elsif Is_Record_Type (Etype (E)) then
5956 Comp := First_Component_Or_Discriminant (Etype (E));
5957 while Present (Comp) loop
5958 if Is_Aliased (Comp)
5959 or else Is_Aliased (Etype (Comp))
5961 Aliased_Comp := True;
5965 Next_Component_Or_Discriminant (Comp);
5969 if Aliased_Comp then
5971 ("cannot apply Volatile_Full_Access (aliased component "
5977 -- Now check appropriateness of the entity
5980 if Rep_Item_Too_Early (E, N)
5982 Rep_Item_Too_Late (E, N)
5986 Check_First_Subtype (Arg1);
5989 -- Attribute belongs on the base type. If the view of the type is
5990 -- currently private, it also belongs on the underlying type.
5992 if Prag_Id = Pragma_Atomic
5994 Prag_Id = Pragma_Shared
5996 Prag_Id = Pragma_Volatile_Full_Access
5999 Set_Atomic_VFA (Base_Type (E));
6000 Set_Atomic_VFA (Underlying_Type (E));
6003 -- Atomic/Shared/Volatile_Full_Access imply Independent
6005 if Prag_Id /= Pragma_Volatile then
6006 Set_Is_Independent (E);
6007 Set_Is_Independent (Base_Type (E));
6008 Set_Is_Independent (Underlying_Type (E));
6010 if Prag_Id = Pragma_Independent then
6011 Record_Independence_Check (N, Base_Type (E));
6015 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6017 if Prag_Id /= Pragma_Independent then
6018 Set_Is_Volatile (E);
6019 Set_Is_Volatile (Base_Type (E));
6020 Set_Is_Volatile (Underlying_Type (E));
6022 Set_Treat_As_Volatile (E);
6023 Set_Treat_As_Volatile (Underlying_Type (E));
6026 elsif K = N_Object_Declaration
6027 or else (K = N_Component_Declaration
6028 and then Original_Record_Component (E) = E)
6030 if Rep_Item_Too_Late (E, N) then
6034 if Prag_Id = Pragma_Atomic
6036 Prag_Id = Pragma_Shared
6038 Prag_Id = Pragma_Volatile_Full_Access
6040 if Prag_Id = Pragma_Volatile_Full_Access then
6041 Set_Is_Volatile_Full_Access (E);
6046 -- If the object declaration has an explicit initialization, a
6047 -- temporary may have to be created to hold the expression, to
6048 -- ensure that access to the object remain atomic.
6050 if Nkind (Parent (E)) = N_Object_Declaration
6051 and then Present (Expression (Parent (E)))
6053 Set_Has_Delayed_Freeze (E);
6057 -- Atomic/Shared/Volatile_Full_Access imply Independent
6059 if Prag_Id /= Pragma_Volatile then
6060 Set_Is_Independent (E);
6062 if Prag_Id = Pragma_Independent then
6063 Record_Independence_Check (N, E);
6067 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6069 if Prag_Id /= Pragma_Independent then
6070 Set_Is_Volatile (E);
6071 Set_Treat_As_Volatile (E);
6075 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6078 -- The following check is only relevant when SPARK_Mode is on as
6079 -- this is not a standard Ada legality rule. Pragma Volatile can
6080 -- only apply to a full type declaration or an object declaration
6081 -- (SPARK RM C.6(1)).
6084 and then Prag_Id = Pragma_Volatile
6085 and then not Nkind_In (K, N_Full_Type_Declaration,
6086 N_Object_Declaration)
6089 ("argument of pragma % must denote a full type or object "
6090 & "declaration", Arg1);
6092 end Process_Atomic_Independent_Shared_Volatile;
6094 -------------------------------------------
6095 -- Process_Compile_Time_Warning_Or_Error --
6096 -------------------------------------------
6098 procedure Process_Compile_Time_Warning_Or_Error is
6099 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6102 Check_Arg_Count (2);
6103 Check_No_Identifiers;
6104 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6105 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6107 if Compile_Time_Known_Value (Arg1x) then
6108 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6110 Str : constant String_Id :=
6111 Strval (Get_Pragma_Arg (Arg2));
6112 Len : constant Int := String_Length (Str);
6117 Cent : constant Entity_Id :=
6118 Cunit_Entity (Current_Sem_Unit);
6120 Force : constant Boolean :=
6121 Prag_Id = Pragma_Compile_Time_Warning
6123 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6124 and then (Ekind (Cent) /= E_Package
6125 or else not In_Private_Part (Cent));
6126 -- Set True if this is the warning case, and we are in the
6127 -- visible part of a package spec, or in a subprogram spec,
6128 -- in which case we want to force the client to see the
6129 -- warning, even though it is not in the main unit.
6132 -- Loop through segments of message separated by line feeds.
6133 -- We output these segments as separate messages with
6134 -- continuation marks for all but the first.
6139 Error_Msg_Strlen := 0;
6141 -- Loop to copy characters from argument to error message
6145 exit when Ptr > Len;
6146 CC := Get_String_Char (Str, Ptr);
6149 -- Ignore wide chars ??? else store character
6151 if In_Character_Range (CC) then
6152 C := Get_Character (CC);
6153 exit when C = ASCII.LF;
6154 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6155 Error_Msg_String (Error_Msg_Strlen) := C;
6159 -- Here with one line ready to go
6161 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6163 -- If this is a warning in a spec, then we want clients
6164 -- to see the warning, so mark the message with the
6165 -- special sequence !! to force the warning. In the case
6166 -- of a package spec, we do not force this if we are in
6167 -- the private part of the spec.
6170 if Cont = False then
6171 Error_Msg_N ("<<~!!", Arg1);
6174 Error_Msg_N ("\<<~!!", Arg1);
6177 -- Error, rather than warning, or in a body, so we do not
6178 -- need to force visibility for client (error will be
6179 -- output in any case, and this is the situation in which
6180 -- we do not want a client to get a warning, since the
6181 -- warning is in the body or the spec private part).
6184 if Cont = False then
6185 Error_Msg_N ("<<~", Arg1);
6188 Error_Msg_N ("\<<~", Arg1);
6192 exit when Ptr > Len;
6197 end Process_Compile_Time_Warning_Or_Error;
6199 ------------------------
6200 -- Process_Convention --
6201 ------------------------
6203 procedure Process_Convention
6204 (C : out Convention_Id;
6205 Ent : out Entity_Id)
6209 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6210 -- Called if we have more than one Export/Import/Convention pragma.
6211 -- This is generally illegal, but we have a special case of allowing
6212 -- Import and Interface to coexist if they specify the convention in
6213 -- a consistent manner. We are allowed to do this, since Interface is
6214 -- an implementation defined pragma, and we choose to do it since we
6215 -- know Rational allows this combination. S is the entity id of the
6216 -- subprogram in question. This procedure also sets the special flag
6217 -- Import_Interface_Present in both pragmas in the case where we do
6218 -- have matching Import and Interface pragmas.
6220 procedure Set_Convention_From_Pragma (E : Entity_Id);
6221 -- Set convention in entity E, and also flag that the entity has a
6222 -- convention pragma. If entity is for a private or incomplete type,
6223 -- also set convention and flag on underlying type. This procedure
6224 -- also deals with the special case of C_Pass_By_Copy convention,
6225 -- and error checks for inappropriate convention specification.
6227 -------------------------------
6228 -- Diagnose_Multiple_Pragmas --
6229 -------------------------------
6231 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6232 Pdec : constant Node_Id := Declaration_Node (S);
6236 function Same_Convention (Decl : Node_Id) return Boolean;
6237 -- Decl is a pragma node. This function returns True if this
6238 -- pragma has a first argument that is an identifier with a
6239 -- Chars field corresponding to the Convention_Id C.
6241 function Same_Name (Decl : Node_Id) return Boolean;
6242 -- Decl is a pragma node. This function returns True if this
6243 -- pragma has a second argument that is an identifier with a
6244 -- Chars field that matches the Chars of the current subprogram.
6246 ---------------------
6247 -- Same_Convention --
6248 ---------------------
6250 function Same_Convention (Decl : Node_Id) return Boolean is
6251 Arg1 : constant Node_Id :=
6252 First (Pragma_Argument_Associations (Decl));
6255 if Present (Arg1) then
6257 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6259 if Nkind (Arg) = N_Identifier
6260 and then Is_Convention_Name (Chars (Arg))
6261 and then Get_Convention_Id (Chars (Arg)) = C
6269 end Same_Convention;
6275 function Same_Name (Decl : Node_Id) return Boolean is
6276 Arg1 : constant Node_Id :=
6277 First (Pragma_Argument_Associations (Decl));
6285 Arg2 := Next (Arg1);
6292 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6294 if Nkind (Arg) = N_Identifier
6295 and then Chars (Arg) = Chars (S)
6304 -- Start of processing for Diagnose_Multiple_Pragmas
6309 -- Definitely give message if we have Convention/Export here
6311 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6314 -- If we have an Import or Export, scan back from pragma to
6315 -- find any previous pragma applying to the same procedure.
6316 -- The scan will be terminated by the start of the list, or
6317 -- hitting the subprogram declaration. This won't allow one
6318 -- pragma to appear in the public part and one in the private
6319 -- part, but that seems very unlikely in practice.
6323 while Present (Decl) and then Decl /= Pdec loop
6325 -- Look for pragma with same name as us
6327 if Nkind (Decl) = N_Pragma
6328 and then Same_Name (Decl)
6330 -- Give error if same as our pragma or Export/Convention
6332 if Nam_In (Pragma_Name (Decl), Name_Export,
6338 -- Case of Import/Interface or the other way round
6340 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6343 -- Here we know that we have Import and Interface. It
6344 -- doesn't matter which way round they are. See if
6345 -- they specify the same convention. If so, all OK,
6346 -- and set special flags to stop other messages
6348 if Same_Convention (Decl) then
6349 Set_Import_Interface_Present (N);
6350 Set_Import_Interface_Present (Decl);
6353 -- If different conventions, special message
6356 Error_Msg_Sloc := Sloc (Decl);
6358 ("convention differs from that given#", Arg1);
6368 -- Give message if needed if we fall through those tests
6369 -- except on Relaxed_RM_Semantics where we let go: either this
6370 -- is a case accepted/ignored by other Ada compilers (e.g.
6371 -- a mix of Convention and Import), or another error will be
6372 -- generated later (e.g. using both Import and Export).
6374 if Err and not Relaxed_RM_Semantics then
6376 ("at most one Convention/Export/Import pragma is allowed",
6379 end Diagnose_Multiple_Pragmas;
6381 --------------------------------
6382 -- Set_Convention_From_Pragma --
6383 --------------------------------
6385 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6387 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6388 -- for an overridden dispatching operation. Technically this is
6389 -- an amendment and should only be done in Ada 2005 mode. However,
6390 -- this is clearly a mistake, since the problem that is addressed
6391 -- by this AI is that there is a clear gap in the RM.
6393 if Is_Dispatching_Operation (E)
6394 and then Present (Overridden_Operation (E))
6395 and then C /= Convention (Overridden_Operation (E))
6398 ("cannot change convention for overridden dispatching "
6399 & "operation", Arg1);
6402 -- Special checks for Convention_Stdcall
6404 if C = Convention_Stdcall then
6406 -- A dispatching call is not allowed. A dispatching subprogram
6407 -- cannot be used to interface to the Win32 API, so in fact
6408 -- this check does not impose any effective restriction.
6410 if Is_Dispatching_Operation (E) then
6411 Error_Msg_Sloc := Sloc (E);
6413 -- Note: make this unconditional so that if there is more
6414 -- than one call to which the pragma applies, we get a
6415 -- message for each call. Also don't use Error_Pragma,
6416 -- so that we get multiple messages.
6419 ("dispatching subprogram# cannot use Stdcall convention!",
6422 -- Subprograms are not allowed
6424 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
6428 and then Ekind (E) /= E_Variable
6430 -- An access to subprogram is also allowed
6434 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
6436 -- Allow internal call to set convention of subprogram type
6438 and then not (Ekind (E) = E_Subprogram_Type)
6441 ("second argument of pragma% must be subprogram (type)",
6446 -- Set the convention
6448 Set_Convention (E, C);
6449 Set_Has_Convention_Pragma (E);
6451 -- For the case of a record base type, also set the convention of
6452 -- any anonymous access types declared in the record which do not
6453 -- currently have a specified convention.
6455 if Is_Record_Type (E) and then Is_Base_Type (E) then
6460 Comp := First_Component (E);
6461 while Present (Comp) loop
6462 if Present (Etype (Comp))
6463 and then Ekind_In (Etype (Comp),
6464 E_Anonymous_Access_Type,
6465 E_Anonymous_Access_Subprogram_Type)
6466 and then not Has_Convention_Pragma (Comp)
6468 Set_Convention (Comp, C);
6471 Next_Component (Comp);
6476 -- Deal with incomplete/private type case, where underlying type
6477 -- is available, so set convention of that underlying type.
6479 if Is_Incomplete_Or_Private_Type (E)
6480 and then Present (Underlying_Type (E))
6482 Set_Convention (Underlying_Type (E), C);
6483 Set_Has_Convention_Pragma (Underlying_Type (E), True);
6486 -- A class-wide type should inherit the convention of the specific
6487 -- root type (although this isn't specified clearly by the RM).
6489 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
6490 Set_Convention (Class_Wide_Type (E), C);
6493 -- If the entity is a record type, then check for special case of
6494 -- C_Pass_By_Copy, which is treated the same as C except that the
6495 -- special record flag is set. This convention is only permitted
6496 -- on record types (see AI95-00131).
6498 if Cname = Name_C_Pass_By_Copy then
6499 if Is_Record_Type (E) then
6500 Set_C_Pass_By_Copy (Base_Type (E));
6501 elsif Is_Incomplete_Or_Private_Type (E)
6502 and then Is_Record_Type (Underlying_Type (E))
6504 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
6507 ("C_Pass_By_Copy convention allowed only for record type",
6512 -- If the entity is a derived boolean type, check for the special
6513 -- case of convention C, C++, or Fortran, where we consider any
6514 -- nonzero value to represent true.
6516 if Is_Discrete_Type (E)
6517 and then Root_Type (Etype (E)) = Standard_Boolean
6523 C = Convention_Fortran)
6525 Set_Nonzero_Is_True (Base_Type (E));
6527 end Set_Convention_From_Pragma;
6531 Comp_Unit : Unit_Number_Type;
6536 -- Start of processing for Process_Convention
6539 Check_At_Least_N_Arguments (2);
6540 Check_Optional_Identifier (Arg1, Name_Convention);
6541 Check_Arg_Is_Identifier (Arg1);
6542 Cname := Chars (Get_Pragma_Arg (Arg1));
6544 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6545 -- tested again below to set the critical flag).
6547 if Cname = Name_C_Pass_By_Copy then
6550 -- Otherwise we must have something in the standard convention list
6552 elsif Is_Convention_Name (Cname) then
6553 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6555 -- Otherwise warn on unrecognized convention
6558 if Warn_On_Export_Import then
6560 ("??unrecognized convention name, C assumed",
6561 Get_Pragma_Arg (Arg1));
6567 Check_Optional_Identifier (Arg2, Name_Entity);
6568 Check_Arg_Is_Local_Name (Arg2);
6570 Id := Get_Pragma_Arg (Arg2);
6573 if not Is_Entity_Name (Id) then
6574 Error_Pragma_Arg ("entity name required", Arg2);
6579 -- Set entity to return
6583 -- Ada_Pass_By_Copy special checking
6585 if C = Convention_Ada_Pass_By_Copy then
6586 if not Is_First_Subtype (E) then
6588 ("convention `Ada_Pass_By_Copy` only allowed for types",
6592 if Is_By_Reference_Type (E) then
6594 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6598 -- Ada_Pass_By_Reference special checking
6600 elsif C = Convention_Ada_Pass_By_Reference then
6601 if not Is_First_Subtype (E) then
6603 ("convention `Ada_Pass_By_Reference` only allowed for types",
6607 if Is_By_Copy_Type (E) then
6609 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6614 -- Go to renamed subprogram if present, since convention applies to
6615 -- the actual renamed entity, not to the renaming entity. If the
6616 -- subprogram is inherited, go to parent subprogram.
6618 if Is_Subprogram (E)
6619 and then Present (Alias (E))
6621 if Nkind (Parent (Declaration_Node (E))) =
6622 N_Subprogram_Renaming_Declaration
6624 if Scope (E) /= Scope (Alias (E)) then
6626 ("cannot apply pragma% to non-local entity&#", E);
6631 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6632 N_Private_Extension_Declaration)
6633 and then Scope (E) = Scope (Alias (E))
6637 -- Return the parent subprogram the entity was inherited from
6643 -- Check that we are not applying this to a specless body. Relax this
6644 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6646 if Is_Subprogram (E)
6647 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6648 and then not Relaxed_RM_Semantics
6651 ("pragma% requires separate spec and must come before body");
6654 -- Check that we are not applying this to a named constant
6656 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6657 Error_Msg_Name_1 := Pname;
6659 ("cannot apply pragma% to named constant!",
6660 Get_Pragma_Arg (Arg2));
6662 ("\supply appropriate type for&!", Arg2);
6665 if Ekind (E) = E_Enumeration_Literal then
6666 Error_Pragma ("enumeration literal not allowed for pragma%");
6669 -- Check for rep item appearing too early or too late
6671 if Etype (E) = Any_Type
6672 or else Rep_Item_Too_Early (E, N)
6676 elsif Present (Underlying_Type (E)) then
6677 E := Underlying_Type (E);
6680 if Rep_Item_Too_Late (E, N) then
6684 if Has_Convention_Pragma (E) then
6685 Diagnose_Multiple_Pragmas (E);
6687 elsif Convention (E) = Convention_Protected
6688 or else Ekind (Scope (E)) = E_Protected_Type
6691 ("a protected operation cannot be given a different convention",
6695 -- For Intrinsic, a subprogram is required
6697 if C = Convention_Intrinsic
6698 and then not Is_Subprogram_Or_Generic_Subprogram (E)
6701 ("second argument of pragma% must be a subprogram", Arg2);
6704 -- Deal with non-subprogram cases
6706 if not Is_Subprogram_Or_Generic_Subprogram (E) then
6707 Set_Convention_From_Pragma (E);
6711 -- The pragma must apply to a first subtype, but it can also
6712 -- apply to a generic type in a generic formal part, in which
6713 -- case it will also appear in the corresponding instance.
6715 if Is_Generic_Type (E) or else In_Instance then
6718 Check_First_Subtype (Arg2);
6721 Set_Convention_From_Pragma (Base_Type (E));
6723 -- For access subprograms, we must set the convention on the
6724 -- internally generated directly designated type as well.
6726 if Ekind (E) = E_Access_Subprogram_Type then
6727 Set_Convention_From_Pragma (Directly_Designated_Type (E));
6731 -- For the subprogram case, set proper convention for all homonyms
6732 -- in same scope and the same declarative part, i.e. the same
6733 -- compilation unit.
6736 Comp_Unit := Get_Source_Unit (E);
6737 Set_Convention_From_Pragma (E);
6739 -- Treat a pragma Import as an implicit body, and pragma import
6740 -- as implicit reference (for navigation in GPS).
6742 if Prag_Id = Pragma_Import then
6743 Generate_Reference (E, Id, 'b');
6745 -- For exported entities we restrict the generation of references
6746 -- to entities exported to foreign languages since entities
6747 -- exported to Ada do not provide further information to GPS and
6748 -- add undesired references to the output of the gnatxref tool.
6750 elsif Prag_Id = Pragma_Export
6751 and then Convention (E) /= Convention_Ada
6753 Generate_Reference (E, Id, 'i');
6756 -- If the pragma comes from an aspect, it only applies to the
6757 -- given entity, not its homonyms.
6759 if From_Aspect_Specification (N) then
6763 -- Otherwise Loop through the homonyms of the pragma argument's
6764 -- entity, an apply convention to those in the current scope.
6770 exit when No (E1) or else Scope (E1) /= Current_Scope;
6772 -- Ignore entry for which convention is already set
6774 if Has_Convention_Pragma (E1) then
6778 -- Do not set the pragma on inherited operations or on formal
6781 if Comes_From_Source (E1)
6782 and then Comp_Unit = Get_Source_Unit (E1)
6783 and then not Is_Formal_Subprogram (E1)
6784 and then Nkind (Original_Node (Parent (E1))) /=
6785 N_Full_Type_Declaration
6787 if Present (Alias (E1))
6788 and then Scope (E1) /= Scope (Alias (E1))
6791 ("cannot apply pragma% to non-local entity& declared#",
6795 Set_Convention_From_Pragma (E1);
6797 if Prag_Id = Pragma_Import then
6798 Generate_Reference (E1, Id, 'b');
6806 end Process_Convention;
6808 ----------------------------------------
6809 -- Process_Disable_Enable_Atomic_Sync --
6810 ----------------------------------------
6812 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
6814 Check_No_Identifiers;
6815 Check_At_Most_N_Arguments (1);
6817 -- Modeled internally as
6818 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6822 Pragma_Identifier =>
6823 Make_Identifier (Loc, Nam),
6824 Pragma_Argument_Associations => New_List (
6825 Make_Pragma_Argument_Association (Loc,
6827 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
6829 if Present (Arg1) then
6830 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
6834 end Process_Disable_Enable_Atomic_Sync;
6836 -------------------------------------------------
6837 -- Process_Extended_Import_Export_Internal_Arg --
6838 -------------------------------------------------
6840 procedure Process_Extended_Import_Export_Internal_Arg
6841 (Arg_Internal : Node_Id := Empty)
6844 if No (Arg_Internal) then
6845 Error_Pragma ("Internal parameter required for pragma%");
6848 if Nkind (Arg_Internal) = N_Identifier then
6851 elsif Nkind (Arg_Internal) = N_Operator_Symbol
6852 and then (Prag_Id = Pragma_Import_Function
6854 Prag_Id = Pragma_Export_Function)
6860 ("wrong form for Internal parameter for pragma%", Arg_Internal);
6863 Check_Arg_Is_Local_Name (Arg_Internal);
6864 end Process_Extended_Import_Export_Internal_Arg;
6866 --------------------------------------------------
6867 -- Process_Extended_Import_Export_Object_Pragma --
6868 --------------------------------------------------
6870 procedure Process_Extended_Import_Export_Object_Pragma
6871 (Arg_Internal : Node_Id;
6872 Arg_External : Node_Id;
6878 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6879 Def_Id := Entity (Arg_Internal);
6881 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
6883 ("pragma% must designate an object", Arg_Internal);
6886 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
6888 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
6891 ("previous Common/Psect_Object applies, pragma % not permitted",
6895 if Rep_Item_Too_Late (Def_Id, N) then
6899 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6901 if Present (Arg_Size) then
6902 Check_Arg_Is_External_Name (Arg_Size);
6905 -- Export_Object case
6907 if Prag_Id = Pragma_Export_Object then
6908 if not Is_Library_Level_Entity (Def_Id) then
6910 ("argument for pragma% must be library level entity",
6914 if Ekind (Current_Scope) = E_Generic_Package then
6915 Error_Pragma ("pragma& cannot appear in a generic unit");
6918 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
6920 ("exported object must have compile time known size",
6924 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
6925 Error_Msg_N ("??duplicate Export_Object pragma", N);
6927 Set_Exported (Def_Id, Arg_Internal);
6930 -- Import_Object case
6933 if Is_Concurrent_Type (Etype (Def_Id)) then
6935 ("cannot use pragma% for task/protected object",
6939 if Ekind (Def_Id) = E_Constant then
6941 ("cannot import a constant", Arg_Internal);
6944 if Warn_On_Export_Import
6945 and then Has_Discriminants (Etype (Def_Id))
6948 ("imported value must be initialized??", Arg_Internal);
6951 if Warn_On_Export_Import
6952 and then Is_Access_Type (Etype (Def_Id))
6955 ("cannot import object of an access type??", Arg_Internal);
6958 if Warn_On_Export_Import
6959 and then Is_Imported (Def_Id)
6961 Error_Msg_N ("??duplicate Import_Object pragma", N);
6963 -- Check for explicit initialization present. Note that an
6964 -- initialization generated by the code generator, e.g. for an
6965 -- access type, does not count here.
6967 elsif Present (Expression (Parent (Def_Id)))
6970 (Original_Node (Expression (Parent (Def_Id))))
6972 Error_Msg_Sloc := Sloc (Def_Id);
6974 ("imported entities cannot be initialized (RM B.1(24))",
6975 "\no initialization allowed for & declared#", Arg1);
6977 Set_Imported (Def_Id);
6978 Note_Possible_Modification (Arg_Internal, Sure => False);
6981 end Process_Extended_Import_Export_Object_Pragma;
6983 ------------------------------------------------------
6984 -- Process_Extended_Import_Export_Subprogram_Pragma --
6985 ------------------------------------------------------
6987 procedure Process_Extended_Import_Export_Subprogram_Pragma
6988 (Arg_Internal : Node_Id;
6989 Arg_External : Node_Id;
6990 Arg_Parameter_Types : Node_Id;
6991 Arg_Result_Type : Node_Id := Empty;
6992 Arg_Mechanism : Node_Id;
6993 Arg_Result_Mechanism : Node_Id := Empty)
6999 Ambiguous : Boolean;
7002 function Same_Base_Type
7004 Formal : Entity_Id) return Boolean;
7005 -- Determines if Ptype references the type of Formal. Note that only
7006 -- the base types need to match according to the spec. Ptype here is
7007 -- the argument from the pragma, which is either a type name, or an
7008 -- access attribute.
7010 --------------------
7011 -- Same_Base_Type --
7012 --------------------
7014 function Same_Base_Type
7016 Formal : Entity_Id) return Boolean
7018 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7022 -- Case where pragma argument is typ'Access
7024 if Nkind (Ptype) = N_Attribute_Reference
7025 and then Attribute_Name (Ptype) = Name_Access
7027 Pref := Prefix (Ptype);
7030 if not Is_Entity_Name (Pref)
7031 or else Entity (Pref) = Any_Type
7036 -- We have a match if the corresponding argument is of an
7037 -- anonymous access type, and its designated type matches the
7038 -- type of the prefix of the access attribute
7040 return Ekind (Ftyp) = E_Anonymous_Access_Type
7041 and then Base_Type (Entity (Pref)) =
7042 Base_Type (Etype (Designated_Type (Ftyp)));
7044 -- Case where pragma argument is a type name
7049 if not Is_Entity_Name (Ptype)
7050 or else Entity (Ptype) = Any_Type
7055 -- We have a match if the corresponding argument is of the type
7056 -- given in the pragma (comparing base types)
7058 return Base_Type (Entity (Ptype)) = Ftyp;
7062 -- Start of processing for
7063 -- Process_Extended_Import_Export_Subprogram_Pragma
7066 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7070 -- Loop through homonyms (overloadings) of the entity
7072 Hom_Id := Entity (Arg_Internal);
7073 while Present (Hom_Id) loop
7074 Def_Id := Get_Base_Subprogram (Hom_Id);
7076 -- We need a subprogram in the current scope
7078 if not Is_Subprogram (Def_Id)
7079 or else Scope (Def_Id) /= Current_Scope
7086 -- Pragma cannot apply to subprogram body
7088 if Is_Subprogram (Def_Id)
7089 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7093 ("pragma% requires separate spec"
7094 & " and must come before body");
7097 -- Test result type if given, note that the result type
7098 -- parameter can only be present for the function cases.
7100 if Present (Arg_Result_Type)
7101 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7105 elsif Etype (Def_Id) /= Standard_Void_Type
7107 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7111 -- Test parameter types if given. Note that this parameter
7112 -- has not been analyzed (and must not be, since it is
7113 -- semantic nonsense), so we get it as the parser left it.
7115 elsif Present (Arg_Parameter_Types) then
7116 Check_Matching_Types : declare
7121 Formal := First_Formal (Def_Id);
7123 if Nkind (Arg_Parameter_Types) = N_Null then
7124 if Present (Formal) then
7128 -- A list of one type, e.g. (List) is parsed as
7129 -- a parenthesized expression.
7131 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7132 and then Paren_Count (Arg_Parameter_Types) = 1
7135 or else Present (Next_Formal (Formal))
7140 Same_Base_Type (Arg_Parameter_Types, Formal);
7143 -- A list of more than one type is parsed as a aggregate
7145 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7146 and then Paren_Count (Arg_Parameter_Types) = 0
7148 Ptype := First (Expressions (Arg_Parameter_Types));
7149 while Present (Ptype) or else Present (Formal) loop
7152 or else not Same_Base_Type (Ptype, Formal)
7157 Next_Formal (Formal);
7162 -- Anything else is of the wrong form
7166 ("wrong form for Parameter_Types parameter",
7167 Arg_Parameter_Types);
7169 end Check_Matching_Types;
7172 -- Match is now False if the entry we found did not match
7173 -- either a supplied Parameter_Types or Result_Types argument
7179 -- Ambiguous case, the flag Ambiguous shows if we already
7180 -- detected this and output the initial messages.
7183 if not Ambiguous then
7185 Error_Msg_Name_1 := Pname;
7187 ("pragma% does not uniquely identify subprogram!",
7189 Error_Msg_Sloc := Sloc (Ent);
7190 Error_Msg_N ("matching subprogram #!", N);
7194 Error_Msg_Sloc := Sloc (Def_Id);
7195 Error_Msg_N ("matching subprogram #!", N);
7200 Hom_Id := Homonym (Hom_Id);
7203 -- See if we found an entry
7206 if not Ambiguous then
7207 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7209 ("pragma% cannot be given for generic subprogram");
7212 ("pragma% does not identify local subprogram");
7219 -- Import pragmas must be for imported entities
7221 if Prag_Id = Pragma_Import_Function
7223 Prag_Id = Pragma_Import_Procedure
7225 Prag_Id = Pragma_Import_Valued_Procedure
7227 if not Is_Imported (Ent) then
7229 ("pragma Import or Interface must precede pragma%");
7232 -- Here we have the Export case which can set the entity as exported
7234 -- But does not do so if the specified external name is null, since
7235 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7236 -- compatible) to request no external name.
7238 elsif Nkind (Arg_External) = N_String_Literal
7239 and then String_Length (Strval (Arg_External)) = 0
7243 -- In all other cases, set entity as exported
7246 Set_Exported (Ent, Arg_Internal);
7249 -- Special processing for Valued_Procedure cases
7251 if Prag_Id = Pragma_Import_Valued_Procedure
7253 Prag_Id = Pragma_Export_Valued_Procedure
7255 Formal := First_Formal (Ent);
7258 Error_Pragma ("at least one parameter required for pragma%");
7260 elsif Ekind (Formal) /= E_Out_Parameter then
7261 Error_Pragma ("first parameter must have mode out for pragma%");
7264 Set_Is_Valued_Procedure (Ent);
7268 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7270 -- Process Result_Mechanism argument if present. We have already
7271 -- checked that this is only allowed for the function case.
7273 if Present (Arg_Result_Mechanism) then
7274 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7277 -- Process Mechanism parameter if present. Note that this parameter
7278 -- is not analyzed, and must not be analyzed since it is semantic
7279 -- nonsense, so we get it in exactly as the parser left it.
7281 if Present (Arg_Mechanism) then
7289 -- A single mechanism association without a formal parameter
7290 -- name is parsed as a parenthesized expression. All other
7291 -- cases are parsed as aggregates, so we rewrite the single
7292 -- parameter case as an aggregate for consistency.
7294 if Nkind (Arg_Mechanism) /= N_Aggregate
7295 and then Paren_Count (Arg_Mechanism) = 1
7297 Rewrite (Arg_Mechanism,
7298 Make_Aggregate (Sloc (Arg_Mechanism),
7299 Expressions => New_List (
7300 Relocate_Node (Arg_Mechanism))));
7303 -- Case of only mechanism name given, applies to all formals
7305 if Nkind (Arg_Mechanism) /= N_Aggregate then
7306 Formal := First_Formal (Ent);
7307 while Present (Formal) loop
7308 Set_Mechanism_Value (Formal, Arg_Mechanism);
7309 Next_Formal (Formal);
7312 -- Case of list of mechanism associations given
7315 if Null_Record_Present (Arg_Mechanism) then
7317 ("inappropriate form for Mechanism parameter",
7321 -- Deal with positional ones first
7323 Formal := First_Formal (Ent);
7325 if Present (Expressions (Arg_Mechanism)) then
7326 Mname := First (Expressions (Arg_Mechanism));
7327 while Present (Mname) loop
7330 ("too many mechanism associations", Mname);
7333 Set_Mechanism_Value (Formal, Mname);
7334 Next_Formal (Formal);
7339 -- Deal with named entries
7341 if Present (Component_Associations (Arg_Mechanism)) then
7342 Massoc := First (Component_Associations (Arg_Mechanism));
7343 while Present (Massoc) loop
7344 Choice := First (Choices (Massoc));
7346 if Nkind (Choice) /= N_Identifier
7347 or else Present (Next (Choice))
7350 ("incorrect form for mechanism association",
7354 Formal := First_Formal (Ent);
7358 ("parameter name & not present", Choice);
7361 if Chars (Choice) = Chars (Formal) then
7363 (Formal, Expression (Massoc));
7365 -- Set entity on identifier (needed by ASIS)
7367 Set_Entity (Choice, Formal);
7372 Next_Formal (Formal);
7381 end Process_Extended_Import_Export_Subprogram_Pragma;
7383 --------------------------
7384 -- Process_Generic_List --
7385 --------------------------
7387 procedure Process_Generic_List is
7392 Check_No_Identifiers;
7393 Check_At_Least_N_Arguments (1);
7395 -- Check all arguments are names of generic units or instances
7398 while Present (Arg) loop
7399 Exp := Get_Pragma_Arg (Arg);
7402 if not Is_Entity_Name (Exp)
7404 (not Is_Generic_Instance (Entity (Exp))
7406 not Is_Generic_Unit (Entity (Exp)))
7409 ("pragma% argument must be name of generic unit/instance",
7415 end Process_Generic_List;
7417 ------------------------------------
7418 -- Process_Import_Predefined_Type --
7419 ------------------------------------
7421 procedure Process_Import_Predefined_Type is
7422 Loc : constant Source_Ptr := Sloc (N);
7424 Ftyp : Node_Id := Empty;
7430 String_To_Name_Buffer (Strval (Expression (Arg3)));
7433 Elmt := First_Elmt (Predefined_Float_Types);
7434 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7438 Ftyp := Node (Elmt);
7440 if Present (Ftyp) then
7442 -- Don't build a derived type declaration, because predefined C
7443 -- types have no declaration anywhere, so cannot really be named.
7444 -- Instead build a full type declaration, starting with an
7445 -- appropriate type definition is built
7447 if Is_Floating_Point_Type (Ftyp) then
7448 Def := Make_Floating_Point_Definition (Loc,
7449 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7450 Make_Real_Range_Specification (Loc,
7451 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7452 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7454 -- Should never have a predefined type we cannot handle
7457 raise Program_Error;
7460 -- Build and insert a Full_Type_Declaration, which will be
7461 -- analyzed as soon as this list entry has been analyzed.
7463 Decl := Make_Full_Type_Declaration (Loc,
7464 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7465 Type_Definition => Def);
7467 Insert_After (N, Decl);
7468 Mark_Rewrite_Insertion (Decl);
7471 Error_Pragma_Arg ("no matching type found for pragma%",
7474 end Process_Import_Predefined_Type;
7476 ---------------------------------
7477 -- Process_Import_Or_Interface --
7478 ---------------------------------
7480 procedure Process_Import_Or_Interface is
7486 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7487 -- pragma Import (Entity, "external name");
7489 if Relaxed_RM_Semantics
7490 and then Arg_Count = 2
7491 and then Prag_Id = Pragma_Import
7492 and then Nkind (Expression (Arg2)) = N_String_Literal
7495 Def_Id := Get_Pragma_Arg (Arg1);
7498 if not Is_Entity_Name (Def_Id) then
7499 Error_Pragma_Arg ("entity name required", Arg1);
7502 Def_Id := Entity (Def_Id);
7503 Kill_Size_Check_Code (Def_Id);
7504 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
7507 Process_Convention (C, Def_Id);
7509 -- A pragma that applies to a Ghost entity becomes Ghost for the
7510 -- purposes of legality checks and removal of ignored Ghost code.
7512 Mark_Pragma_As_Ghost (N, Def_Id);
7513 Kill_Size_Check_Code (Def_Id);
7514 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7517 -- Various error checks
7519 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7521 -- We do not permit Import to apply to a renaming declaration
7523 if Present (Renamed_Object (Def_Id)) then
7525 ("pragma% not allowed for object renaming", Arg2);
7527 -- User initialization is not allowed for imported object, but
7528 -- the object declaration may contain a default initialization,
7529 -- that will be discarded. Note that an explicit initialization
7530 -- only counts if it comes from source, otherwise it is simply
7531 -- the code generator making an implicit initialization explicit.
7533 elsif Present (Expression (Parent (Def_Id)))
7534 and then Comes_From_Source
7535 (Original_Node (Expression (Parent (Def_Id))))
7537 -- Set imported flag to prevent cascaded errors
7539 Set_Is_Imported (Def_Id);
7541 Error_Msg_Sloc := Sloc (Def_Id);
7543 ("no initialization allowed for declaration of& #",
7544 "\imported entities cannot be initialized (RM B.1(24))",
7548 -- If the pragma comes from an aspect specification the
7549 -- Is_Imported flag has already been set.
7551 if not From_Aspect_Specification (N) then
7552 Set_Imported (Def_Id);
7555 Process_Interface_Name (Def_Id, Arg3, Arg4);
7557 -- Note that we do not set Is_Public here. That's because we
7558 -- only want to set it if there is no address clause, and we
7559 -- don't know that yet, so we delay that processing till
7562 -- pragma Import completes deferred constants
7564 if Ekind (Def_Id) = E_Constant then
7565 Set_Has_Completion (Def_Id);
7568 -- It is not possible to import a constant of an unconstrained
7569 -- array type (e.g. string) because there is no simple way to
7570 -- write a meaningful subtype for it.
7572 if Is_Array_Type (Etype (Def_Id))
7573 and then not Is_Constrained (Etype (Def_Id))
7576 ("imported constant& must have a constrained subtype",
7581 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
7583 -- If the name is overloaded, pragma applies to all of the denoted
7584 -- entities in the same declarative part, unless the pragma comes
7585 -- from an aspect specification or was generated by the compiler
7586 -- (such as for pragma Provide_Shift_Operators).
7589 while Present (Hom_Id) loop
7591 Def_Id := Get_Base_Subprogram (Hom_Id);
7593 -- Ignore inherited subprograms because the pragma will apply
7594 -- to the parent operation, which is the one called.
7596 if Is_Overloadable (Def_Id)
7597 and then Present (Alias (Def_Id))
7601 -- If it is not a subprogram, it must be in an outer scope and
7602 -- pragma does not apply.
7604 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
7607 -- The pragma does not apply to primitives of interfaces
7609 elsif Is_Dispatching_Operation (Def_Id)
7610 and then Present (Find_Dispatching_Type (Def_Id))
7611 and then Is_Interface (Find_Dispatching_Type (Def_Id))
7615 -- Verify that the homonym is in the same declarative part (not
7616 -- just the same scope). If the pragma comes from an aspect
7617 -- specification we know that it is part of the declaration.
7619 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
7620 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
7621 and then not From_Aspect_Specification (N)
7626 -- If the pragma comes from an aspect specification the
7627 -- Is_Imported flag has already been set.
7629 if not From_Aspect_Specification (N) then
7630 Set_Imported (Def_Id);
7633 -- Reject an Import applied to an abstract subprogram
7635 if Is_Subprogram (Def_Id)
7636 and then Is_Abstract_Subprogram (Def_Id)
7638 Error_Msg_Sloc := Sloc (Def_Id);
7640 ("cannot import abstract subprogram& declared#",
7644 -- Special processing for Convention_Intrinsic
7646 if C = Convention_Intrinsic then
7648 -- Link_Name argument not allowed for intrinsic
7652 Set_Is_Intrinsic_Subprogram (Def_Id);
7654 -- If no external name is present, then check that this
7655 -- is a valid intrinsic subprogram. If an external name
7656 -- is present, then this is handled by the back end.
7659 Check_Intrinsic_Subprogram
7660 (Def_Id, Get_Pragma_Arg (Arg2));
7664 -- Verify that the subprogram does not have a completion
7665 -- through a renaming declaration. For other completions the
7666 -- pragma appears as a too late representation.
7669 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
7673 and then Nkind (Decl) = N_Subprogram_Declaration
7674 and then Present (Corresponding_Body (Decl))
7675 and then Nkind (Unit_Declaration_Node
7676 (Corresponding_Body (Decl))) =
7677 N_Subprogram_Renaming_Declaration
7679 Error_Msg_Sloc := Sloc (Def_Id);
7681 ("cannot import&, renaming already provided for "
7682 & "declaration #", N, Def_Id);
7686 -- If the pragma comes from an aspect specification, there
7687 -- must be an Import aspect specified as well. In the rare
7688 -- case where Import is set to False, the suprogram needs to
7689 -- have a local completion.
7692 Imp_Aspect : constant Node_Id :=
7693 Find_Aspect (Def_Id, Aspect_Import);
7697 if Present (Imp_Aspect)
7698 and then Present (Expression (Imp_Aspect))
7700 Expr := Expression (Imp_Aspect);
7701 Analyze_And_Resolve (Expr, Standard_Boolean);
7703 if Is_Entity_Name (Expr)
7704 and then Entity (Expr) = Standard_True
7706 Set_Has_Completion (Def_Id);
7709 -- If there is no expression, the default is True, as for
7710 -- all boolean aspects. Same for the older pragma.
7713 Set_Has_Completion (Def_Id);
7717 Process_Interface_Name (Def_Id, Arg3, Arg4);
7720 if Is_Compilation_Unit (Hom_Id) then
7722 -- Its possible homonyms are not affected by the pragma.
7723 -- Such homonyms might be present in the context of other
7724 -- units being compiled.
7728 elsif From_Aspect_Specification (N) then
7731 -- If the pragma was created by the compiler, then we don't
7732 -- want it to apply to other homonyms. This kind of case can
7733 -- occur when using pragma Provide_Shift_Operators, which
7734 -- generates implicit shift and rotate operators with Import
7735 -- pragmas that might apply to earlier explicit or implicit
7736 -- declarations marked with Import (for example, coming from
7737 -- an earlier pragma Provide_Shift_Operators for another type),
7738 -- and we don't generally want other homonyms being treated
7739 -- as imported or the pragma flagged as an illegal duplicate.
7741 elsif not Comes_From_Source (N) then
7745 Hom_Id := Homonym (Hom_Id);
7749 -- When the convention is Java or CIL, we also allow Import to
7750 -- be given for packages, generic packages, exceptions, record
7751 -- components, and access to subprograms.
7753 elsif (C = Convention_Java or else C = Convention_CIL)
7755 (Is_Package_Or_Generic_Package (Def_Id)
7756 or else Ekind (Def_Id) = E_Exception
7757 or else Ekind (Def_Id) = E_Access_Subprogram_Type
7758 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
7760 Set_Imported (Def_Id);
7761 Set_Is_Public (Def_Id);
7762 Process_Interface_Name (Def_Id, Arg3, Arg4);
7764 -- Import a CPP class
7766 elsif C = Convention_CPP
7767 and then (Is_Record_Type (Def_Id)
7768 or else Ekind (Def_Id) = E_Incomplete_Type)
7770 if Ekind (Def_Id) = E_Incomplete_Type then
7771 if Present (Full_View (Def_Id)) then
7772 Def_Id := Full_View (Def_Id);
7776 ("cannot import 'C'P'P type before full declaration seen",
7777 Get_Pragma_Arg (Arg2));
7779 -- Although we have reported the error we decorate it as
7780 -- CPP_Class to avoid reporting spurious errors
7782 Set_Is_CPP_Class (Def_Id);
7787 -- Types treated as CPP classes must be declared limited (note:
7788 -- this used to be a warning but there is no real benefit to it
7789 -- since we did effectively intend to treat the type as limited
7792 if not Is_Limited_Type (Def_Id) then
7794 ("imported 'C'P'P type must be limited",
7795 Get_Pragma_Arg (Arg2));
7798 if Etype (Def_Id) /= Def_Id
7799 and then not Is_CPP_Class (Root_Type (Def_Id))
7801 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
7804 Set_Is_CPP_Class (Def_Id);
7806 -- Imported CPP types must not have discriminants (because C++
7807 -- classes do not have discriminants).
7809 if Has_Discriminants (Def_Id) then
7811 ("imported 'C'P'P type cannot have discriminants",
7812 First (Discriminant_Specifications
7813 (Declaration_Node (Def_Id))));
7816 -- Check that components of imported CPP types do not have default
7817 -- expressions. For private types this check is performed when the
7818 -- full view is analyzed (see Process_Full_View).
7820 if not Is_Private_Type (Def_Id) then
7821 Check_CPP_Type_Has_No_Defaults (Def_Id);
7824 -- Import a CPP exception
7826 elsif C = Convention_CPP
7827 and then Ekind (Def_Id) = E_Exception
7831 ("'External_'Name arguments is required for 'Cpp exception",
7834 -- As only a string is allowed, Check_Arg_Is_External_Name
7837 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
7840 if Present (Arg4) then
7842 ("Link_Name argument not allowed for imported Cpp exception",
7846 -- Do not call Set_Interface_Name as the name of the exception
7847 -- shouldn't be modified (and in particular it shouldn't be
7848 -- the External_Name). For exceptions, the External_Name is the
7849 -- name of the RTTI structure.
7851 -- ??? Emit an error if pragma Import/Export_Exception is present
7853 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
7855 Check_Arg_Count (3);
7856 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
7858 Process_Import_Predefined_Type;
7862 ("second argument of pragma% must be object, subprogram "
7863 & "or incomplete type",
7867 -- If this pragma applies to a compilation unit, then the unit, which
7868 -- is a subprogram, does not require (or allow) a body. We also do
7869 -- not need to elaborate imported procedures.
7871 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
7873 Cunit : constant Node_Id := Parent (Parent (N));
7875 Set_Body_Required (Cunit, False);
7878 end Process_Import_Or_Interface;
7880 --------------------
7881 -- Process_Inline --
7882 --------------------
7884 procedure Process_Inline (Status : Inline_Status) is
7891 Ghost_Error_Posted : Boolean := False;
7892 -- Flag set when an error concerning the illegal mix of Ghost and
7893 -- non-Ghost subprograms is emitted.
7895 Ghost_Id : Entity_Id := Empty;
7896 -- The entity of the first Ghost subprogram encountered while
7897 -- processing the arguments of the pragma.
7899 procedure Make_Inline (Subp : Entity_Id);
7900 -- Subp is the defining unit name of the subprogram declaration. Set
7901 -- the flag, as well as the flag in the corresponding body, if there
7904 procedure Set_Inline_Flags (Subp : Entity_Id);
7905 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7906 -- Has_Pragma_Inline_Always for the Inline_Always case.
7908 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
7909 -- Returns True if it can be determined at this stage that inlining
7910 -- is not possible, for example if the body is available and contains
7911 -- exception handlers, we prevent inlining, since otherwise we can
7912 -- get undefined symbols at link time. This function also emits a
7913 -- warning if front-end inlining is enabled and the pragma appears
7916 -- ??? is business with link symbols still valid, or does it relate
7917 -- to front end ZCX which is being phased out ???
7919 ---------------------------
7920 -- Inlining_Not_Possible --
7921 ---------------------------
7923 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
7924 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7928 if Nkind (Decl) = N_Subprogram_Body then
7929 Stats := Handled_Statement_Sequence (Decl);
7930 return Present (Exception_Handlers (Stats))
7931 or else Present (At_End_Proc (Stats));
7933 elsif Nkind (Decl) = N_Subprogram_Declaration
7934 and then Present (Corresponding_Body (Decl))
7936 if Front_End_Inlining
7937 and then Analyzed (Corresponding_Body (Decl))
7939 Error_Msg_N ("pragma appears too late, ignored??", N);
7942 -- If the subprogram is a renaming as body, the body is just a
7943 -- call to the renamed subprogram, and inlining is trivially
7947 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
7948 N_Subprogram_Renaming_Declaration
7954 Handled_Statement_Sequence
7955 (Unit_Declaration_Node (Corresponding_Body (Decl)));
7958 Present (Exception_Handlers (Stats))
7959 or else Present (At_End_Proc (Stats));
7963 -- If body is not available, assume the best, the check is
7964 -- performed again when compiling enclosing package bodies.
7968 end Inlining_Not_Possible;
7974 procedure Make_Inline (Subp : Entity_Id) is
7975 Kind : constant Entity_Kind := Ekind (Subp);
7976 Inner_Subp : Entity_Id := Subp;
7979 -- Ignore if bad type, avoid cascaded error
7981 if Etype (Subp) = Any_Type then
7985 -- If inlining is not possible, for now do not treat as an error
7987 elsif Status /= Suppressed
7988 and then Inlining_Not_Possible (Subp)
7993 -- Here we have a candidate for inlining, but we must exclude
7994 -- derived operations. Otherwise we would end up trying to inline
7995 -- a phantom declaration, and the result would be to drag in a
7996 -- body which has no direct inlining associated with it. That
7997 -- would not only be inefficient but would also result in the
7998 -- backend doing cross-unit inlining in cases where it was
7999 -- definitely inappropriate to do so.
8001 -- However, a simple Comes_From_Source test is insufficient, since
8002 -- we do want to allow inlining of generic instances which also do
8003 -- not come from source. We also need to recognize specs generated
8004 -- by the front-end for bodies that carry the pragma. Finally,
8005 -- predefined operators do not come from source but are not
8006 -- inlineable either.
8008 elsif Is_Generic_Instance (Subp)
8009 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8013 elsif not Comes_From_Source (Subp)
8014 and then Scope (Subp) /= Standard_Standard
8020 -- The referenced entity must either be the enclosing entity, or
8021 -- an entity declared within the current open scope.
8023 if Present (Scope (Subp))
8024 and then Scope (Subp) /= Current_Scope
8025 and then Subp /= Current_Scope
8028 ("argument of% must be entity in current scope", Assoc);
8032 -- Processing for procedure, operator or function. If subprogram
8033 -- is aliased (as for an instance) indicate that the renamed
8034 -- entity (if declared in the same unit) is inlined.
8036 if Is_Subprogram (Subp) then
8037 Inner_Subp := Ultimate_Alias (Inner_Subp);
8039 if In_Same_Source_Unit (Subp, Inner_Subp) then
8040 Set_Inline_Flags (Inner_Subp);
8042 Decl := Parent (Parent (Inner_Subp));
8044 if Nkind (Decl) = N_Subprogram_Declaration
8045 and then Present (Corresponding_Body (Decl))
8047 Set_Inline_Flags (Corresponding_Body (Decl));
8049 elsif Is_Generic_Instance (Subp) then
8051 -- Indicate that the body needs to be created for
8052 -- inlining subsequent calls. The instantiation node
8053 -- follows the declaration of the wrapper package
8056 if Scope (Subp) /= Standard_Standard
8058 Need_Subprogram_Instance_Body
8059 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
8065 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8066 -- appear in a formal part to apply to a formal subprogram.
8067 -- Do not apply check within an instance or a formal package
8068 -- the test will have been applied to the original generic.
8070 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8071 and then List_Containing (Decl) = List_Containing (N)
8072 and then not In_Instance
8075 ("Inline cannot apply to a formal subprogram", N);
8077 -- If Subp is a renaming, it is the renamed entity that
8078 -- will appear in any call, and be inlined. However, for
8079 -- ASIS uses it is convenient to indicate that the renaming
8080 -- itself is an inlined subprogram, so that some gnatcheck
8081 -- rules can be applied in the absence of expansion.
8083 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8084 Set_Inline_Flags (Subp);
8090 -- For a generic subprogram set flag as well, for use at the point
8091 -- of instantiation, to determine whether the body should be
8094 elsif Is_Generic_Subprogram (Subp) then
8095 Set_Inline_Flags (Subp);
8098 -- Literals are by definition inlined
8100 elsif Kind = E_Enumeration_Literal then
8103 -- Anything else is an error
8107 ("expect subprogram name for pragma%", Assoc);
8111 ----------------------
8112 -- Set_Inline_Flags --
8113 ----------------------
8115 procedure Set_Inline_Flags (Subp : Entity_Id) is
8117 -- First set the Has_Pragma_XXX flags and issue the appropriate
8118 -- errors and warnings for suspicious combinations.
8120 if Prag_Id = Pragma_No_Inline then
8121 if Has_Pragma_Inline_Always (Subp) then
8123 ("Inline_Always and No_Inline are mutually exclusive", N);
8124 elsif Has_Pragma_Inline (Subp) then
8126 ("Inline and No_Inline both specified for& ??",
8127 N, Entity (Subp_Id));
8130 Set_Has_Pragma_No_Inline (Subp);
8132 if Prag_Id = Pragma_Inline_Always then
8133 if Has_Pragma_No_Inline (Subp) then
8135 ("Inline_Always and No_Inline are mutually exclusive",
8139 Set_Has_Pragma_Inline_Always (Subp);
8141 if Has_Pragma_No_Inline (Subp) then
8143 ("Inline and No_Inline both specified for& ??",
8144 N, Entity (Subp_Id));
8148 if not Has_Pragma_Inline (Subp) then
8149 Set_Has_Pragma_Inline (Subp);
8153 -- Then adjust the Is_Inlined flag. It can never be set if the
8154 -- subprogram is subject to pragma No_Inline.
8158 Set_Is_Inlined (Subp, False);
8162 if not Has_Pragma_No_Inline (Subp) then
8163 Set_Is_Inlined (Subp, True);
8167 -- A pragma that applies to a Ghost entity becomes Ghost for the
8168 -- purposes of legality checks and removal of ignored Ghost code.
8170 Mark_Pragma_As_Ghost (N, Subp);
8172 -- Capture the entity of the first Ghost subprogram being
8173 -- processed for error detection purposes.
8175 if Is_Ghost_Entity (Subp) then
8176 if No (Ghost_Id) then
8180 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8181 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8183 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
8184 Ghost_Error_Posted := True;
8186 Error_Msg_Name_1 := Pname;
8188 ("pragma % cannot mention ghost and non-ghost subprograms",
8191 Error_Msg_Sloc := Sloc (Ghost_Id);
8192 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
8194 Error_Msg_Sloc := Sloc (Subp);
8195 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
8197 end Set_Inline_Flags;
8199 -- Start of processing for Process_Inline
8202 Check_No_Identifiers;
8203 Check_At_Least_N_Arguments (1);
8205 if Status = Enabled then
8206 Inline_Processing_Required := True;
8210 while Present (Assoc) loop
8211 Subp_Id := Get_Pragma_Arg (Assoc);
8215 if Is_Entity_Name (Subp_Id) then
8216 Subp := Entity (Subp_Id);
8218 if Subp = Any_Id then
8220 -- If previous error, avoid cascaded errors
8222 Check_Error_Detected;
8228 -- For the pragma case, climb homonym chain. This is
8229 -- what implements allowing the pragma in the renaming
8230 -- case, with the result applying to the ancestors, and
8231 -- also allows Inline to apply to all previous homonyms.
8233 if not From_Aspect_Specification (N) then
8234 while Present (Homonym (Subp))
8235 and then Scope (Homonym (Subp)) = Current_Scope
8237 Make_Inline (Homonym (Subp));
8238 Subp := Homonym (Subp);
8245 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
8252 ----------------------------
8253 -- Process_Interface_Name --
8254 ----------------------------
8256 procedure Process_Interface_Name
8257 (Subprogram_Def : Entity_Id;
8263 String_Val : String_Id;
8265 procedure Check_Form_Of_Interface_Name
8267 Ext_Name_Case : Boolean);
8268 -- SN is a string literal node for an interface name. This routine
8269 -- performs some minimal checks that the name is reasonable. In
8270 -- particular that no spaces or other obviously incorrect characters
8271 -- appear. This is only a warning, since any characters are allowed.
8272 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8274 ----------------------------------
8275 -- Check_Form_Of_Interface_Name --
8276 ----------------------------------
8278 procedure Check_Form_Of_Interface_Name
8280 Ext_Name_Case : Boolean)
8282 S : constant String_Id := Strval (Expr_Value_S (SN));
8283 SL : constant Nat := String_Length (S);
8288 Error_Msg_N ("interface name cannot be null string", SN);
8291 for J in 1 .. SL loop
8292 C := Get_String_Char (S, J);
8294 -- Look for dubious character and issue unconditional warning.
8295 -- Definitely dubious if not in character range.
8297 if not In_Character_Range (C)
8299 -- For all cases except CLI target,
8300 -- commas, spaces and slashes are dubious (in CLI, we use
8301 -- commas and backslashes in external names to specify
8302 -- assembly version and public key, while slashes and spaces
8303 -- can be used in names to mark nested classes and
8306 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
8307 and then (Get_Character (C) = ','
8309 Get_Character (C) = '\'))
8310 or else (VM_Target /= CLI_Target
8311 and then (Get_Character (C) = ' '
8313 Get_Character (C) = '/'))
8316 ("??interface name contains illegal character",
8317 Sloc (SN) + Source_Ptr (J));
8320 end Check_Form_Of_Interface_Name;
8322 -- Start of processing for Process_Interface_Name
8325 if No (Link_Arg) then
8326 if No (Ext_Arg) then
8327 if VM_Target = CLI_Target
8328 and then Ekind (Subprogram_Def) = E_Package
8329 and then Nkind (Parent (Subprogram_Def)) =
8330 N_Package_Specification
8331 and then Present (Generic_Parent (Parent (Subprogram_Def)))
8336 (Generic_Parent (Parent (Subprogram_Def))));
8341 elsif Chars (Ext_Arg) = Name_Link_Name then
8343 Link_Nam := Expression (Ext_Arg);
8346 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8347 Ext_Nam := Expression (Ext_Arg);
8352 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8353 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8354 Ext_Nam := Expression (Ext_Arg);
8355 Link_Nam := Expression (Link_Arg);
8358 -- Check expressions for external name and link name are static
8360 if Present (Ext_Nam) then
8361 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8362 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
8364 -- Verify that external name is not the name of a local entity,
8365 -- which would hide the imported one and could lead to run-time
8366 -- surprises. The problem can only arise for entities declared in
8367 -- a package body (otherwise the external name is fully qualified
8368 -- and will not conflict).
8376 if Prag_Id = Pragma_Import then
8377 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8379 E := Entity_Id (Get_Name_Table_Int (Nam));
8381 if Nam /= Chars (Subprogram_Def)
8382 and then Present (E)
8383 and then not Is_Overloadable (E)
8384 and then Is_Immediately_Visible (E)
8385 and then not Is_Imported (E)
8386 and then Ekind (Scope (E)) = E_Package
8389 while Present (Par) loop
8390 if Nkind (Par) = N_Package_Body then
8391 Error_Msg_Sloc := Sloc (E);
8393 ("imported entity is hidden by & declared#",
8398 Par := Parent (Par);
8405 if Present (Link_Nam) then
8406 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8407 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
8410 -- If there is no link name, just set the external name
8412 if No (Link_Nam) then
8413 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8415 -- For the Link_Name case, the given literal is preceded by an
8416 -- asterisk, which indicates to GCC that the given name should be
8417 -- taken literally, and in particular that no prepending of
8418 -- underlines should occur, even in systems where this is the
8424 if VM_Target = No_VM then
8425 Store_String_Char (Get_Char_Code ('*'));
8428 String_Val := Strval (Expr_Value_S (Link_Nam));
8429 Store_String_Chars (String_Val);
8431 Make_String_Literal (Sloc (Link_Nam),
8432 Strval => End_String);
8435 -- Set the interface name. If the entity is a generic instance, use
8436 -- its alias, which is the callable entity.
8438 if Is_Generic_Instance (Subprogram_Def) then
8439 Set_Encoded_Interface_Name
8440 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8442 Set_Encoded_Interface_Name
8443 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
8446 -- We allow duplicated export names in CIL/Java, as they are always
8447 -- enclosed in a namespace that differentiates them, and overloaded
8448 -- entities are supported by the VM.
8450 if Convention (Subprogram_Def) /= Convention_CIL
8452 Convention (Subprogram_Def) /= Convention_Java
8454 Check_Duplicated_Export_Name (Link_Nam);
8456 end Process_Interface_Name;
8458 -----------------------------------------
8459 -- Process_Interrupt_Or_Attach_Handler --
8460 -----------------------------------------
8462 procedure Process_Interrupt_Or_Attach_Handler is
8463 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
8464 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
8465 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
8468 -- A pragma that applies to a Ghost entity becomes Ghost for the
8469 -- purposes of legality checks and removal of ignored Ghost code.
8471 Mark_Pragma_As_Ghost (N, Handler_Proc);
8472 Set_Is_Interrupt_Handler (Handler_Proc);
8474 -- If the pragma is not associated with a handler procedure within a
8475 -- protected type, then it must be for a nonprotected procedure for
8476 -- the AAMP target, in which case we don't associate a representation
8477 -- item with the procedure's scope.
8479 if Ekind (Proc_Scope) = E_Protected_Type then
8480 if Prag_Id = Pragma_Interrupt_Handler
8482 Prag_Id = Pragma_Attach_Handler
8484 Record_Rep_Item (Proc_Scope, N);
8487 end Process_Interrupt_Or_Attach_Handler;
8489 --------------------------------------------------
8490 -- Process_Restrictions_Or_Restriction_Warnings --
8491 --------------------------------------------------
8493 -- Note: some of the simple identifier cases were handled in par-prag,
8494 -- but it is harmless (and more straightforward) to simply handle all
8495 -- cases here, even if it means we repeat a bit of work in some cases.
8497 procedure Process_Restrictions_Or_Restriction_Warnings
8501 R_Id : Restriction_Id;
8507 -- Ignore all Restrictions pragmas in CodePeer mode
8509 if CodePeer_Mode then
8513 Check_Ada_83_Warning;
8514 Check_At_Least_N_Arguments (1);
8515 Check_Valid_Configuration_Pragma;
8518 while Present (Arg) loop
8520 Expr := Get_Pragma_Arg (Arg);
8522 -- Case of no restriction identifier present
8524 if Id = No_Name then
8525 if Nkind (Expr) /= N_Identifier then
8527 ("invalid form for restriction", Arg);
8532 (Process_Restriction_Synonyms (Expr));
8534 if R_Id not in All_Boolean_Restrictions then
8535 Error_Msg_Name_1 := Pname;
8537 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8539 -- Check for possible misspelling
8541 for J in Restriction_Id loop
8543 Rnm : constant String := Restriction_Id'Image (J);
8546 Name_Buffer (1 .. Rnm'Length) := Rnm;
8547 Name_Len := Rnm'Length;
8548 Set_Casing (All_Lower_Case);
8550 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8552 (Identifier_Casing (Current_Source_File));
8553 Error_Msg_String (1 .. Rnm'Length) :=
8554 Name_Buffer (1 .. Name_Len);
8555 Error_Msg_Strlen := Rnm'Length;
8556 Error_Msg_N -- CODEFIX
8557 ("\possible misspelling of ""~""",
8558 Get_Pragma_Arg (Arg));
8567 if Implementation_Restriction (R_Id) then
8568 Check_Restriction (No_Implementation_Restrictions, Arg);
8571 -- Special processing for No_Elaboration_Code restriction
8573 if R_Id = No_Elaboration_Code then
8575 -- Restriction is only recognized within a configuration
8576 -- pragma file, or within a unit of the main extended
8577 -- program. Note: the test for Main_Unit is needed to
8578 -- properly include the case of configuration pragma files.
8580 if not (Current_Sem_Unit = Main_Unit
8581 or else In_Extended_Main_Source_Unit (N))
8585 -- Don't allow in a subunit unless already specified in
8588 elsif Nkind (Parent (N)) = N_Compilation_Unit
8589 and then Nkind (Unit (Parent (N))) = N_Subunit
8590 and then not Restriction_Active (No_Elaboration_Code)
8593 ("invalid specification of ""No_Elaboration_Code""",
8596 ("\restriction cannot be specified in a subunit", N);
8598 ("\unless also specified in body or spec", N);
8601 -- If we accept a No_Elaboration_Code restriction, then it
8602 -- needs to be added to the configuration restriction set so
8603 -- that we get proper application to other units in the main
8604 -- extended source as required.
8607 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
8611 -- If this is a warning, then set the warning unless we already
8612 -- have a real restriction active (we never want a warning to
8613 -- override a real restriction).
8616 if not Restriction_Active (R_Id) then
8617 Set_Restriction (R_Id, N);
8618 Restriction_Warnings (R_Id) := True;
8621 -- If real restriction case, then set it and make sure that the
8622 -- restriction warning flag is off, since a real restriction
8623 -- always overrides a warning.
8626 Set_Restriction (R_Id, N);
8627 Restriction_Warnings (R_Id) := False;
8630 -- Check for obsolescent restrictions in Ada 2005 mode
8633 and then Ada_Version >= Ada_2005
8634 and then (R_Id = No_Asynchronous_Control
8636 R_Id = No_Unchecked_Deallocation
8638 R_Id = No_Unchecked_Conversion)
8640 Check_Restriction (No_Obsolescent_Features, N);
8643 -- A very special case that must be processed here: pragma
8644 -- Restrictions (No_Exceptions) turns off all run-time
8645 -- checking. This is a bit dubious in terms of the formal
8646 -- language definition, but it is what is intended by RM
8647 -- H.4(12). Restriction_Warnings never affects generated code
8648 -- so this is done only in the real restriction case.
8650 -- Atomic_Synchronization is not a real check, so it is not
8651 -- affected by this processing).
8653 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8654 -- run-time checks in CodePeer and GNATprove modes: we want to
8655 -- generate checks for analysis purposes, as set respectively
8656 -- by -gnatC and -gnatd.F
8659 and then not (CodePeer_Mode or GNATprove_Mode)
8660 and then R_Id = No_Exceptions
8662 for J in Scope_Suppress.Suppress'Range loop
8663 if J /= Atomic_Synchronization then
8664 Scope_Suppress.Suppress (J) := True;
8669 -- Case of No_Dependence => unit-name. Note that the parser
8670 -- already made the necessary entry in the No_Dependence table.
8672 elsif Id = Name_No_Dependence then
8673 if not OK_No_Dependence_Unit_Name (Expr) then
8677 -- Case of No_Specification_Of_Aspect => aspect-identifier
8679 elsif Id = Name_No_Specification_Of_Aspect then
8684 if Nkind (Expr) /= N_Identifier then
8687 A_Id := Get_Aspect_Id (Chars (Expr));
8690 if A_Id = No_Aspect then
8691 Error_Pragma_Arg ("invalid restriction name", Arg);
8693 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
8697 -- Case of No_Use_Of_Attribute => attribute-identifier
8699 elsif Id = Name_No_Use_Of_Attribute then
8700 if Nkind (Expr) /= N_Identifier
8701 or else not Is_Attribute_Name (Chars (Expr))
8703 Error_Msg_N ("unknown attribute name??", Expr);
8706 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
8709 -- Case of No_Use_Of_Entity => fully-qualified-name
8711 elsif Id = Name_No_Use_Of_Entity then
8713 -- Restriction is only recognized within a configuration
8714 -- pragma file, or within a unit of the main extended
8715 -- program. Note: the test for Main_Unit is needed to
8716 -- properly include the case of configuration pragma files.
8718 if Current_Sem_Unit = Main_Unit
8719 or else In_Extended_Main_Source_Unit (N)
8721 if not OK_No_Dependence_Unit_Name (Expr) then
8722 Error_Msg_N ("wrong form for entity name", Expr);
8724 Set_Restriction_No_Use_Of_Entity
8725 (Expr, Warn, No_Profile);
8729 -- Case of No_Use_Of_Pragma => pragma-identifier
8731 elsif Id = Name_No_Use_Of_Pragma then
8732 if Nkind (Expr) /= N_Identifier
8733 or else not Is_Pragma_Name (Chars (Expr))
8735 Error_Msg_N ("unknown pragma name??", Expr);
8737 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
8740 -- All other cases of restriction identifier present
8743 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
8744 Analyze_And_Resolve (Expr, Any_Integer);
8746 if R_Id not in All_Parameter_Restrictions then
8748 ("invalid restriction parameter identifier", Arg);
8750 elsif not Is_OK_Static_Expression (Expr) then
8751 Flag_Non_Static_Expr
8752 ("value must be static expression!", Expr);
8755 elsif not Is_Integer_Type (Etype (Expr))
8756 or else Expr_Value (Expr) < 0
8759 ("value must be non-negative integer", Arg);
8762 -- Restriction pragma is active
8764 Val := Expr_Value (Expr);
8766 if not UI_Is_In_Int_Range (Val) then
8768 ("pragma ignored, value too large??", Arg);
8771 -- Warning case. If the real restriction is active, then we
8772 -- ignore the request, since warning never overrides a real
8773 -- restriction. Otherwise we set the proper warning. Note that
8774 -- this circuit sets the warning again if it is already set,
8775 -- which is what we want, since the constant may have changed.
8778 if not Restriction_Active (R_Id) then
8780 (R_Id, N, Integer (UI_To_Int (Val)));
8781 Restriction_Warnings (R_Id) := True;
8784 -- Real restriction case, set restriction and make sure warning
8785 -- flag is off since real restriction always overrides warning.
8788 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
8789 Restriction_Warnings (R_Id) := False;
8795 end Process_Restrictions_Or_Restriction_Warnings;
8797 ---------------------------------
8798 -- Process_Suppress_Unsuppress --
8799 ---------------------------------
8801 -- Note: this procedure makes entries in the check suppress data
8802 -- structures managed by Sem. See spec of package Sem for full
8803 -- details on how we handle recording of check suppression.
8805 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
8810 In_Package_Spec : constant Boolean :=
8811 Is_Package_Or_Generic_Package (Current_Scope)
8812 and then not In_Package_Body (Current_Scope);
8814 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
8815 -- Used to suppress a single check on the given entity
8817 --------------------------------
8818 -- Suppress_Unsuppress_Echeck --
8819 --------------------------------
8821 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
8823 -- Check for error of trying to set atomic synchronization for
8824 -- a non-atomic variable.
8826 if C = Atomic_Synchronization
8827 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
8830 ("pragma & requires atomic type or variable",
8831 Pragma_Identifier (Original_Node (N)));
8834 Set_Checks_May_Be_Suppressed (E);
8836 if In_Package_Spec then
8837 Push_Global_Suppress_Stack_Entry
8840 Suppress => Suppress_Case);
8842 Push_Local_Suppress_Stack_Entry
8845 Suppress => Suppress_Case);
8848 -- If this is a first subtype, and the base type is distinct,
8849 -- then also set the suppress flags on the base type.
8851 if Is_First_Subtype (E) and then Etype (E) /= E then
8852 Suppress_Unsuppress_Echeck (Etype (E), C);
8854 end Suppress_Unsuppress_Echeck;
8856 -- Start of processing for Process_Suppress_Unsuppress
8859 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
8860 -- on user code: we want to generate checks for analysis purposes, as
8861 -- set respectively by -gnatC and -gnatd.F
8863 if Comes_From_Source (N)
8864 and then (CodePeer_Mode or GNATprove_Mode)
8869 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8870 -- declarative part or a package spec (RM 11.5(5)).
8872 if not Is_Configuration_Pragma then
8873 Check_Is_In_Decl_Part_Or_Package_Spec;
8876 Check_At_Least_N_Arguments (1);
8877 Check_At_Most_N_Arguments (2);
8878 Check_No_Identifier (Arg1);
8879 Check_Arg_Is_Identifier (Arg1);
8881 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
8883 if C = No_Check_Id then
8885 ("argument of pragma% is not valid check name", Arg1);
8888 -- Warn that suppress of Elaboration_Check has no effect in SPARK
8890 if C = Elaboration_Check and then SPARK_Mode = On then
8892 ("Suppress of Elaboration_Check ignored in SPARK??",
8893 "\elaboration checking rules are statically enforced "
8894 & "(SPARK RM 7.7)", Arg1);
8897 -- One-argument case
8899 if Arg_Count = 1 then
8901 -- Make an entry in the local scope suppress table. This is the
8902 -- table that directly shows the current value of the scope
8903 -- suppress check for any check id value.
8905 if C = All_Checks then
8907 -- For All_Checks, we set all specific predefined checks with
8908 -- the exception of Elaboration_Check, which is handled
8909 -- specially because of not wanting All_Checks to have the
8910 -- effect of deactivating static elaboration order processing.
8911 -- Atomic_Synchronization is also not affected, since this is
8912 -- not a real check.
8914 for J in Scope_Suppress.Suppress'Range loop
8915 if J /= Elaboration_Check
8917 J /= Atomic_Synchronization
8919 Scope_Suppress.Suppress (J) := Suppress_Case;
8923 -- If not All_Checks, and predefined check, then set appropriate
8924 -- scope entry. Note that we will set Elaboration_Check if this
8925 -- is explicitly specified. Atomic_Synchronization is allowed
8926 -- only if internally generated and entity is atomic.
8928 elsif C in Predefined_Check_Id
8929 and then (not Comes_From_Source (N)
8930 or else C /= Atomic_Synchronization)
8932 Scope_Suppress.Suppress (C) := Suppress_Case;
8935 -- Also make an entry in the Local_Entity_Suppress table
8937 Push_Local_Suppress_Stack_Entry
8940 Suppress => Suppress_Case);
8942 -- Case of two arguments present, where the check is suppressed for
8943 -- a specified entity (given as the second argument of the pragma)
8946 -- This is obsolescent in Ada 2005 mode
8948 if Ada_Version >= Ada_2005 then
8949 Check_Restriction (No_Obsolescent_Features, Arg2);
8952 Check_Optional_Identifier (Arg2, Name_On);
8953 E_Id := Get_Pragma_Arg (Arg2);
8956 if not Is_Entity_Name (E_Id) then
8958 ("second argument of pragma% must be entity name", Arg2);
8967 -- A pragma that applies to a Ghost entity becomes Ghost for the
8968 -- purposes of legality checks and removal of ignored Ghost code.
8970 Mark_Pragma_As_Ghost (N, E);
8972 -- Enforce RM 11.5(7) which requires that for a pragma that
8973 -- appears within a package spec, the named entity must be
8974 -- within the package spec. We allow the package name itself
8975 -- to be mentioned since that makes sense, although it is not
8976 -- strictly allowed by 11.5(7).
8979 and then E /= Current_Scope
8980 and then Scope (E) /= Current_Scope
8983 ("entity in pragma% is not in package spec (RM 11.5(7))",
8987 -- Loop through homonyms. As noted below, in the case of a package
8988 -- spec, only homonyms within the package spec are considered.
8991 Suppress_Unsuppress_Echeck (E, C);
8993 if Is_Generic_Instance (E)
8994 and then Is_Subprogram (E)
8995 and then Present (Alias (E))
8997 Suppress_Unsuppress_Echeck (Alias (E), C);
9000 -- Move to next homonym if not aspect spec case
9002 exit when From_Aspect_Specification (N);
9006 -- If we are within a package specification, the pragma only
9007 -- applies to homonyms in the same scope.
9009 exit when In_Package_Spec
9010 and then Scope (E) /= Current_Scope;
9013 end Process_Suppress_Unsuppress;
9015 -------------------------------
9016 -- Record_Independence_Check --
9017 -------------------------------
9019 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9021 -- For GCC back ends the validation is done a priori
9023 if VM_Target = No_VM and then not AAMP_On_Target then
9027 Independence_Checks.Append ((N, E));
9028 end Record_Independence_Check;
9034 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9036 if Is_Imported (E) then
9038 ("cannot export entity& that was previously imported", Arg);
9040 elsif Present (Address_Clause (E))
9041 and then not Relaxed_RM_Semantics
9044 ("cannot export entity& that has an address clause", Arg);
9047 Set_Is_Exported (E);
9049 -- Generate a reference for entity explicitly, because the
9050 -- identifier may be overloaded and name resolution will not
9053 Generate_Reference (E, Arg);
9055 -- Deal with exporting non-library level entity
9057 if not Is_Library_Level_Entity (E) then
9059 -- Not allowed at all for subprograms
9061 if Is_Subprogram (E) then
9062 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9064 -- Otherwise set public and statically allocated
9068 Set_Is_Statically_Allocated (E);
9070 -- Warn if the corresponding W flag is set
9072 if Warn_On_Export_Import
9074 -- Only do this for something that was in the source. Not
9075 -- clear if this can be False now (there used for sure to be
9076 -- cases on some systems where it was False), but anyway the
9077 -- test is harmless if not needed, so it is retained.
9079 and then Comes_From_Source (Arg)
9082 ("?x?& has been made static as a result of Export",
9085 ("\?x?this usage is non-standard and non-portable",
9091 if Warn_On_Export_Import and then Is_Type (E) then
9092 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9095 if Warn_On_Export_Import and Inside_A_Generic then
9097 ("all instances of& will have the same external name?x?",
9102 ----------------------------------------------
9103 -- Set_Extended_Import_Export_External_Name --
9104 ----------------------------------------------
9106 procedure Set_Extended_Import_Export_External_Name
9107 (Internal_Ent : Entity_Id;
9108 Arg_External : Node_Id)
9110 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9114 if No (Arg_External) then
9118 Check_Arg_Is_External_Name (Arg_External);
9120 if Nkind (Arg_External) = N_String_Literal then
9121 if String_Length (Strval (Arg_External)) = 0 then
9124 New_Name := Adjust_External_Name_Case (Arg_External);
9127 elsif Nkind (Arg_External) = N_Identifier then
9128 New_Name := Get_Default_External_Name (Arg_External);
9130 -- Check_Arg_Is_External_Name should let through only identifiers and
9131 -- string literals or static string expressions (which are folded to
9132 -- string literals).
9135 raise Program_Error;
9138 -- If we already have an external name set (by a prior normal Import
9139 -- or Export pragma), then the external names must match
9141 if Present (Interface_Name (Internal_Ent)) then
9143 -- Ignore mismatching names in CodePeer mode, to support some
9144 -- old compilers which would export the same procedure under
9145 -- different names, e.g:
9147 -- pragma Export_Procedure (P, "a");
9148 -- pragma Export_Procedure (P, "b");
9150 if CodePeer_Mode then
9154 Check_Matching_Internal_Names : declare
9155 S1 : constant String_Id := Strval (Old_Name);
9156 S2 : constant String_Id := Strval (New_Name);
9159 pragma No_Return (Mismatch);
9160 -- Called if names do not match
9166 procedure Mismatch is
9168 Error_Msg_Sloc := Sloc (Old_Name);
9170 ("external name does not match that given #",
9174 -- Start of processing for Check_Matching_Internal_Names
9177 if String_Length (S1) /= String_Length (S2) then
9181 for J in 1 .. String_Length (S1) loop
9182 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9187 end Check_Matching_Internal_Names;
9189 -- Otherwise set the given name
9192 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9193 Check_Duplicated_Export_Name (New_Name);
9195 end Set_Extended_Import_Export_External_Name;
9201 procedure Set_Imported (E : Entity_Id) is
9203 -- Error message if already imported or exported
9205 if Is_Exported (E) or else Is_Imported (E) then
9207 -- Error if being set Exported twice
9209 if Is_Exported (E) then
9210 Error_Msg_NE ("entity& was previously exported", N, E);
9212 -- Ignore error in CodePeer mode where we treat all imported
9213 -- subprograms as unknown.
9215 elsif CodePeer_Mode then
9218 -- OK if Import/Interface case
9220 elsif Import_Interface_Present (N) then
9223 -- Error if being set Imported twice
9226 Error_Msg_NE ("entity& was previously imported", N, E);
9229 Error_Msg_Name_1 := Pname;
9231 ("\(pragma% applies to all previous entities)", N);
9233 Error_Msg_Sloc := Sloc (E);
9234 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9236 -- Here if not previously imported or exported, OK to import
9239 Set_Is_Imported (E);
9241 -- For subprogram, set Import_Pragma field
9243 if Is_Subprogram (E) then
9244 Set_Import_Pragma (E, N);
9247 -- If the entity is an object that is not at the library level,
9248 -- then it is statically allocated. We do not worry about objects
9249 -- with address clauses in this context since they are not really
9250 -- imported in the linker sense.
9253 and then not Is_Library_Level_Entity (E)
9254 and then No (Address_Clause (E))
9256 Set_Is_Statically_Allocated (E);
9263 -------------------------
9264 -- Set_Mechanism_Value --
9265 -------------------------
9267 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9268 -- analyzed, since it is semantic nonsense), so we get it in the exact
9269 -- form created by the parser.
9271 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9272 procedure Bad_Mechanism;
9273 pragma No_Return (Bad_Mechanism);
9274 -- Signal bad mechanism name
9276 -------------------------
9277 -- Bad_Mechanism_Value --
9278 -------------------------
9280 procedure Bad_Mechanism is
9282 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9285 -- Start of processing for Set_Mechanism_Value
9288 if Mechanism (Ent) /= Default_Mechanism then
9290 ("mechanism for & has already been set", Mech_Name, Ent);
9293 -- MECHANISM_NAME ::= value | reference
9295 if Nkind (Mech_Name) = N_Identifier then
9296 if Chars (Mech_Name) = Name_Value then
9297 Set_Mechanism (Ent, By_Copy);
9300 elsif Chars (Mech_Name) = Name_Reference then
9301 Set_Mechanism (Ent, By_Reference);
9304 elsif Chars (Mech_Name) = Name_Copy then
9306 ("bad mechanism name, Value assumed", Mech_Name);
9315 end Set_Mechanism_Value;
9317 --------------------------
9318 -- Set_Rational_Profile --
9319 --------------------------
9321 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9322 -- and extension to the semantics of renaming declarations.
9324 procedure Set_Rational_Profile is
9326 Implicit_Packing := True;
9327 Overriding_Renamings := True;
9328 Use_VADS_Size := True;
9329 end Set_Rational_Profile;
9331 ---------------------------
9332 -- Set_Ravenscar_Profile --
9333 ---------------------------
9335 -- The tasks to be done here are
9337 -- Set required policies
9339 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9340 -- pragma Locking_Policy (Ceiling_Locking)
9342 -- Set Detect_Blocking mode
9344 -- Set required restrictions (see System.Rident for detailed list)
9346 -- Set the No_Dependence rules
9347 -- No_Dependence => Ada.Asynchronous_Task_Control
9348 -- No_Dependence => Ada.Calendar
9349 -- No_Dependence => Ada.Execution_Time.Group_Budget
9350 -- No_Dependence => Ada.Execution_Time.Timers
9351 -- No_Dependence => Ada.Task_Attributes
9352 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9354 procedure Set_Ravenscar_Profile (N : Node_Id) is
9355 Prefix_Entity : Entity_Id;
9356 Selector_Entity : Entity_Id;
9357 Prefix_Node : Node_Id;
9361 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9363 if Task_Dispatching_Policy /= ' '
9364 and then Task_Dispatching_Policy /= 'F'
9366 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9367 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9369 -- Set the FIFO_Within_Priorities policy, but always preserve
9370 -- System_Location since we like the error message with the run time
9374 Task_Dispatching_Policy := 'F';
9376 if Task_Dispatching_Policy_Sloc /= System_Location then
9377 Task_Dispatching_Policy_Sloc := Loc;
9381 -- pragma Locking_Policy (Ceiling_Locking)
9383 if Locking_Policy /= ' '
9384 and then Locking_Policy /= 'C'
9386 Error_Msg_Sloc := Locking_Policy_Sloc;
9387 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9389 -- Set the Ceiling_Locking policy, but preserve System_Location since
9390 -- we like the error message with the run time name.
9393 Locking_Policy := 'C';
9395 if Locking_Policy_Sloc /= System_Location then
9396 Locking_Policy_Sloc := Loc;
9400 -- pragma Detect_Blocking
9402 Detect_Blocking := True;
9404 -- Set the corresponding restrictions
9406 Set_Profile_Restrictions
9407 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9409 -- Set the No_Dependence restrictions
9411 -- The following No_Dependence restrictions:
9412 -- No_Dependence => Ada.Asynchronous_Task_Control
9413 -- No_Dependence => Ada.Calendar
9414 -- No_Dependence => Ada.Task_Attributes
9415 -- are already set by previous call to Set_Profile_Restrictions.
9417 -- Set the following restrictions which were added to Ada 2005:
9418 -- No_Dependence => Ada.Execution_Time.Group_Budget
9419 -- No_Dependence => Ada.Execution_Time.Timers
9421 if Ada_Version >= Ada_2005 then
9422 Name_Buffer (1 .. 3) := "ada";
9425 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9427 Name_Buffer (1 .. 14) := "execution_time";
9430 Selector_Entity := Make_Identifier (Loc, Name_Find);
9433 Make_Selected_Component
9435 Prefix => Prefix_Entity,
9436 Selector_Name => Selector_Entity);
9438 Name_Buffer (1 .. 13) := "group_budgets";
9441 Selector_Entity := Make_Identifier (Loc, Name_Find);
9444 Make_Selected_Component
9446 Prefix => Prefix_Node,
9447 Selector_Name => Selector_Entity);
9449 Set_Restriction_No_Dependence
9451 Warn => Treat_Restrictions_As_Warnings,
9452 Profile => Ravenscar);
9454 Name_Buffer (1 .. 6) := "timers";
9457 Selector_Entity := Make_Identifier (Loc, Name_Find);
9460 Make_Selected_Component
9462 Prefix => Prefix_Node,
9463 Selector_Name => Selector_Entity);
9465 Set_Restriction_No_Dependence
9467 Warn => Treat_Restrictions_As_Warnings,
9468 Profile => Ravenscar);
9471 -- Set the following restrictions which was added to Ada 2012 (see
9473 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9475 if Ada_Version >= Ada_2012 then
9476 Name_Buffer (1 .. 6) := "system";
9479 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9481 Name_Buffer (1 .. 15) := "multiprocessors";
9484 Selector_Entity := Make_Identifier (Loc, Name_Find);
9487 Make_Selected_Component
9489 Prefix => Prefix_Entity,
9490 Selector_Name => Selector_Entity);
9492 Name_Buffer (1 .. 19) := "dispatching_domains";
9495 Selector_Entity := Make_Identifier (Loc, Name_Find);
9498 Make_Selected_Component
9500 Prefix => Prefix_Node,
9501 Selector_Name => Selector_Entity);
9503 Set_Restriction_No_Dependence
9505 Warn => Treat_Restrictions_As_Warnings,
9506 Profile => Ravenscar);
9508 end Set_Ravenscar_Profile;
9510 -- Start of processing for Analyze_Pragma
9513 -- The following code is a defense against recursion. Not clear that
9514 -- this can happen legitimately, but perhaps some error situations
9515 -- can cause it, and we did see this recursion during testing.
9517 if Analyzed (N) then
9520 Set_Analyzed (N, True);
9523 -- Deal with unrecognized pragma
9525 Pname := Pragma_Name (N);
9527 if not Is_Pragma_Name (Pname) then
9528 if Warn_On_Unrecognized_Pragma then
9529 Error_Msg_Name_1 := Pname;
9530 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
9532 for PN in First_Pragma_Name .. Last_Pragma_Name loop
9533 if Is_Bad_Spelling_Of (Pname, PN) then
9534 Error_Msg_Name_1 := PN;
9535 Error_Msg_N -- CODEFIX
9536 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
9545 -- Ignore pragma if Ignore_Pragma applies
9547 if Get_Name_Table_Boolean3 (Pname) then
9551 -- Here to start processing for recognized pragma
9553 Prag_Id := Get_Pragma_Id (Pname);
9554 Pname := Original_Aspect_Pragma_Name (N);
9556 -- Capture setting of Opt.Uneval_Old
9558 case Opt.Uneval_Old is
9560 Set_Uneval_Old_Accept (N);
9564 Set_Uneval_Old_Warn (N);
9566 raise Program_Error;
9569 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9570 -- is already set, indicating that we have already checked the policy
9571 -- at the right point. This happens for example in the case of a pragma
9572 -- that is derived from an Aspect.
9574 if Is_Ignored (N) or else Is_Checked (N) then
9577 -- For a pragma that is a rewriting of another pragma, copy the
9578 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9580 elsif Is_Rewrite_Substitution (N)
9581 and then Nkind (Original_Node (N)) = N_Pragma
9582 and then Original_Node (N) /= N
9584 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
9585 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
9587 -- Otherwise query the applicable policy at this point
9590 Check_Applicable_Policy (N);
9592 -- If pragma is disabled, rewrite as NULL and skip analysis
9594 if Is_Disabled (N) then
9595 Rewrite (N, Make_Null_Statement (Loc));
9609 if Present (Pragma_Argument_Associations (N)) then
9610 Arg_Count := List_Length (Pragma_Argument_Associations (N));
9611 Arg1 := First (Pragma_Argument_Associations (N));
9613 if Present (Arg1) then
9614 Arg2 := Next (Arg1);
9616 if Present (Arg2) then
9617 Arg3 := Next (Arg2);
9619 if Present (Arg3) then
9620 Arg4 := Next (Arg3);
9626 Check_Restriction_No_Use_Of_Pragma (N);
9628 -- An enumeration type defines the pragmas that are supported by the
9629 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9630 -- into the corresponding enumeration value for the following case.
9638 -- pragma Abort_Defer;
9640 when Pragma_Abort_Defer =>
9642 Check_Arg_Count (0);
9644 -- The only required semantic processing is to check the
9645 -- placement. This pragma must appear at the start of the
9646 -- statement sequence of a handled sequence of statements.
9648 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
9649 or else N /= First (Statements (Parent (N)))
9654 --------------------
9655 -- Abstract_State --
9656 --------------------
9658 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9660 -- ABSTRACT_STATE_LIST ::=
9662 -- | STATE_NAME_WITH_OPTIONS
9663 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9665 -- STATE_NAME_WITH_OPTIONS ::=
9667 -- | (STATE_NAME with OPTION_LIST)
9669 -- OPTION_LIST ::= OPTION {, OPTION}
9673 -- | NAME_VALUE_OPTION
9675 -- SIMPLE_OPTION ::= Ghost
9677 -- NAME_VALUE_OPTION ::=
9678 -- Part_Of => ABSTRACT_STATE
9679 -- | External [=> EXTERNAL_PROPERTY_LIST]
9681 -- EXTERNAL_PROPERTY_LIST ::=
9682 -- EXTERNAL_PROPERTY
9683 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9685 -- EXTERNAL_PROPERTY ::=
9686 -- Async_Readers [=> boolean_EXPRESSION]
9687 -- | Async_Writers [=> boolean_EXPRESSION]
9688 -- | Effective_Reads [=> boolean_EXPRESSION]
9689 -- | Effective_Writes [=> boolean_EXPRESSION]
9690 -- others => boolean_EXPRESSION
9692 -- STATE_NAME ::= defining_identifier
9694 -- ABSTRACT_STATE ::= name
9698 -- * Analysis - The annotation is fully analyzed immediately upon
9699 -- elaboration as it cannot forward reference entities.
9701 -- * Expansion - None.
9703 -- * Template - The annotation utilizes the generic template of the
9704 -- related package declaration.
9706 -- * Globals - The annotation cannot reference global entities.
9708 -- * Instance - The annotation is instantiated automatically when
9709 -- the related generic package is instantiated.
9711 when Pragma_Abstract_State => Abstract_State : declare
9712 Missing_Parentheses : Boolean := False;
9713 -- Flag set when a state declaration with options is not properly
9716 -- Flags used to verify the consistency of states
9718 Non_Null_Seen : Boolean := False;
9719 Null_Seen : Boolean := False;
9721 procedure Analyze_Abstract_State
9723 Pack_Id : Entity_Id);
9724 -- Verify the legality of a single state declaration. Create and
9725 -- decorate a state abstraction entity and introduce it into the
9726 -- visibility chain. Pack_Id denotes the entity or the related
9727 -- package where pragma Abstract_State appears.
9729 procedure Malformed_State_Error (State : Node_Id);
9730 -- Emit an error concerning the illegal declaration of abstract
9731 -- state State. This routine diagnoses syntax errors that lead to
9732 -- a different parse tree. The error is issued regardless of the
9733 -- SPARK mode in effect.
9735 ----------------------------
9736 -- Analyze_Abstract_State --
9737 ----------------------------
9739 procedure Analyze_Abstract_State
9741 Pack_Id : Entity_Id)
9743 -- Flags used to verify the consistency of options
9745 AR_Seen : Boolean := False;
9746 AW_Seen : Boolean := False;
9747 ER_Seen : Boolean := False;
9748 EW_Seen : Boolean := False;
9749 External_Seen : Boolean := False;
9750 Others_Seen : Boolean := False;
9751 Part_Of_Seen : Boolean := False;
9753 -- Flags used to store the static value of all external states'
9756 AR_Val : Boolean := False;
9757 AW_Val : Boolean := False;
9758 ER_Val : Boolean := False;
9759 EW_Val : Boolean := False;
9761 State_Id : Entity_Id := Empty;
9762 -- The entity to be generated for the current state declaration
9764 procedure Analyze_External_Option (Opt : Node_Id);
9765 -- Verify the legality of option External
9767 procedure Analyze_External_Property
9769 Expr : Node_Id := Empty);
9770 -- Verify the legailty of a single external property. Prop
9771 -- denotes the external property. Expr is the expression used
9772 -- to set the property.
9774 procedure Analyze_Part_Of_Option (Opt : Node_Id);
9775 -- Verify the legality of option Part_Of
9777 procedure Check_Duplicate_Option
9779 Status : in out Boolean);
9780 -- Flag Status denotes whether a particular option has been
9781 -- seen while processing a state. This routine verifies that
9782 -- Opt is not a duplicate option and sets the flag Status
9783 -- (SPARK RM 7.1.4(1)).
9785 procedure Check_Duplicate_Property
9787 Status : in out Boolean);
9788 -- Flag Status denotes whether a particular property has been
9789 -- seen while processing option External. This routine verifies
9790 -- that Prop is not a duplicate property and sets flag Status.
9791 -- Opt is not a duplicate property and sets the flag Status.
9792 -- (SPARK RM 7.1.4(2))
9794 procedure Create_Abstract_State
9799 -- Generate an abstract state entity with name Nam and enter it
9800 -- into visibility. Decl is the "declaration" of the state as
9801 -- it appears in pragma Abstract_State. Loc is the location of
9802 -- the related state "declaration". Flag Is_Null should be set
9803 -- when the associated Abstract_State pragma defines a null
9806 -----------------------------
9807 -- Analyze_External_Option --
9808 -----------------------------
9810 procedure Analyze_External_Option (Opt : Node_Id) is
9811 Errors : constant Nat := Serious_Errors_Detected;
9813 Props : Node_Id := Empty;
9816 Check_Duplicate_Option (Opt, External_Seen);
9818 if Nkind (Opt) = N_Component_Association then
9819 Props := Expression (Opt);
9822 -- External state with properties
9824 if Present (Props) then
9826 -- Multiple properties appear as an aggregate
9828 if Nkind (Props) = N_Aggregate then
9830 -- Simple property form
9832 Prop := First (Expressions (Props));
9833 while Present (Prop) loop
9834 Analyze_External_Property (Prop);
9838 -- Property with expression form
9840 Prop := First (Component_Associations (Props));
9841 while Present (Prop) loop
9842 Analyze_External_Property
9843 (Prop => First (Choices (Prop)),
9844 Expr => Expression (Prop));
9852 Analyze_External_Property (Props);
9855 -- An external state defined without any properties defaults
9856 -- all properties to True.
9865 -- Once all external properties have been processed, verify
9866 -- their mutual interaction. Do not perform the check when
9867 -- at least one of the properties is illegal as this will
9868 -- produce a bogus error.
9870 if Errors = Serious_Errors_Detected then
9871 Check_External_Properties
9872 (State, AR_Val, AW_Val, ER_Val, EW_Val);
9874 end Analyze_External_Option;
9876 -------------------------------
9877 -- Analyze_External_Property --
9878 -------------------------------
9880 procedure Analyze_External_Property
9882 Expr : Node_Id := Empty)
9887 -- Check the placement of "others" (if available)
9889 if Nkind (Prop) = N_Others_Choice then
9892 ("only one others choice allowed in option External",
9895 Others_Seen := True;
9898 elsif Others_Seen then
9900 ("others must be the last property in option External",
9903 -- The only remaining legal options are the four predefined
9904 -- external properties.
9906 elsif Nkind (Prop) = N_Identifier
9907 and then Nam_In (Chars (Prop), Name_Async_Readers,
9909 Name_Effective_Reads,
9910 Name_Effective_Writes)
9914 -- Otherwise the construct is not a valid property
9917 SPARK_Msg_N ("invalid external state property", Prop);
9921 -- Ensure that the expression of the external state property
9922 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
9924 if Present (Expr) then
9925 Analyze_And_Resolve (Expr, Standard_Boolean);
9927 if Is_OK_Static_Expression (Expr) then
9928 Expr_Val := Is_True (Expr_Value (Expr));
9931 ("expression of external state property must be "
9935 -- The lack of expression defaults the property to True
9943 if Nkind (Prop) = N_Identifier then
9944 if Chars (Prop) = Name_Async_Readers then
9945 Check_Duplicate_Property (Prop, AR_Seen);
9948 elsif Chars (Prop) = Name_Async_Writers then
9949 Check_Duplicate_Property (Prop, AW_Seen);
9952 elsif Chars (Prop) = Name_Effective_Reads then
9953 Check_Duplicate_Property (Prop, ER_Seen);
9957 Check_Duplicate_Property (Prop, EW_Seen);
9961 -- The handling of property "others" must take into account
9962 -- all other named properties that have been encountered so
9963 -- far. Only those that have not been seen are affected by
9983 end Analyze_External_Property;
9985 ----------------------------
9986 -- Analyze_Part_Of_Option --
9987 ----------------------------
9989 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
9990 Encaps : constant Node_Id := Expression (Opt);
9991 Encaps_Id : Entity_Id;
9995 Check_Duplicate_Option (Opt, Part_Of_Seen);
9998 (Item_Id => State_Id,
10000 Indic => First (Choices (Opt)),
10003 -- The Part_Of indicator turns an abstract state into a
10004 -- constituent of the encapsulating state.
10007 Encaps_Id := Entity (Encaps);
10009 Append_Elmt (State_Id, Part_Of_Constituents (Encaps_Id));
10010 Set_Encapsulating_State (State_Id, Encaps_Id);
10012 end Analyze_Part_Of_Option;
10014 ----------------------------
10015 -- Check_Duplicate_Option --
10016 ----------------------------
10018 procedure Check_Duplicate_Option
10020 Status : in out Boolean)
10024 SPARK_Msg_N ("duplicate state option", Opt);
10028 end Check_Duplicate_Option;
10030 ------------------------------
10031 -- Check_Duplicate_Property --
10032 ------------------------------
10034 procedure Check_Duplicate_Property
10036 Status : in out Boolean)
10040 SPARK_Msg_N ("duplicate external property", Prop);
10044 end Check_Duplicate_Property;
10046 ---------------------------
10047 -- Create_Abstract_State --
10048 ---------------------------
10050 procedure Create_Abstract_State
10057 -- The abstract state may be semi-declared when the related
10058 -- package was withed through a limited with clause. In that
10059 -- case reuse the entity to fully declare the state.
10061 if Present (Decl) and then Present (Entity (Decl)) then
10062 State_Id := Entity (Decl);
10064 -- Otherwise the elaboration of pragma Abstract_State
10065 -- declares the state.
10068 State_Id := Make_Defining_Identifier (Loc, Nam);
10070 if Present (Decl) then
10071 Set_Entity (Decl, State_Id);
10075 -- Null states never come from source
10077 Set_Comes_From_Source (State_Id, not Is_Null);
10078 Set_Parent (State_Id, State);
10079 Set_Ekind (State_Id, E_Abstract_State);
10080 Set_Etype (State_Id, Standard_Void_Type);
10081 Set_Encapsulating_State (State_Id, Empty);
10082 Set_Refinement_Constituents (State_Id, New_Elmt_List);
10083 Set_Part_Of_Constituents (State_Id, New_Elmt_List);
10085 -- An abstract state declared within a Ghost region becomes
10086 -- Ghost (SPARK RM 6.9(2)).
10088 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10089 Set_Is_Ghost_Entity (State_Id);
10092 -- Establish a link between the state declaration and the
10093 -- abstract state entity. Note that a null state remains as
10094 -- N_Null and does not carry any linkages.
10096 if not Is_Null then
10097 if Present (Decl) then
10098 Set_Entity (Decl, State_Id);
10099 Set_Etype (Decl, Standard_Void_Type);
10102 -- Every non-null state must be defined, nameable and
10105 Push_Scope (Pack_Id);
10106 Generate_Definition (State_Id);
10107 Enter_Name (State_Id);
10110 end Create_Abstract_State;
10117 -- Start of processing for Analyze_Abstract_State
10120 -- A package with a null abstract state is not allowed to
10121 -- declare additional states.
10125 ("package & has null abstract state", State, Pack_Id);
10127 -- Null states appear as internally generated entities
10129 elsif Nkind (State) = N_Null then
10130 Create_Abstract_State
10131 (Nam => New_Internal_Name ('S'),
10133 Loc => Sloc (State),
10137 -- Catch a case where a null state appears in a list of
10138 -- non-null states.
10140 if Non_Null_Seen then
10142 ("package & has non-null abstract state",
10146 -- Simple state declaration
10148 elsif Nkind (State) = N_Identifier then
10149 Create_Abstract_State
10150 (Nam => Chars (State),
10152 Loc => Sloc (State),
10154 Non_Null_Seen := True;
10156 -- State declaration with various options. This construct
10157 -- appears as an extension aggregate in the tree.
10159 elsif Nkind (State) = N_Extension_Aggregate then
10160 if Nkind (Ancestor_Part (State)) = N_Identifier then
10161 Create_Abstract_State
10162 (Nam => Chars (Ancestor_Part (State)),
10163 Decl => Ancestor_Part (State),
10164 Loc => Sloc (Ancestor_Part (State)),
10166 Non_Null_Seen := True;
10169 ("state name must be an identifier",
10170 Ancestor_Part (State));
10173 -- Options External and Ghost appear as expressions
10175 Opt := First (Expressions (State));
10176 while Present (Opt) loop
10177 if Nkind (Opt) = N_Identifier then
10178 if Chars (Opt) = Name_External then
10179 Analyze_External_Option (Opt);
10181 elsif Chars (Opt) = Name_Ghost then
10182 if Present (State_Id) then
10183 Set_Is_Ghost_Entity (State_Id);
10186 -- Option Part_Of without an encapsulating state is
10187 -- illegal. (SPARK RM 7.1.4(9)).
10189 elsif Chars (Opt) = Name_Part_Of then
10191 ("indicator Part_Of must denote an abstract "
10194 -- Do not emit an error message when a previous state
10195 -- declaration with options was not parenthesized as
10196 -- the option is actually another state declaration.
10198 -- with Abstract_State
10199 -- (State_1 with ..., -- missing parentheses
10200 -- (State_2 with ...),
10201 -- State_3) -- ok state declaration
10203 elsif Missing_Parentheses then
10206 -- Otherwise the option is not allowed. Note that it
10207 -- is not possible to distinguish between an option
10208 -- and a state declaration when a previous state with
10209 -- options not properly parentheses.
10211 -- with Abstract_State
10212 -- (State_1 with ..., -- missing parentheses
10213 -- State_2); -- could be an option
10217 ("simple option not allowed in state declaration",
10221 -- Catch a case where missing parentheses around a state
10222 -- declaration with options cause a subsequent state
10223 -- declaration with options to be treated as an option.
10225 -- with Abstract_State
10226 -- (State_1 with ..., -- missing parentheses
10227 -- (State_2 with ...))
10229 elsif Nkind (Opt) = N_Extension_Aggregate then
10230 Missing_Parentheses := True;
10232 ("state declaration must be parenthesized",
10233 Ancestor_Part (State));
10235 -- Otherwise the option is malformed
10238 SPARK_Msg_N ("malformed option", Opt);
10244 -- Options External and Part_Of appear as component
10247 Opt := First (Component_Associations (State));
10248 while Present (Opt) loop
10249 Opt_Nam := First (Choices (Opt));
10251 if Nkind (Opt_Nam) = N_Identifier then
10252 if Chars (Opt_Nam) = Name_External then
10253 Analyze_External_Option (Opt);
10255 elsif Chars (Opt_Nam) = Name_Part_Of then
10256 Analyze_Part_Of_Option (Opt);
10259 SPARK_Msg_N ("invalid state option", Opt);
10262 SPARK_Msg_N ("invalid state option", Opt);
10268 -- Any other attempt to declare a state is illegal
10271 Malformed_State_Error (State);
10275 -- Guard against a junk state. In such cases no entity is
10276 -- generated and the subsequent checks cannot be applied.
10278 if Present (State_Id) then
10280 -- Verify whether the state does not introduce an illegal
10281 -- hidden state within a package subject to a null abstract
10284 Check_No_Hidden_State (State_Id);
10286 -- Check whether the lack of option Part_Of agrees with the
10287 -- placement of the abstract state with respect to the state
10290 if not Part_Of_Seen then
10291 Check_Missing_Part_Of (State_Id);
10294 -- Associate the state with its related package
10296 if No (Abstract_States (Pack_Id)) then
10297 Set_Abstract_States (Pack_Id, New_Elmt_List);
10300 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10302 end Analyze_Abstract_State;
10304 ---------------------------
10305 -- Malformed_State_Error --
10306 ---------------------------
10308 procedure Malformed_State_Error (State : Node_Id) is
10310 Error_Msg_N ("malformed abstract state declaration", State);
10312 -- An abstract state with a simple option is being declared
10313 -- with "=>" rather than the legal "with". The state appears
10314 -- as a component association.
10316 if Nkind (State) = N_Component_Association then
10317 Error_Msg_N ("\use WITH to specify simple option", State);
10319 end Malformed_State_Error;
10323 Pack_Decl : Node_Id;
10324 Pack_Id : Entity_Id;
10328 -- Start of processing for Abstract_State
10332 Check_No_Identifiers;
10333 Check_Arg_Count (1);
10335 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
10337 -- Ensure the proper placement of the pragma. Abstract states must
10338 -- be associated with a package declaration.
10340 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
10341 N_Package_Declaration)
10345 -- Otherwise the pragma is associated with an illegal construct
10352 Pack_Id := Defining_Entity (Pack_Decl);
10354 -- A pragma that applies to a Ghost entity becomes Ghost for the
10355 -- purposes of legality checks and removal of ignored Ghost code.
10357 Mark_Pragma_As_Ghost (N, Pack_Id);
10358 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
10360 States := Expression (Get_Argument (N, Pack_Id));
10362 -- Multiple non-null abstract states appear as an aggregate
10364 if Nkind (States) = N_Aggregate then
10365 State := First (Expressions (States));
10366 while Present (State) loop
10367 Analyze_Abstract_State (State, Pack_Id);
10371 -- An abstract state with a simple option is being illegaly
10372 -- declared with "=>" rather than "with". In this case the
10373 -- state declaration appears as a component association.
10375 if Present (Component_Associations (States)) then
10376 State := First (Component_Associations (States));
10377 while Present (State) loop
10378 Malformed_State_Error (State);
10383 -- Various forms of a single abstract state. Note that these may
10384 -- include malformed state declarations.
10387 Analyze_Abstract_State (States, Pack_Id);
10390 -- Verify the declaration order of pragmas Abstract_State and
10393 Check_Declaration_Order
10395 Second => Get_Pragma (Pack_Id, Pragma_Initializes));
10397 -- Chain the pragma on the contract for completeness
10399 Add_Contract_Item (N, Pack_Id);
10400 end Abstract_State;
10408 -- Note: this pragma also has some specific processing in Par.Prag
10409 -- because we want to set the Ada version mode during parsing.
10411 when Pragma_Ada_83 =>
10413 Check_Arg_Count (0);
10415 -- We really should check unconditionally for proper configuration
10416 -- pragma placement, since we really don't want mixed Ada modes
10417 -- within a single unit, and the GNAT reference manual has always
10418 -- said this was a configuration pragma, but we did not check and
10419 -- are hesitant to add the check now.
10421 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10422 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10423 -- or Ada 2012 mode.
10425 if Ada_Version >= Ada_2005 then
10426 Check_Valid_Configuration_Pragma;
10429 -- Now set Ada 83 mode
10431 Ada_Version := Ada_83;
10432 Ada_Version_Explicit := Ada_83;
10433 Ada_Version_Pragma := N;
10441 -- Note: this pragma also has some specific processing in Par.Prag
10442 -- because we want to set the Ada 83 version mode during parsing.
10444 when Pragma_Ada_95 =>
10446 Check_Arg_Count (0);
10448 -- We really should check unconditionally for proper configuration
10449 -- pragma placement, since we really don't want mixed Ada modes
10450 -- within a single unit, and the GNAT reference manual has always
10451 -- said this was a configuration pragma, but we did not check and
10452 -- are hesitant to add the check now.
10454 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10455 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10457 if Ada_Version >= Ada_2005 then
10458 Check_Valid_Configuration_Pragma;
10461 -- Now set Ada 95 mode
10463 Ada_Version := Ada_95;
10464 Ada_Version_Explicit := Ada_95;
10465 Ada_Version_Pragma := N;
10467 ---------------------
10468 -- Ada_05/Ada_2005 --
10469 ---------------------
10472 -- pragma Ada_05 (LOCAL_NAME);
10474 -- pragma Ada_2005;
10475 -- pragma Ada_2005 (LOCAL_NAME):
10477 -- Note: these pragmas also have some specific processing in Par.Prag
10478 -- because we want to set the Ada 2005 version mode during parsing.
10480 -- The one argument form is used for managing the transition from
10481 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10482 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10483 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10484 -- mode, a preference rule is established which does not choose
10485 -- such an entity unless it is unambiguously specified. This avoids
10486 -- extra subprograms marked this way from generating ambiguities in
10487 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10488 -- intended for exclusive use in the GNAT run-time library.
10490 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
10496 if Arg_Count = 1 then
10497 Check_Arg_Is_Local_Name (Arg1);
10498 E_Id := Get_Pragma_Arg (Arg1);
10500 if Etype (E_Id) = Any_Type then
10504 Set_Is_Ada_2005_Only (Entity (E_Id));
10505 Record_Rep_Item (Entity (E_Id), N);
10508 Check_Arg_Count (0);
10510 -- For Ada_2005 we unconditionally enforce the documented
10511 -- configuration pragma placement, since we do not want to
10512 -- tolerate mixed modes in a unit involving Ada 2005. That
10513 -- would cause real difficulties for those cases where there
10514 -- are incompatibilities between Ada 95 and Ada 2005.
10516 Check_Valid_Configuration_Pragma;
10518 -- Now set appropriate Ada mode
10520 Ada_Version := Ada_2005;
10521 Ada_Version_Explicit := Ada_2005;
10522 Ada_Version_Pragma := N;
10526 ---------------------
10527 -- Ada_12/Ada_2012 --
10528 ---------------------
10531 -- pragma Ada_12 (LOCAL_NAME);
10533 -- pragma Ada_2012;
10534 -- pragma Ada_2012 (LOCAL_NAME):
10536 -- Note: these pragmas also have some specific processing in Par.Prag
10537 -- because we want to set the Ada 2012 version mode during parsing.
10539 -- The one argument form is used for managing the transition from Ada
10540 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10541 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10542 -- mode will generate a warning. In addition, in any pre-Ada_2012
10543 -- mode, a preference rule is established which does not choose
10544 -- such an entity unless it is unambiguously specified. This avoids
10545 -- extra subprograms marked this way from generating ambiguities in
10546 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10547 -- intended for exclusive use in the GNAT run-time library.
10549 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
10555 if Arg_Count = 1 then
10556 Check_Arg_Is_Local_Name (Arg1);
10557 E_Id := Get_Pragma_Arg (Arg1);
10559 if Etype (E_Id) = Any_Type then
10563 Set_Is_Ada_2012_Only (Entity (E_Id));
10564 Record_Rep_Item (Entity (E_Id), N);
10567 Check_Arg_Count (0);
10569 -- For Ada_2012 we unconditionally enforce the documented
10570 -- configuration pragma placement, since we do not want to
10571 -- tolerate mixed modes in a unit involving Ada 2012. That
10572 -- would cause real difficulties for those cases where there
10573 -- are incompatibilities between Ada 95 and Ada 2012. We could
10574 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10576 Check_Valid_Configuration_Pragma;
10578 -- Now set appropriate Ada mode
10580 Ada_Version := Ada_2012;
10581 Ada_Version_Explicit := Ada_2012;
10582 Ada_Version_Pragma := N;
10586 ----------------------
10587 -- All_Calls_Remote --
10588 ----------------------
10590 -- pragma All_Calls_Remote [(library_package_NAME)];
10592 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
10593 Lib_Entity : Entity_Id;
10596 Check_Ada_83_Warning;
10597 Check_Valid_Library_Unit_Pragma;
10599 if Nkind (N) = N_Null_Statement then
10603 Lib_Entity := Find_Lib_Unit_Name;
10605 -- A pragma that applies to a Ghost entity becomes Ghost for the
10606 -- purposes of legality checks and removal of ignored Ghost code.
10608 Mark_Pragma_As_Ghost (N, Lib_Entity);
10610 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10612 if Present (Lib_Entity) and then not Debug_Flag_U then
10613 if not Is_Remote_Call_Interface (Lib_Entity) then
10614 Error_Pragma ("pragma% only apply to rci unit");
10616 -- Set flag for entity of the library unit
10619 Set_Has_All_Calls_Remote (Lib_Entity);
10622 end All_Calls_Remote;
10624 ---------------------------
10625 -- Allow_Integer_Address --
10626 ---------------------------
10628 -- pragma Allow_Integer_Address;
10630 when Pragma_Allow_Integer_Address =>
10632 Check_Valid_Configuration_Pragma;
10633 Check_Arg_Count (0);
10635 -- If Address is a private type, then set the flag to allow
10636 -- integer address values. If Address is not private, then this
10637 -- pragma has no purpose, so it is simply ignored. Not clear if
10638 -- there are any such targets now.
10640 if Opt.Address_Is_Private then
10641 Opt.Allow_Integer_Address := True;
10649 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10650 -- ARG ::= NAME | EXPRESSION
10652 -- The first two arguments are by convention intended to refer to an
10653 -- external tool and a tool-specific function. These arguments are
10656 when Pragma_Annotate => Annotate : declare
10663 Check_At_Least_N_Arguments (1);
10665 Nam_Arg := Last (Pragma_Argument_Associations (N));
10667 -- Determine whether the last argument is "Entity => local_NAME"
10668 -- and if it is, perform the required semantic checks. Remove the
10669 -- argument from further processing.
10671 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
10672 and then Chars (Nam_Arg) = Name_Entity
10674 Check_Arg_Is_Local_Name (Nam_Arg);
10675 Arg_Count := Arg_Count - 1;
10677 -- A pragma that applies to a Ghost entity becomes Ghost for
10678 -- the purposes of legality checks and removal of ignored Ghost
10681 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
10682 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
10684 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
10687 -- Not allowed in compiler units (bootstrap issues)
10689 Check_Compiler_Unit ("Entity for pragma Annotate", N);
10692 -- Continue the processing with last argument removed for now
10694 Check_Arg_Is_Identifier (Arg1);
10695 Check_No_Identifiers;
10698 -- The second parameter is optional, it is never analyzed
10703 -- Otherwise there is a second parameter
10706 -- The second parameter must be an identifier
10708 Check_Arg_Is_Identifier (Arg2);
10710 -- Process the remaining parameters (if any)
10712 Arg := Next (Arg2);
10713 while Present (Arg) loop
10714 Expr := Get_Pragma_Arg (Arg);
10717 if Is_Entity_Name (Expr) then
10720 -- For string literals, we assume Standard_String as the
10721 -- type, unless the string contains wide or wide_wide
10724 elsif Nkind (Expr) = N_String_Literal then
10725 if Has_Wide_Wide_Character (Expr) then
10726 Resolve (Expr, Standard_Wide_Wide_String);
10727 elsif Has_Wide_Character (Expr) then
10728 Resolve (Expr, Standard_Wide_String);
10730 Resolve (Expr, Standard_String);
10733 elsif Is_Overloaded (Expr) then
10734 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
10745 -------------------------------------------------
10746 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10747 -------------------------------------------------
10750 -- ( [Check => ] Boolean_EXPRESSION
10751 -- [, [Message =>] Static_String_EXPRESSION]);
10753 -- pragma Assert_And_Cut
10754 -- ( [Check => ] Boolean_EXPRESSION
10755 -- [, [Message =>] Static_String_EXPRESSION]);
10758 -- ( [Check => ] Boolean_EXPRESSION
10759 -- [, [Message =>] Static_String_EXPRESSION]);
10761 -- pragma Loop_Invariant
10762 -- ( [Check => ] Boolean_EXPRESSION
10763 -- [, [Message =>] Static_String_EXPRESSION]);
10765 when Pragma_Assert |
10766 Pragma_Assert_And_Cut |
10768 Pragma_Loop_Invariant =>
10770 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
10771 -- Determine whether expression Expr contains a Loop_Entry
10772 -- attribute reference.
10774 -------------------------
10775 -- Contains_Loop_Entry --
10776 -------------------------
10778 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
10779 Has_Loop_Entry : Boolean := False;
10781 function Process (N : Node_Id) return Traverse_Result;
10782 -- Process function for traversal to look for Loop_Entry
10788 function Process (N : Node_Id) return Traverse_Result is
10790 if Nkind (N) = N_Attribute_Reference
10791 and then Attribute_Name (N) = Name_Loop_Entry
10793 Has_Loop_Entry := True;
10800 procedure Traverse is new Traverse_Proc (Process);
10802 -- Start of processing for Contains_Loop_Entry
10806 return Has_Loop_Entry;
10807 end Contains_Loop_Entry;
10811 GM : constant Ghost_Mode_Type := Ghost_Mode;
10813 New_Args : List_Id;
10815 -- Start of processing for Assert
10818 -- Ensure that analysis and expansion produce Ghost nodes if the
10819 -- pragma itself is Ghost.
10821 Set_Ghost_Mode (N);
10823 -- Assert is an Ada 2005 RM-defined pragma
10825 if Prag_Id = Pragma_Assert then
10828 -- The remaining ones are GNAT pragmas
10834 Check_At_Least_N_Arguments (1);
10835 Check_At_Most_N_Arguments (2);
10836 Check_Arg_Order ((Name_Check, Name_Message));
10837 Check_Optional_Identifier (Arg1, Name_Check);
10838 Expr := Get_Pragma_Arg (Arg1);
10840 -- Special processing for Loop_Invariant, Loop_Variant or for
10841 -- other cases where a Loop_Entry attribute is present. If the
10842 -- assertion pragma contains attribute Loop_Entry, ensure that
10843 -- the related pragma is within a loop.
10845 if Prag_Id = Pragma_Loop_Invariant
10846 or else Prag_Id = Pragma_Loop_Variant
10847 or else Contains_Loop_Entry (Expr)
10849 Check_Loop_Pragma_Placement;
10851 -- Perform preanalysis to deal with embedded Loop_Entry
10854 Preanalyze_Assert_Expression (Expr, Any_Boolean);
10857 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10858 -- a corresponding Check pragma:
10860 -- pragma Check (name, condition [, msg]);
10862 -- Where name is the identifier matching the pragma name. So
10863 -- rewrite pragma in this manner, transfer the message argument
10864 -- if present, and analyze the result
10866 -- Note: When dealing with a semantically analyzed tree, the
10867 -- information that a Check node N corresponds to a source Assert,
10868 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10869 -- pragma kind of Original_Node(N).
10871 New_Args := New_List (
10872 Make_Pragma_Argument_Association (Loc,
10873 Expression => Make_Identifier (Loc, Pname)),
10874 Make_Pragma_Argument_Association (Sloc (Expr),
10875 Expression => Expr));
10877 if Arg_Count > 1 then
10878 Check_Optional_Identifier (Arg2, Name_Message);
10880 -- Provide semantic annnotations for optional argument, for
10881 -- ASIS use, before rewriting.
10883 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
10884 Append_To (New_Args, New_Copy_Tree (Arg2));
10887 -- Rewrite as Check pragma
10891 Chars => Name_Check,
10892 Pragma_Argument_Associations => New_Args));
10896 -- Restore the original Ghost mode once analysis and expansion
10897 -- have taken place.
10902 ----------------------
10903 -- Assertion_Policy --
10904 ----------------------
10906 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10908 -- The following form is Ada 2012 only, but we allow it in all modes
10910 -- Pragma Assertion_Policy (
10911 -- ASSERTION_KIND => POLICY_IDENTIFIER
10912 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10914 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10916 -- RM_ASSERTION_KIND ::= Assert |
10917 -- Static_Predicate |
10918 -- Dynamic_Predicate |
10923 -- Type_Invariant |
10924 -- Type_Invariant'Class
10926 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10928 -- Contract_Cases |
10930 -- Default_Initial_Condition |
10932 -- Initial_Condition |
10933 -- Loop_Invariant |
10939 -- Statement_Assertions
10941 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10942 -- ID_ASSERTION_KIND list contains implementation-defined additions
10943 -- recognized by GNAT. The effect is to control the behavior of
10944 -- identically named aspects and pragmas, depending on the specified
10945 -- policy identifier:
10947 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
10949 -- Note: Check and Ignore are language-defined. Disable is a GNAT
10950 -- implementation defined addition that results in totally ignoring
10951 -- the corresponding assertion. If Disable is specified, then the
10952 -- argument of the assertion is not even analyzed. This is useful
10953 -- when the aspect/pragma argument references entities in a with'ed
10954 -- package that is replaced by a dummy package in the final build.
10956 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
10957 -- and Type_Invariant'Class were recognized by the parser and
10958 -- transformed into references to the special internal identifiers
10959 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
10960 -- processing is required here.
10962 when Pragma_Assertion_Policy => Assertion_Policy : declare
10971 -- This can always appear as a configuration pragma
10973 if Is_Configuration_Pragma then
10976 -- It can also appear in a declarative part or package spec in Ada
10977 -- 2012 mode. We allow this in other modes, but in that case we
10978 -- consider that we have an Ada 2012 pragma on our hands.
10981 Check_Is_In_Decl_Part_Or_Package_Spec;
10985 -- One argument case with no identifier (first form above)
10988 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
10989 or else Chars (Arg1) = No_Name)
10991 Check_Arg_Is_One_Of
10992 (Arg1, Name_Check, Name_Disable, Name_Ignore);
10994 -- Treat one argument Assertion_Policy as equivalent to:
10996 -- pragma Check_Policy (Assertion, policy)
10998 -- So rewrite pragma in that manner and link on to the chain
10999 -- of Check_Policy pragmas, marking the pragma as analyzed.
11001 Policy := Get_Pragma_Arg (Arg1);
11005 Chars => Name_Check_Policy,
11006 Pragma_Argument_Associations => New_List (
11007 Make_Pragma_Argument_Association (Loc,
11008 Expression => Make_Identifier (Loc, Name_Assertion)),
11010 Make_Pragma_Argument_Association (Loc,
11012 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11015 -- Here if we have two or more arguments
11018 Check_At_Least_N_Arguments (1);
11021 -- Loop through arguments
11024 while Present (Arg) loop
11025 LocP := Sloc (Arg);
11027 -- Kind must be specified
11029 if Nkind (Arg) /= N_Pragma_Argument_Association
11030 or else Chars (Arg) = No_Name
11033 ("missing assertion kind for pragma%", Arg);
11036 -- Check Kind and Policy have allowed forms
11038 Kind := Chars (Arg);
11040 if not Is_Valid_Assertion_Kind (Kind) then
11042 ("invalid assertion kind for pragma%", Arg);
11045 Check_Arg_Is_One_Of
11046 (Arg, Name_Check, Name_Disable, Name_Ignore);
11048 -- Rewrite the Assertion_Policy pragma as a series of
11049 -- Check_Policy pragmas of the form:
11051 -- Check_Policy (Kind, Policy);
11053 -- Note: the insertion of the pragmas cannot be done with
11054 -- Insert_Action because in the configuration case, there
11055 -- are no scopes on the scope stack and the mechanism will
11058 Insert_Before_And_Analyze (N,
11060 Chars => Name_Check_Policy,
11061 Pragma_Argument_Associations => New_List (
11062 Make_Pragma_Argument_Association (LocP,
11063 Expression => Make_Identifier (LocP, Kind)),
11064 Make_Pragma_Argument_Association (LocP,
11065 Expression => Get_Pragma_Arg (Arg)))));
11070 -- Rewrite the Assertion_Policy pragma as null since we have
11071 -- now inserted all the equivalent Check pragmas.
11073 Rewrite (N, Make_Null_Statement (Loc));
11076 end Assertion_Policy;
11078 ------------------------------
11079 -- Assume_No_Invalid_Values --
11080 ------------------------------
11082 -- pragma Assume_No_Invalid_Values (On | Off);
11084 when Pragma_Assume_No_Invalid_Values =>
11086 Check_Valid_Configuration_Pragma;
11087 Check_Arg_Count (1);
11088 Check_No_Identifiers;
11089 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11091 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11092 Assume_No_Invalid_Values := True;
11094 Assume_No_Invalid_Values := False;
11097 --------------------------
11098 -- Attribute_Definition --
11099 --------------------------
11101 -- pragma Attribute_Definition
11102 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11103 -- [Entity =>] LOCAL_NAME,
11104 -- [Expression =>] EXPRESSION | NAME);
11106 when Pragma_Attribute_Definition => Attribute_Definition : declare
11107 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11112 Check_Arg_Count (3);
11113 Check_Optional_Identifier (Arg1, "attribute");
11114 Check_Optional_Identifier (Arg2, "entity");
11115 Check_Optional_Identifier (Arg3, "expression");
11117 if Nkind (Attribute_Designator) /= N_Identifier then
11118 Error_Msg_N ("attribute name expected", Attribute_Designator);
11122 Check_Arg_Is_Local_Name (Arg2);
11124 -- If the attribute is not recognized, then issue a warning (not
11125 -- an error), and ignore the pragma.
11127 Aname := Chars (Attribute_Designator);
11129 if not Is_Attribute_Name (Aname) then
11130 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11134 -- Otherwise, rewrite the pragma as an attribute definition clause
11137 Make_Attribute_Definition_Clause (Loc,
11138 Name => Get_Pragma_Arg (Arg2),
11140 Expression => Get_Pragma_Arg (Arg3)));
11142 end Attribute_Definition;
11144 ------------------------------------------------------------------
11145 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11146 ------------------------------------------------------------------
11148 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11149 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11150 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11151 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11153 -- FLAG ::= boolean_EXPRESSION
11155 when Pragma_Async_Readers |
11156 Pragma_Async_Writers |
11157 Pragma_Effective_Reads |
11158 Pragma_Effective_Writes =>
11159 Async_Effective : declare
11163 Obj_Id : Entity_Id;
11167 Check_No_Identifiers;
11168 Check_At_Least_N_Arguments (1);
11169 Check_At_Most_N_Arguments (2);
11170 Check_Arg_Is_Local_Name (Arg1);
11171 Error_Msg_Name_1 := Pname;
11173 Obj := Get_Pragma_Arg (Arg1);
11174 Expr := Get_Pragma_Arg (Arg2);
11176 -- Perform minimal verification to ensure that the argument is at
11177 -- least a variable. Subsequent finer grained checks will be done
11178 -- at the end of the declarative region the contains the pragma.
11180 if Is_Entity_Name (Obj)
11181 and then Present (Entity (Obj))
11182 and then Ekind (Entity (Obj)) = E_Variable
11184 Obj_Id := Entity (Obj);
11186 -- A pragma that applies to a Ghost entity becomes Ghost for
11187 -- the purposes of legality checks and removal of ignored Ghost
11190 Mark_Pragma_As_Ghost (N, Obj_Id);
11192 -- Detect a duplicate pragma. Note that it is not efficient to
11193 -- examine preceding statements as Boolean aspects may appear
11194 -- anywhere between the related object declaration and its
11195 -- freeze point. As an alternative, inspect the contents of the
11196 -- variable contract.
11198 Duplic := Get_Pragma (Obj_Id, Prag_Id);
11200 if Present (Duplic) then
11201 Error_Msg_Sloc := Sloc (Duplic);
11202 Error_Msg_N ("pragma % duplicates pragma declared #", N);
11204 -- No duplicate detected
11207 if Present (Expr) then
11208 Preanalyze_And_Resolve (Expr, Standard_Boolean);
11211 -- Chain the pragma on the contract for further processing
11212 -- by Analyze_External_Property_In_Decl_Part.
11214 Add_Contract_Item (N, Obj_Id);
11217 Error_Pragma ("pragma % must apply to a volatile object");
11219 end Async_Effective;
11225 -- pragma Asynchronous (LOCAL_NAME);
11227 when Pragma_Asynchronous => Asynchronous : declare
11230 Formal : Entity_Id;
11235 procedure Process_Async_Pragma;
11236 -- Common processing for procedure and access-to-procedure case
11238 --------------------------
11239 -- Process_Async_Pragma --
11240 --------------------------
11242 procedure Process_Async_Pragma is
11245 Set_Is_Asynchronous (Nm);
11249 -- The formals should be of mode IN (RM E.4.1(6))
11252 while Present (S) loop
11253 Formal := Defining_Identifier (S);
11255 if Nkind (Formal) = N_Defining_Identifier
11256 and then Ekind (Formal) /= E_In_Parameter
11259 ("pragma% procedure can only have IN parameter",
11266 Set_Is_Asynchronous (Nm);
11267 end Process_Async_Pragma;
11269 -- Start of processing for pragma Asynchronous
11272 Check_Ada_83_Warning;
11273 Check_No_Identifiers;
11274 Check_Arg_Count (1);
11275 Check_Arg_Is_Local_Name (Arg1);
11277 if Debug_Flag_U then
11281 C_Ent := Cunit_Entity (Current_Sem_Unit);
11282 Analyze (Get_Pragma_Arg (Arg1));
11283 Nm := Entity (Get_Pragma_Arg (Arg1));
11285 -- A pragma that applies to a Ghost entity becomes Ghost for the
11286 -- purposes of legality checks and removal of ignored Ghost code.
11288 Mark_Pragma_As_Ghost (N, Nm);
11290 if not Is_Remote_Call_Interface (C_Ent)
11291 and then not Is_Remote_Types (C_Ent)
11293 -- This pragma should only appear in an RCI or Remote Types
11294 -- unit (RM E.4.1(4)).
11297 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11300 if Ekind (Nm) = E_Procedure
11301 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11303 if not Is_Remote_Call_Interface (Nm) then
11305 ("pragma% cannot be applied on non-remote procedure",
11309 L := Parameter_Specifications (Parent (Nm));
11310 Process_Async_Pragma;
11313 elsif Ekind (Nm) = E_Function then
11315 ("pragma% cannot be applied to function", Arg1);
11317 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11318 if Is_Record_Type (Nm) then
11320 -- A record type that is the Equivalent_Type for a remote
11321 -- access-to-subprogram type.
11323 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
11326 -- A non-expanded RAS type (distribution is not enabled)
11328 Decl := Declaration_Node (Nm);
11331 if Nkind (Decl) = N_Full_Type_Declaration
11332 and then Nkind (Type_Definition (Decl)) =
11333 N_Access_Procedure_Definition
11335 L := Parameter_Specifications (Type_Definition (Decl));
11336 Process_Async_Pragma;
11338 if Is_Asynchronous (Nm)
11339 and then Expander_Active
11340 and then Get_PCS_Name /= Name_No_DSA
11342 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11347 ("pragma% cannot reference access-to-function type",
11351 -- Only other possibility is Access-to-class-wide type
11353 elsif Is_Access_Type (Nm)
11354 and then Is_Class_Wide_Type (Designated_Type (Nm))
11356 Check_First_Subtype (Arg1);
11357 Set_Is_Asynchronous (Nm);
11358 if Expander_Active then
11359 RACW_Type_Is_Asynchronous (Nm);
11363 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
11371 -- pragma Atomic (LOCAL_NAME);
11373 when Pragma_Atomic =>
11374 Process_Atomic_Independent_Shared_Volatile;
11376 -----------------------
11377 -- Atomic_Components --
11378 -----------------------
11380 -- pragma Atomic_Components (array_LOCAL_NAME);
11382 -- This processing is shared by Volatile_Components
11384 when Pragma_Atomic_Components |
11385 Pragma_Volatile_Components =>
11386 Atomic_Components : declare
11393 Check_Ada_83_Warning;
11394 Check_No_Identifiers;
11395 Check_Arg_Count (1);
11396 Check_Arg_Is_Local_Name (Arg1);
11397 E_Id := Get_Pragma_Arg (Arg1);
11399 if Etype (E_Id) = Any_Type then
11403 E := Entity (E_Id);
11405 -- A pragma that applies to a Ghost entity becomes Ghost for the
11406 -- purposes of legality checks and removal of ignored Ghost code.
11408 Mark_Pragma_As_Ghost (N, E);
11409 Check_Duplicate_Pragma (E);
11411 if Rep_Item_Too_Early (E, N)
11413 Rep_Item_Too_Late (E, N)
11418 D := Declaration_Node (E);
11421 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
11423 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
11424 and then Nkind (D) = N_Object_Declaration
11425 and then Nkind (Object_Definition (D)) =
11426 N_Constrained_Array_Definition)
11428 -- The flag is set on the object, or on the base type
11430 if Nkind (D) /= N_Object_Declaration then
11431 E := Base_Type (E);
11434 -- Atomic implies both Independent and Volatile
11436 if Prag_Id = Pragma_Atomic_Components then
11437 Set_Has_Atomic_Components (E);
11438 Set_Has_Independent_Components (E);
11441 Set_Has_Volatile_Components (E);
11444 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
11446 end Atomic_Components;
11448 --------------------
11449 -- Attach_Handler --
11450 --------------------
11452 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11454 when Pragma_Attach_Handler =>
11455 Check_Ada_83_Warning;
11456 Check_No_Identifiers;
11457 Check_Arg_Count (2);
11459 if No_Run_Time_Mode then
11460 Error_Msg_CRT ("Attach_Handler pragma", N);
11462 Check_Interrupt_Or_Attach_Handler;
11464 -- The expression that designates the attribute may depend on a
11465 -- discriminant, and is therefore a per-object expression, to
11466 -- be expanded in the init proc. If expansion is enabled, then
11467 -- perform semantic checks on a copy only.
11472 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
11475 -- In Relaxed_RM_Semantics mode, we allow any static
11476 -- integer value, for compatibility with other compilers.
11478 if Relaxed_RM_Semantics
11479 and then Nkind (Parg2) = N_Integer_Literal
11481 Typ := Standard_Integer;
11483 Typ := RTE (RE_Interrupt_ID);
11486 if Expander_Active then
11487 Temp := New_Copy_Tree (Parg2);
11488 Set_Parent (Temp, N);
11489 Preanalyze_And_Resolve (Temp, Typ);
11492 Resolve (Parg2, Typ);
11496 Process_Interrupt_Or_Attach_Handler;
11499 --------------------
11500 -- C_Pass_By_Copy --
11501 --------------------
11503 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11505 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
11511 Check_Valid_Configuration_Pragma;
11512 Check_Arg_Count (1);
11513 Check_Optional_Identifier (Arg1, "max_size");
11515 Arg := Get_Pragma_Arg (Arg1);
11516 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
11518 Val := Expr_Value (Arg);
11522 ("maximum size for pragma% must be positive", Arg1);
11524 elsif UI_Is_In_Int_Range (Val) then
11525 Default_C_Record_Mechanism := UI_To_Int (Val);
11527 -- If a giant value is given, Int'Last will do well enough.
11528 -- If sometime someone complains that a record larger than
11529 -- two gigabytes is not copied, we will worry about it then.
11532 Default_C_Record_Mechanism := Mechanism_Type'Last;
11534 end C_Pass_By_Copy;
11540 -- pragma Check ([Name =>] CHECK_KIND,
11541 -- [Check =>] Boolean_EXPRESSION
11542 -- [,[Message =>] String_EXPRESSION]);
11544 -- CHECK_KIND ::= IDENTIFIER |
11547 -- Invariant'Class |
11548 -- Type_Invariant'Class
11550 -- The identifiers Assertions and Statement_Assertions are not
11551 -- allowed, since they have special meaning for Check_Policy.
11553 when Pragma_Check => Check : declare
11554 GM : constant Ghost_Mode_Type := Ghost_Mode;
11561 -- Ensure that analysis and expansion produce Ghost nodes if the
11562 -- pragma itself is Ghost.
11564 Set_Ghost_Mode (N);
11567 Check_At_Least_N_Arguments (2);
11568 Check_At_Most_N_Arguments (3);
11569 Check_Optional_Identifier (Arg1, Name_Name);
11570 Check_Optional_Identifier (Arg2, Name_Check);
11572 if Arg_Count = 3 then
11573 Check_Optional_Identifier (Arg3, Name_Message);
11574 Str := Get_Pragma_Arg (Arg3);
11577 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
11578 Check_Arg_Is_Identifier (Arg1);
11579 Cname := Chars (Get_Pragma_Arg (Arg1));
11581 -- Check forbidden name Assertions or Statement_Assertions
11584 when Name_Assertions =>
11586 ("""Assertions"" is not allowed as a check kind for "
11587 & "pragma%", Arg1);
11589 when Name_Statement_Assertions =>
11591 ("""Statement_Assertions"" is not allowed as a check kind "
11592 & "for pragma%", Arg1);
11598 -- Check applicable policy. We skip this if Checked/Ignored status
11599 -- is already set (e.g. in the case of a pragma from an aspect).
11601 if Is_Checked (N) or else Is_Ignored (N) then
11604 -- For a non-source pragma that is a rewriting of another pragma,
11605 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11607 elsif Is_Rewrite_Substitution (N)
11608 and then Nkind (Original_Node (N)) = N_Pragma
11609 and then Original_Node (N) /= N
11611 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11612 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11614 -- Otherwise query the applicable policy at this point
11617 case Check_Kind (Cname) is
11618 when Name_Ignore =>
11619 Set_Is_Ignored (N, True);
11620 Set_Is_Checked (N, False);
11623 Set_Is_Ignored (N, False);
11624 Set_Is_Checked (N, True);
11626 -- For disable, rewrite pragma as null statement and skip
11627 -- rest of the analysis of the pragma.
11629 when Name_Disable =>
11630 Rewrite (N, Make_Null_Statement (Loc));
11634 -- No other possibilities
11637 raise Program_Error;
11641 -- If check kind was not Disable, then continue pragma analysis
11643 Expr := Get_Pragma_Arg (Arg2);
11645 -- Deal with SCO generation
11649 -- Nothing to do for invariants and predicates as the checks
11650 -- occur in the client units. The SCO for the aspect in the
11651 -- declaration unit is conservatively always enabled.
11653 when Name_Invariant | Name_Predicate =>
11656 -- Otherwise mark aspect/pragma SCO as enabled
11659 if Is_Checked (N) and then not Split_PPC (N) then
11660 Set_SCO_Pragma_Enabled (Loc);
11664 -- Deal with analyzing the string argument
11666 if Arg_Count = 3 then
11668 -- If checks are not on we don't want any expansion (since
11669 -- such expansion would not get properly deleted) but
11670 -- we do want to analyze (to get proper references).
11671 -- The Preanalyze_And_Resolve routine does just what we want
11673 if Is_Ignored (N) then
11674 Preanalyze_And_Resolve (Str, Standard_String);
11676 -- Otherwise we need a proper analysis and expansion
11679 Analyze_And_Resolve (Str, Standard_String);
11683 -- Now you might think we could just do the same with the Boolean
11684 -- expression if checks are off (and expansion is on) and then
11685 -- rewrite the check as a null statement. This would work but we
11686 -- would lose the useful warnings about an assertion being bound
11687 -- to fail even if assertions are turned off.
11689 -- So instead we wrap the boolean expression in an if statement
11690 -- that looks like:
11692 -- if False and then condition then
11696 -- The reason we do this rewriting during semantic analysis rather
11697 -- than as part of normal expansion is that we cannot analyze and
11698 -- expand the code for the boolean expression directly, or it may
11699 -- cause insertion of actions that would escape the attempt to
11700 -- suppress the check code.
11702 -- Note that the Sloc for the if statement corresponds to the
11703 -- argument condition, not the pragma itself. The reason for
11704 -- this is that we may generate a warning if the condition is
11705 -- False at compile time, and we do not want to delete this
11706 -- warning when we delete the if statement.
11708 if Expander_Active and Is_Ignored (N) then
11709 Eloc := Sloc (Expr);
11712 Make_If_Statement (Eloc,
11714 Make_And_Then (Eloc,
11715 Left_Opnd => Make_Identifier (Eloc, Name_False),
11716 Right_Opnd => Expr),
11717 Then_Statements => New_List (
11718 Make_Null_Statement (Eloc))));
11720 -- Now go ahead and analyze the if statement
11722 In_Assertion_Expr := In_Assertion_Expr + 1;
11724 -- One rather special treatment. If we are now in Eliminated
11725 -- overflow mode, then suppress overflow checking since we do
11726 -- not want to drag in the bignum stuff if we are in Ignore
11727 -- mode anyway. This is particularly important if we are using
11728 -- a configurable run time that does not support bignum ops.
11730 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
11732 Svo : constant Boolean :=
11733 Scope_Suppress.Suppress (Overflow_Check);
11735 Scope_Suppress.Overflow_Mode_Assertions := Strict;
11736 Scope_Suppress.Suppress (Overflow_Check) := True;
11738 Scope_Suppress.Suppress (Overflow_Check) := Svo;
11739 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
11742 -- Not that special case!
11748 -- All done with this check
11750 In_Assertion_Expr := In_Assertion_Expr - 1;
11752 -- Check is active or expansion not active. In these cases we can
11753 -- just go ahead and analyze the boolean with no worries.
11756 In_Assertion_Expr := In_Assertion_Expr + 1;
11757 Analyze_And_Resolve (Expr, Any_Boolean);
11758 In_Assertion_Expr := In_Assertion_Expr - 1;
11761 -- Restore the original Ghost mode once analysis and expansion
11762 -- have taken place.
11767 --------------------------
11768 -- Check_Float_Overflow --
11769 --------------------------
11771 -- pragma Check_Float_Overflow;
11773 when Pragma_Check_Float_Overflow =>
11775 Check_Valid_Configuration_Pragma;
11776 Check_Arg_Count (0);
11777 Check_Float_Overflow := not Machine_Overflows_On_Target;
11783 -- pragma Check_Name (check_IDENTIFIER);
11785 when Pragma_Check_Name =>
11787 Check_No_Identifiers;
11788 Check_Valid_Configuration_Pragma;
11789 Check_Arg_Count (1);
11790 Check_Arg_Is_Identifier (Arg1);
11793 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
11796 for J in Check_Names.First .. Check_Names.Last loop
11797 if Check_Names.Table (J) = Nam then
11802 Check_Names.Append (Nam);
11809 -- This is the old style syntax, which is still allowed in all modes:
11811 -- pragma Check_Policy ([Name =>] CHECK_KIND
11812 -- [Policy =>] POLICY_IDENTIFIER);
11814 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11816 -- CHECK_KIND ::= IDENTIFIER |
11819 -- Type_Invariant'Class |
11822 -- This is the new style syntax, compatible with Assertion_Policy
11823 -- and also allowed in all modes.
11825 -- Pragma Check_Policy (
11826 -- CHECK_KIND => POLICY_IDENTIFIER
11827 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11829 -- Note: the identifiers Name and Policy are not allowed as
11830 -- Check_Kind values. This avoids ambiguities between the old and
11831 -- new form syntax.
11833 when Pragma_Check_Policy => Check_Policy : declare
11839 Check_At_Least_N_Arguments (1);
11841 -- A Check_Policy pragma can appear either as a configuration
11842 -- pragma, or in a declarative part or a package spec (see RM
11843 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11844 -- followed for Check_Policy).
11846 if not Is_Configuration_Pragma then
11847 Check_Is_In_Decl_Part_Or_Package_Spec;
11850 -- Figure out if we have the old or new syntax. We have the
11851 -- old syntax if the first argument has no identifier, or the
11852 -- identifier is Name.
11854 if Nkind (Arg1) /= N_Pragma_Argument_Association
11855 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
11859 Check_Arg_Count (2);
11860 Check_Optional_Identifier (Arg1, Name_Name);
11861 Kind := Get_Pragma_Arg (Arg1);
11862 Rewrite_Assertion_Kind (Kind);
11863 Check_Arg_Is_Identifier (Arg1);
11865 -- Check forbidden check kind
11867 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
11868 Error_Msg_Name_2 := Chars (Kind);
11870 ("pragma% does not allow% as check name", Arg1);
11875 Check_Optional_Identifier (Arg2, Name_Policy);
11876 Check_Arg_Is_One_Of
11878 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
11879 Ident := Get_Pragma_Arg (Arg2);
11881 if Chars (Kind) = Name_Ghost then
11883 -- Pragma Check_Policy specifying a Ghost policy cannot
11884 -- occur within a ghost subprogram or package.
11886 if Ghost_Mode > None then
11888 ("pragma % cannot appear within ghost subprogram or "
11891 -- The policy identifier of pragma Ghost must be either
11892 -- Check or Ignore (SPARK RM 6.9(7)).
11894 elsif not Nam_In (Chars (Ident), Name_Check,
11898 ("argument of pragma % Ghost must be Check or Ignore",
11903 -- And chain pragma on the Check_Policy_List for search
11905 Set_Next_Pragma (N, Opt.Check_Policy_List);
11906 Opt.Check_Policy_List := N;
11908 -- For the new syntax, what we do is to convert each argument to
11909 -- an old syntax equivalent. We do that because we want to chain
11910 -- old style Check_Policy pragmas for the search (we don't want
11911 -- to have to deal with multiple arguments in the search).
11921 while Present (Arg) loop
11922 LocP := Sloc (Arg);
11923 Argx := Get_Pragma_Arg (Arg);
11925 -- Kind must be specified
11927 if Nkind (Arg) /= N_Pragma_Argument_Association
11928 or else Chars (Arg) = No_Name
11931 ("missing assertion kind for pragma%", Arg);
11934 -- Construct equivalent old form syntax Check_Policy
11935 -- pragma and insert it to get remaining checks.
11939 Chars => Name_Check_Policy,
11940 Pragma_Argument_Associations => New_List (
11941 Make_Pragma_Argument_Association (LocP,
11943 Make_Identifier (LocP, Chars (Arg))),
11944 Make_Pragma_Argument_Association (Sloc (Argx),
11945 Expression => Argx))));
11950 -- Rewrite original Check_Policy pragma to null, since we
11951 -- have converted it into a series of old syntax pragmas.
11953 Rewrite (N, Make_Null_Statement (Loc));
11959 ---------------------
11960 -- CIL_Constructor --
11961 ---------------------
11963 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11965 -- Processing for this pragma is shared with Java_Constructor
11971 -- pragma Comment (static_string_EXPRESSION)
11973 -- Processing for pragma Comment shares the circuitry for pragma
11974 -- Ident. The only differences are that Ident enforces a limit of 31
11975 -- characters on its argument, and also enforces limitations on
11976 -- placement for DEC compatibility. Pragma Comment shares neither of
11977 -- these restrictions.
11979 -------------------
11980 -- Common_Object --
11981 -------------------
11983 -- pragma Common_Object (
11984 -- [Internal =>] LOCAL_NAME
11985 -- [, [External =>] EXTERNAL_SYMBOL]
11986 -- [, [Size =>] EXTERNAL_SYMBOL]);
11988 -- Processing for this pragma is shared with Psect_Object
11990 ------------------------
11991 -- Compile_Time_Error --
11992 ------------------------
11994 -- pragma Compile_Time_Error
11995 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11997 when Pragma_Compile_Time_Error =>
11999 Process_Compile_Time_Warning_Or_Error;
12001 --------------------------
12002 -- Compile_Time_Warning --
12003 --------------------------
12005 -- pragma Compile_Time_Warning
12006 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12008 when Pragma_Compile_Time_Warning =>
12010 Process_Compile_Time_Warning_Or_Error;
12012 ---------------------------
12013 -- Compiler_Unit_Warning --
12014 ---------------------------
12016 -- pragma Compiler_Unit_Warning;
12020 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12021 -- errors not warnings. This means that we had introduced a big extra
12022 -- inertia to compiler changes, since even if we implemented a new
12023 -- feature, and even if all versions to be used for bootstrapping
12024 -- implemented this new feature, we could not use it, since old
12025 -- compilers would give errors for using this feature in units
12026 -- having Compiler_Unit pragmas.
12028 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12029 -- problem. We no longer have any units mentioning Compiler_Unit,
12030 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12031 -- and thus generates a warning which can be ignored. So that deals
12032 -- with the problem of old compilers not implementing the newer form
12035 -- Newer compilers recognize the new pragma, but generate warning
12036 -- messages instead of errors, which again can be ignored in the
12037 -- case of an old compiler which implements a wanted new feature
12038 -- but at the time felt like warning about it for older compilers.
12040 -- We retain Compiler_Unit so that new compilers can be used to build
12041 -- older run-times that use this pragma. That's an unusual case, but
12042 -- it's easy enough to handle, so why not?
12044 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12046 Check_Arg_Count (0);
12048 -- Only recognized in main unit
12050 if Current_Sem_Unit = Main_Unit then
12051 Compiler_Unit := True;
12054 -----------------------------
12055 -- Complete_Representation --
12056 -----------------------------
12058 -- pragma Complete_Representation;
12060 when Pragma_Complete_Representation =>
12062 Check_Arg_Count (0);
12064 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12066 ("pragma & must appear within record representation clause");
12069 ----------------------------
12070 -- Complex_Representation --
12071 ----------------------------
12073 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12075 when Pragma_Complex_Representation => Complex_Representation : declare
12082 Check_Arg_Count (1);
12083 Check_Optional_Identifier (Arg1, Name_Entity);
12084 Check_Arg_Is_Local_Name (Arg1);
12085 E_Id := Get_Pragma_Arg (Arg1);
12087 if Etype (E_Id) = Any_Type then
12091 E := Entity (E_Id);
12093 if not Is_Record_Type (E) then
12095 ("argument for pragma% must be record type", Arg1);
12098 Ent := First_Entity (E);
12101 or else No (Next_Entity (Ent))
12102 or else Present (Next_Entity (Next_Entity (Ent)))
12103 or else not Is_Floating_Point_Type (Etype (Ent))
12104 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12107 ("record for pragma% must have two fields of the same "
12108 & "floating-point type", Arg1);
12111 Set_Has_Complex_Representation (Base_Type (E));
12113 -- We need to treat the type has having a non-standard
12114 -- representation, for back-end purposes, even though in
12115 -- general a complex will have the default representation
12116 -- of a record with two real components.
12118 Set_Has_Non_Standard_Rep (Base_Type (E));
12120 end Complex_Representation;
12122 -------------------------
12123 -- Component_Alignment --
12124 -------------------------
12126 -- pragma Component_Alignment (
12127 -- [Form =>] ALIGNMENT_CHOICE
12128 -- [, [Name =>] type_LOCAL_NAME]);
12130 -- ALIGNMENT_CHOICE ::=
12132 -- | Component_Size_4
12136 when Pragma_Component_Alignment => Component_AlignmentP : declare
12137 Args : Args_List (1 .. 2);
12138 Names : constant Name_List (1 .. 2) := (
12142 Form : Node_Id renames Args (1);
12143 Name : Node_Id renames Args (2);
12145 Atype : Component_Alignment_Kind;
12150 Gather_Associations (Names, Args);
12153 Error_Pragma ("missing Form argument for pragma%");
12156 Check_Arg_Is_Identifier (Form);
12158 -- Get proper alignment, note that Default = Component_Size on all
12159 -- machines we have so far, and we want to set this value rather
12160 -- than the default value to indicate that it has been explicitly
12161 -- set (and thus will not get overridden by the default component
12162 -- alignment for the current scope)
12164 if Chars (Form) = Name_Component_Size then
12165 Atype := Calign_Component_Size;
12167 elsif Chars (Form) = Name_Component_Size_4 then
12168 Atype := Calign_Component_Size_4;
12170 elsif Chars (Form) = Name_Default then
12171 Atype := Calign_Component_Size;
12173 elsif Chars (Form) = Name_Storage_Unit then
12174 Atype := Calign_Storage_Unit;
12178 ("invalid Form parameter for pragma%", Form);
12181 -- Case with no name, supplied, affects scope table entry
12185 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12187 -- Case of name supplied
12190 Check_Arg_Is_Local_Name (Name);
12192 Typ := Entity (Name);
12195 or else Rep_Item_Too_Early (Typ, N)
12199 Typ := Underlying_Type (Typ);
12202 if not Is_Record_Type (Typ)
12203 and then not Is_Array_Type (Typ)
12206 ("Name parameter of pragma% must identify record or "
12207 & "array type", Name);
12210 -- An explicit Component_Alignment pragma overrides an
12211 -- implicit pragma Pack, but not an explicit one.
12213 if not Has_Pragma_Pack (Base_Type (Typ)) then
12214 Set_Is_Packed (Base_Type (Typ), False);
12215 Set_Component_Alignment (Base_Type (Typ), Atype);
12218 end Component_AlignmentP;
12220 --------------------
12221 -- Contract_Cases --
12222 --------------------
12224 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12226 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12228 -- CASE_GUARD ::= boolean_EXPRESSION | others
12230 -- CONSEQUENCE ::= boolean_EXPRESSION
12232 -- Characteristics:
12234 -- * Analysis - The annotation undergoes initial checks to verify
12235 -- the legal placement and context. Secondary checks preanalyze the
12238 -- Analyze_Contract_Cases_In_Decl_Part
12240 -- * Expansion - The annotation is expanded during the expansion of
12241 -- the related subprogram [body] contract as performed in:
12243 -- Expand_Subprogram_Contract
12245 -- * Template - The annotation utilizes the generic template of the
12246 -- related subprogram [body] when it is:
12248 -- aspect on subprogram declaration
12249 -- aspect on stand alone subprogram body
12250 -- pragma on stand alone subprogram body
12252 -- The annotation must prepare its own template when it is:
12254 -- pragma on subprogram declaration
12256 -- * Globals - Capture of global references must occur after full
12259 -- * Instance - The annotation is instantiated automatically when
12260 -- the related generic subprogram [body] is instantiated except for
12261 -- the "pragma on subprogram declaration" case. In that scenario
12262 -- the annotation must instantiate itself.
12264 when Pragma_Contract_Cases => Contract_Cases : declare
12265 Spec_Id : Entity_Id;
12266 Subp_Decl : Node_Id;
12270 Check_No_Identifiers;
12271 Check_Arg_Count (1);
12273 -- The pragma is analyzed at the end of the declarative part which
12274 -- contains the related subprogram. Reset the analyzed flag.
12276 Set_Analyzed (N, False);
12278 -- Ensure the proper placement of the pragma. Contract_Cases must
12279 -- be associated with a subprogram declaration or a body that acts
12283 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12285 -- Generic subprogram
12287 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
12290 -- Body acts as spec
12292 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12293 and then No (Corresponding_Spec (Subp_Decl))
12297 -- Body stub acts as spec
12299 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12300 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12306 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
12314 Spec_Id := Corresponding_Spec_Of (Subp_Decl);
12316 -- A pragma that applies to a Ghost entity becomes Ghost for the
12317 -- purposes of legality checks and removal of ignored Ghost code.
12319 Mark_Pragma_As_Ghost (N, Spec_Id);
12320 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
12322 -- Fully analyze the pragma when it appears inside a subprogram
12323 -- body because it cannot benefit from forward references.
12325 if Nkind (Subp_Decl) = N_Subprogram_Body then
12326 Analyze_Contract_Cases_In_Decl_Part (N);
12329 -- Chain the pragma on the contract for further processing by
12330 -- Analyze_Contract_Cases_In_Decl_Part.
12332 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12333 end Contract_Cases;
12339 -- pragma Controlled (first_subtype_LOCAL_NAME);
12341 when Pragma_Controlled => Controlled : declare
12345 Check_No_Identifiers;
12346 Check_Arg_Count (1);
12347 Check_Arg_Is_Local_Name (Arg1);
12348 Arg := Get_Pragma_Arg (Arg1);
12350 if not Is_Entity_Name (Arg)
12351 or else not Is_Access_Type (Entity (Arg))
12353 Error_Pragma_Arg ("pragma% requires access type", Arg1);
12355 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
12363 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12364 -- [Entity =>] LOCAL_NAME);
12366 when Pragma_Convention => Convention : declare
12369 pragma Warnings (Off, C);
12370 pragma Warnings (Off, E);
12372 Check_Arg_Order ((Name_Convention, Name_Entity));
12373 Check_Ada_83_Warning;
12374 Check_Arg_Count (2);
12375 Process_Convention (C, E);
12377 -- A pragma that applies to a Ghost entity becomes Ghost for the
12378 -- purposes of legality checks and removal of ignored Ghost code.
12380 Mark_Pragma_As_Ghost (N, E);
12383 ---------------------------
12384 -- Convention_Identifier --
12385 ---------------------------
12387 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12388 -- [Convention =>] convention_IDENTIFIER);
12390 when Pragma_Convention_Identifier => Convention_Identifier : declare
12396 Check_Arg_Order ((Name_Name, Name_Convention));
12397 Check_Arg_Count (2);
12398 Check_Optional_Identifier (Arg1, Name_Name);
12399 Check_Optional_Identifier (Arg2, Name_Convention);
12400 Check_Arg_Is_Identifier (Arg1);
12401 Check_Arg_Is_Identifier (Arg2);
12402 Idnam := Chars (Get_Pragma_Arg (Arg1));
12403 Cname := Chars (Get_Pragma_Arg (Arg2));
12405 if Is_Convention_Name (Cname) then
12406 Record_Convention_Identifier
12407 (Idnam, Get_Convention_Id (Cname));
12410 ("second arg for % pragma must be convention", Arg2);
12412 end Convention_Identifier;
12418 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12420 when Pragma_CPP_Class => CPP_Class : declare
12424 if Warn_On_Obsolescent_Feature then
12426 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12427 & "effect; replace it by pragma import?j?", N);
12430 Check_Arg_Count (1);
12434 Chars => Name_Import,
12435 Pragma_Argument_Associations => New_List (
12436 Make_Pragma_Argument_Association (Loc,
12437 Expression => Make_Identifier (Loc, Name_CPP)),
12438 New_Copy (First (Pragma_Argument_Associations (N))))));
12442 ---------------------
12443 -- CPP_Constructor --
12444 ---------------------
12446 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12447 -- [, [External_Name =>] static_string_EXPRESSION ]
12448 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12450 when Pragma_CPP_Constructor => CPP_Constructor : declare
12453 Def_Id : Entity_Id;
12454 Tag_Typ : Entity_Id;
12458 Check_At_Least_N_Arguments (1);
12459 Check_At_Most_N_Arguments (3);
12460 Check_Optional_Identifier (Arg1, Name_Entity);
12461 Check_Arg_Is_Local_Name (Arg1);
12463 Id := Get_Pragma_Arg (Arg1);
12464 Find_Program_Unit_Name (Id);
12466 -- If we did not find the name, we are done
12468 if Etype (Id) = Any_Type then
12472 Def_Id := Entity (Id);
12474 -- Check if already defined as constructor
12476 if Is_Constructor (Def_Id) then
12478 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
12482 if Ekind (Def_Id) = E_Function
12483 and then (Is_CPP_Class (Etype (Def_Id))
12484 or else (Is_Class_Wide_Type (Etype (Def_Id))
12486 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
12488 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
12490 ("'C'P'P constructor must be defined in the scope of "
12491 & "its returned type", Arg1);
12494 if Arg_Count >= 2 then
12495 Set_Imported (Def_Id);
12496 Set_Is_Public (Def_Id);
12497 Process_Interface_Name (Def_Id, Arg2, Arg3);
12500 Set_Has_Completion (Def_Id);
12501 Set_Is_Constructor (Def_Id);
12502 Set_Convention (Def_Id, Convention_CPP);
12504 -- Imported C++ constructors are not dispatching primitives
12505 -- because in C++ they don't have a dispatch table slot.
12506 -- However, in Ada the constructor has the profile of a
12507 -- function that returns a tagged type and therefore it has
12508 -- been treated as a primitive operation during semantic
12509 -- analysis. We now remove it from the list of primitive
12510 -- operations of the type.
12512 if Is_Tagged_Type (Etype (Def_Id))
12513 and then not Is_Class_Wide_Type (Etype (Def_Id))
12514 and then Is_Dispatching_Operation (Def_Id)
12516 Tag_Typ := Etype (Def_Id);
12518 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
12519 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
12523 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
12524 Set_Is_Dispatching_Operation (Def_Id, False);
12527 -- For backward compatibility, if the constructor returns a
12528 -- class wide type, and we internally change the return type to
12529 -- the corresponding root type.
12531 if Is_Class_Wide_Type (Etype (Def_Id)) then
12532 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
12536 ("pragma% requires function returning a 'C'P'P_Class type",
12539 end CPP_Constructor;
12545 when Pragma_CPP_Virtual => CPP_Virtual : declare
12549 if Warn_On_Obsolescent_Feature then
12551 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12560 when Pragma_CPP_Vtable => CPP_Vtable : declare
12564 if Warn_On_Obsolescent_Feature then
12566 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12575 -- pragma CPU (EXPRESSION);
12577 when Pragma_CPU => CPU : declare
12578 P : constant Node_Id := Parent (N);
12584 Check_No_Identifiers;
12585 Check_Arg_Count (1);
12589 if Nkind (P) = N_Subprogram_Body then
12590 Check_In_Main_Program;
12592 Arg := Get_Pragma_Arg (Arg1);
12593 Analyze_And_Resolve (Arg, Any_Integer);
12595 Ent := Defining_Unit_Name (Specification (P));
12597 if Nkind (Ent) = N_Defining_Program_Unit_Name then
12598 Ent := Defining_Identifier (Ent);
12603 if not Is_OK_Static_Expression (Arg) then
12604 Flag_Non_Static_Expr
12605 ("main subprogram affinity is not static!", Arg);
12608 -- If constraint error, then we already signalled an error
12610 elsif Raises_Constraint_Error (Arg) then
12613 -- Otherwise check in range
12617 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
12618 -- This is the entity System.Multiprocessors.CPU_Range;
12620 Val : constant Uint := Expr_Value (Arg);
12623 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
12625 Val > Expr_Value (Type_High_Bound (CPU_Id))
12628 ("main subprogram CPU is out of range", Arg1);
12634 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
12638 elsif Nkind (P) = N_Task_Definition then
12639 Arg := Get_Pragma_Arg (Arg1);
12640 Ent := Defining_Identifier (Parent (P));
12642 -- The expression must be analyzed in the special manner
12643 -- described in "Handling of Default and Per-Object
12644 -- Expressions" in sem.ads.
12646 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
12648 -- Anything else is incorrect
12654 -- Check duplicate pragma before we chain the pragma in the Rep
12655 -- Item chain of Ent.
12657 Check_Duplicate_Pragma (Ent);
12658 Record_Rep_Item (Ent, N);
12665 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12667 when Pragma_Debug => Debug : declare
12674 -- The condition for executing the call is that the expander
12675 -- is active and that we are not ignoring this debug pragma.
12680 (Expander_Active and then not Is_Ignored (N)),
12683 if not Is_Ignored (N) then
12684 Set_SCO_Pragma_Enabled (Loc);
12687 if Arg_Count = 2 then
12689 Make_And_Then (Loc,
12690 Left_Opnd => Relocate_Node (Cond),
12691 Right_Opnd => Get_Pragma_Arg (Arg1));
12692 Call := Get_Pragma_Arg (Arg2);
12694 Call := Get_Pragma_Arg (Arg1);
12698 N_Indexed_Component,
12702 N_Selected_Component)
12704 -- If this pragma Debug comes from source, its argument was
12705 -- parsed as a name form (which is syntactically identical).
12706 -- In a generic context a parameterless call will be left as
12707 -- an expanded name (if global) or selected_component if local.
12708 -- Change it to a procedure call statement now.
12710 Change_Name_To_Procedure_Call_Statement (Call);
12712 elsif Nkind (Call) = N_Procedure_Call_Statement then
12714 -- Already in the form of a procedure call statement: nothing
12715 -- to do (could happen in case of an internally generated
12721 -- All other cases: diagnose error
12724 ("argument of pragma ""Debug"" is not procedure call",
12729 -- Rewrite into a conditional with an appropriate condition. We
12730 -- wrap the procedure call in a block so that overhead from e.g.
12731 -- use of the secondary stack does not generate execution overhead
12732 -- for suppressed conditions.
12734 -- Normally the analysis that follows will freeze the subprogram
12735 -- being called. However, if the call is to a null procedure,
12736 -- we want to freeze it before creating the block, because the
12737 -- analysis that follows may be done with expansion disabled, in
12738 -- which case the body will not be generated, leading to spurious
12741 if Nkind (Call) = N_Procedure_Call_Statement
12742 and then Is_Entity_Name (Name (Call))
12744 Analyze (Name (Call));
12745 Freeze_Before (N, Entity (Name (Call)));
12749 Make_Implicit_If_Statement (N,
12751 Then_Statements => New_List (
12752 Make_Block_Statement (Loc,
12753 Handled_Statement_Sequence =>
12754 Make_Handled_Sequence_Of_Statements (Loc,
12755 Statements => New_List (Relocate_Node (Call)))))));
12758 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12759 -- after analysis of the normally rewritten node, to capture all
12760 -- references to entities, which avoids issuing wrong warnings
12761 -- about unused entities.
12763 if GNATprove_Mode then
12764 Rewrite (N, Make_Null_Statement (Loc));
12772 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12774 when Pragma_Debug_Policy =>
12776 Check_Arg_Count (1);
12777 Check_No_Identifiers;
12778 Check_Arg_Is_Identifier (Arg1);
12780 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12781 -- rewrite it that way, and let the rest of the checking come
12782 -- from analyzing the rewritten pragma.
12786 Chars => Name_Check_Policy,
12787 Pragma_Argument_Associations => New_List (
12788 Make_Pragma_Argument_Association (Loc,
12789 Expression => Make_Identifier (Loc, Name_Debug)),
12791 Make_Pragma_Argument_Association (Loc,
12792 Expression => Get_Pragma_Arg (Arg1)))));
12795 -------------------------------
12796 -- Default_Initial_Condition --
12797 -------------------------------
12799 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12801 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
12808 Check_No_Identifiers;
12809 Check_At_Most_N_Arguments (1);
12812 while Present (Stmt) loop
12814 -- Skip prior pragmas, but check for duplicates
12816 if Nkind (Stmt) = N_Pragma then
12817 if Pragma_Name (Stmt) = Pname then
12818 Error_Msg_Name_1 := Pname;
12819 Error_Msg_Sloc := Sloc (Stmt);
12820 Error_Msg_N ("pragma % duplicates pragma declared#", N);
12823 -- Skip internally generated code
12825 elsif not Comes_From_Source (Stmt) then
12828 -- The associated private type [extension] has been found, stop
12831 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
12832 N_Private_Type_Declaration)
12834 Typ := Defining_Entity (Stmt);
12837 -- The pragma does not apply to a legal construct, issue an
12838 -- error and stop the analysis.
12845 Stmt := Prev (Stmt);
12848 -- A pragma that applies to a Ghost entity becomes Ghost for the
12849 -- purposes of legality checks and removal of ignored Ghost code.
12851 Mark_Pragma_As_Ghost (N, Typ);
12852 Set_Has_Default_Init_Cond (Typ);
12853 Set_Has_Inherited_Default_Init_Cond (Typ, False);
12855 -- Chain the pragma on the rep item chain for further processing
12857 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
12858 end Default_Init_Cond;
12860 ----------------------------------
12861 -- Default_Scalar_Storage_Order --
12862 ----------------------------------
12864 -- pragma Default_Scalar_Storage_Order
12865 -- (High_Order_First | Low_Order_First);
12867 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
12868 Default : Character;
12872 Check_Arg_Count (1);
12874 -- Default_Scalar_Storage_Order can appear as a configuration
12875 -- pragma, or in a declarative part of a package spec.
12877 if not Is_Configuration_Pragma then
12878 Check_Is_In_Decl_Part_Or_Package_Spec;
12881 Check_No_Identifiers;
12882 Check_Arg_Is_One_Of
12883 (Arg1, Name_High_Order_First, Name_Low_Order_First);
12884 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12885 Default := Fold_Upper (Name_Buffer (1));
12887 if not Support_Nondefault_SSO_On_Target
12888 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
12890 if Warn_On_Unrecognized_Pragma then
12892 ("non-default Scalar_Storage_Order not supported "
12893 & "on target?g?", N);
12895 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
12898 -- Here set the specified default
12901 Opt.Default_SSO := Default;
12905 --------------------------
12906 -- Default_Storage_Pool --
12907 --------------------------
12909 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12911 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
12916 Check_Arg_Count (1);
12918 -- Default_Storage_Pool can appear as a configuration pragma, or
12919 -- in a declarative part of a package spec.
12921 if not Is_Configuration_Pragma then
12922 Check_Is_In_Decl_Part_Or_Package_Spec;
12925 if Present (Arg1) then
12926 Pool := Get_Pragma_Arg (Arg1);
12928 -- Case of Default_Storage_Pool (null);
12930 if Nkind (Pool) = N_Null then
12933 -- This is an odd case, this is not really an expression,
12934 -- so we don't have a type for it. So just set the type to
12937 Set_Etype (Pool, Empty);
12939 -- Case of Default_Storage_Pool (storage_pool_NAME);
12942 -- If it's a configuration pragma, then the only allowed
12943 -- argument is "null".
12945 if Is_Configuration_Pragma then
12946 Error_Pragma_Arg ("NULL expected", Arg1);
12949 -- The expected type for a non-"null" argument is
12950 -- Root_Storage_Pool'Class, and the pool must be a variable.
12952 Analyze_And_Resolve
12953 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
12955 if Is_Variable (Pool) then
12957 -- A pragma that applies to a Ghost entity becomes Ghost
12958 -- for the purposes of legality checks and removal of
12959 -- ignored Ghost code.
12961 Mark_Pragma_As_Ghost (N, Entity (Pool));
12965 ("default storage pool must be a variable", Arg1);
12969 -- Record the pool name (or null). Freeze.Freeze_Entity for an
12970 -- access type will use this information to set the appropriate
12971 -- attributes of the access type.
12973 Default_Pool := Pool;
12975 end Default_Storage_Pool;
12981 -- pragma Depends (DEPENDENCY_RELATION);
12983 -- DEPENDENCY_RELATION ::=
12985 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12987 -- DEPENDENCY_CLAUSE ::=
12988 -- OUTPUT_LIST =>[+] INPUT_LIST
12989 -- | NULL_DEPENDENCY_CLAUSE
12991 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12993 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12995 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12997 -- OUTPUT ::= NAME | FUNCTION_RESULT
13000 -- where FUNCTION_RESULT is a function Result attribute_reference
13002 -- Characteristics:
13004 -- * Analysis - The annotation undergoes initial checks to verify
13005 -- the legal placement and context. Secondary checks fully analyze
13006 -- the dependency clauses in:
13008 -- Analyze_Depends_In_Decl_Part
13010 -- * Expansion - None.
13012 -- * Template - The annotation utilizes the generic template of the
13013 -- related subprogram [body] when it is:
13015 -- aspect on subprogram declaration
13016 -- aspect on stand alone subprogram body
13017 -- pragma on stand alone subprogram body
13019 -- The annotation must prepare its own template when it is:
13021 -- pragma on subprogram declaration
13023 -- * Globals - Capture of global references must occur after full
13026 -- * Instance - The annotation is instantiated automatically when
13027 -- the related generic subprogram [body] is instantiated except for
13028 -- the "pragma on subprogram declaration" case. In that scenario
13029 -- the annotation must instantiate itself.
13031 when Pragma_Depends =>
13032 Analyze_Depends_Global;
13034 ---------------------
13035 -- Detect_Blocking --
13036 ---------------------
13038 -- pragma Detect_Blocking;
13040 when Pragma_Detect_Blocking =>
13042 Check_Arg_Count (0);
13043 Check_Valid_Configuration_Pragma;
13044 Detect_Blocking := True;
13046 ------------------------------------
13047 -- Disable_Atomic_Synchronization --
13048 ------------------------------------
13050 -- pragma Disable_Atomic_Synchronization [(Entity)];
13052 when Pragma_Disable_Atomic_Synchronization =>
13054 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13056 -------------------
13057 -- Discard_Names --
13058 -------------------
13060 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13062 when Pragma_Discard_Names => Discard_Names : declare
13067 Check_Ada_83_Warning;
13069 -- Deal with configuration pragma case
13071 if Arg_Count = 0 and then Is_Configuration_Pragma then
13072 Global_Discard_Names := True;
13075 -- Otherwise, check correct appropriate context
13078 Check_Is_In_Decl_Part_Or_Package_Spec;
13080 if Arg_Count = 0 then
13082 -- If there is no parameter, then from now on this pragma
13083 -- applies to any enumeration, exception or tagged type
13084 -- defined in the current declarative part, and recursively
13085 -- to any nested scope.
13087 Set_Discard_Names (Current_Scope);
13091 Check_Arg_Count (1);
13092 Check_Optional_Identifier (Arg1, Name_On);
13093 Check_Arg_Is_Local_Name (Arg1);
13095 E_Id := Get_Pragma_Arg (Arg1);
13097 if Etype (E_Id) = Any_Type then
13100 E := Entity (E_Id);
13103 -- A pragma that applies to a Ghost entity becomes Ghost for
13104 -- the purposes of legality checks and removal of ignored
13107 Mark_Pragma_As_Ghost (N, E);
13109 if (Is_First_Subtype (E)
13111 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13112 or else Ekind (E) = E_Exception
13114 Set_Discard_Names (E);
13115 Record_Rep_Item (E, N);
13119 ("inappropriate entity for pragma%", Arg1);
13125 ------------------------
13126 -- Dispatching_Domain --
13127 ------------------------
13129 -- pragma Dispatching_Domain (EXPRESSION);
13131 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13132 P : constant Node_Id := Parent (N);
13138 Check_No_Identifiers;
13139 Check_Arg_Count (1);
13141 -- This pragma is born obsolete, but not the aspect
13143 if not From_Aspect_Specification (N) then
13145 (No_Obsolescent_Features, Pragma_Identifier (N));
13148 if Nkind (P) = N_Task_Definition then
13149 Arg := Get_Pragma_Arg (Arg1);
13150 Ent := Defining_Identifier (Parent (P));
13152 -- A pragma that applies to a Ghost entity becomes Ghost for
13153 -- the purposes of legality checks and removal of ignored Ghost
13156 Mark_Pragma_As_Ghost (N, Ent);
13158 -- The expression must be analyzed in the special manner
13159 -- described in "Handling of Default and Per-Object
13160 -- Expressions" in sem.ads.
13162 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13164 -- Check duplicate pragma before we chain the pragma in the Rep
13165 -- Item chain of Ent.
13167 Check_Duplicate_Pragma (Ent);
13168 Record_Rep_Item (Ent, N);
13170 -- Anything else is incorrect
13175 end Dispatching_Domain;
13181 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13183 when Pragma_Elaborate => Elaborate : declare
13188 -- Pragma must be in context items list of a compilation unit
13190 if not Is_In_Context_Clause then
13194 -- Must be at least one argument
13196 if Arg_Count = 0 then
13197 Error_Pragma ("pragma% requires at least one argument");
13200 -- In Ada 83 mode, there can be no items following it in the
13201 -- context list except other pragmas and implicit with clauses
13202 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13203 -- placement rule does not apply.
13205 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13207 while Present (Citem) loop
13208 if Nkind (Citem) = N_Pragma
13209 or else (Nkind (Citem) = N_With_Clause
13210 and then Implicit_With (Citem))
13215 ("(Ada 83) pragma% must be at end of context clause");
13222 -- Finally, the arguments must all be units mentioned in a with
13223 -- clause in the same context clause. Note we already checked (in
13224 -- Par.Prag) that the arguments are all identifiers or selected
13228 Outer : while Present (Arg) loop
13229 Citem := First (List_Containing (N));
13230 Inner : while Citem /= N loop
13231 if Nkind (Citem) = N_With_Clause
13232 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13234 Set_Elaborate_Present (Citem, True);
13235 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13237 -- With the pragma present, elaboration calls on
13238 -- subprograms from the named unit need no further
13239 -- checks, as long as the pragma appears in the current
13240 -- compilation unit. If the pragma appears in some unit
13241 -- in the context, there might still be a need for an
13242 -- Elaborate_All_Desirable from the current compilation
13243 -- to the named unit, so we keep the check enabled.
13245 if In_Extended_Main_Source_Unit (N) then
13247 -- This does not apply in SPARK mode, where we allow
13248 -- pragma Elaborate, but we don't trust it to be right
13249 -- so we will still insist on the Elaborate_All.
13251 if SPARK_Mode /= On then
13252 Set_Suppress_Elaboration_Warnings
13253 (Entity (Name (Citem)));
13265 ("argument of pragma% is not withed unit", Arg);
13271 -- Give a warning if operating in static mode with one of the
13272 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13275 and not Dynamic_Elaboration_Checks
13277 -- pragma Elaborate not allowed in SPARK mode anyway. We
13278 -- already complained about it, no point in generating any
13279 -- further complaint.
13281 and SPARK_Mode /= On
13284 ("?l?use of pragma Elaborate may not be safe", N);
13286 ("?l?use pragma Elaborate_All instead if possible", N);
13290 -------------------
13291 -- Elaborate_All --
13292 -------------------
13294 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13296 when Pragma_Elaborate_All => Elaborate_All : declare
13301 Check_Ada_83_Warning;
13303 -- Pragma must be in context items list of a compilation unit
13305 if not Is_In_Context_Clause then
13309 -- Must be at least one argument
13311 if Arg_Count = 0 then
13312 Error_Pragma ("pragma% requires at least one argument");
13315 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13316 -- have to appear at the end of the context clause, but may
13317 -- appear mixed in with other items, even in Ada 83 mode.
13319 -- Final check: the arguments must all be units mentioned in
13320 -- a with clause in the same context clause. Note that we
13321 -- already checked (in Par.Prag) that all the arguments are
13322 -- either identifiers or selected components.
13325 Outr : while Present (Arg) loop
13326 Citem := First (List_Containing (N));
13327 Innr : while Citem /= N loop
13328 if Nkind (Citem) = N_With_Clause
13329 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13331 Set_Elaborate_All_Present (Citem, True);
13332 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13334 -- Suppress warnings and elaboration checks on the named
13335 -- unit if the pragma is in the current compilation, as
13336 -- for pragma Elaborate.
13338 if In_Extended_Main_Source_Unit (N) then
13339 Set_Suppress_Elaboration_Warnings
13340 (Entity (Name (Citem)));
13349 Set_Error_Posted (N);
13351 ("argument of pragma% is not withed unit", Arg);
13358 --------------------
13359 -- Elaborate_Body --
13360 --------------------
13362 -- pragma Elaborate_Body [( library_unit_NAME )];
13364 when Pragma_Elaborate_Body => Elaborate_Body : declare
13365 Cunit_Node : Node_Id;
13366 Cunit_Ent : Entity_Id;
13369 Check_Ada_83_Warning;
13370 Check_Valid_Library_Unit_Pragma;
13372 if Nkind (N) = N_Null_Statement then
13376 Cunit_Node := Cunit (Current_Sem_Unit);
13377 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
13379 -- A pragma that applies to a Ghost entity becomes Ghost for the
13380 -- purposes of legality checks and removal of ignored Ghost code.
13382 Mark_Pragma_As_Ghost (N, Cunit_Ent);
13384 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
13387 Error_Pragma ("pragma% must refer to a spec, not a body");
13389 Set_Body_Required (Cunit_Node, True);
13390 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
13392 -- If we are in dynamic elaboration mode, then we suppress
13393 -- elaboration warnings for the unit, since it is definitely
13394 -- fine NOT to do dynamic checks at the first level (and such
13395 -- checks will be suppressed because no elaboration boolean
13396 -- is created for Elaborate_Body packages).
13398 -- But in the static model of elaboration, Elaborate_Body is
13399 -- definitely NOT good enough to ensure elaboration safety on
13400 -- its own, since the body may WITH other units that are not
13401 -- safe from an elaboration point of view, so a client must
13402 -- still do an Elaborate_All on such units.
13404 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13405 -- Elaborate_Body always suppressed elab warnings.
13407 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
13408 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
13411 end Elaborate_Body;
13413 ------------------------
13414 -- Elaboration_Checks --
13415 ------------------------
13417 -- pragma Elaboration_Checks (Static | Dynamic);
13419 when Pragma_Elaboration_Checks =>
13421 Check_Arg_Count (1);
13422 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
13424 -- Set flag accordingly (ignore attempt at dynamic elaboration
13425 -- checks in SPARK mode).
13427 Dynamic_Elaboration_Checks :=
13428 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
13429 and then SPARK_Mode /= On;
13435 -- pragma Eliminate (
13436 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13437 -- [,[Entity =>] IDENTIFIER |
13438 -- SELECTED_COMPONENT |
13440 -- [, OVERLOADING_RESOLUTION]);
13442 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13445 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13446 -- FUNCTION_PROFILE
13448 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13450 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13451 -- Result_Type => result_SUBTYPE_NAME]
13453 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13454 -- SUBTYPE_NAME ::= STRING_LITERAL
13456 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13457 -- SOURCE_TRACE ::= STRING_LITERAL
13459 when Pragma_Eliminate => Eliminate : declare
13460 Args : Args_List (1 .. 5);
13461 Names : constant Name_List (1 .. 5) := (
13464 Name_Parameter_Types,
13466 Name_Source_Location);
13468 Unit_Name : Node_Id renames Args (1);
13469 Entity : Node_Id renames Args (2);
13470 Parameter_Types : Node_Id renames Args (3);
13471 Result_Type : Node_Id renames Args (4);
13472 Source_Location : Node_Id renames Args (5);
13476 Check_Valid_Configuration_Pragma;
13477 Gather_Associations (Names, Args);
13479 if No (Unit_Name) then
13480 Error_Pragma ("missing Unit_Name argument for pragma%");
13484 and then (Present (Parameter_Types)
13486 Present (Result_Type)
13488 Present (Source_Location))
13490 Error_Pragma ("missing Entity argument for pragma%");
13493 if (Present (Parameter_Types)
13495 Present (Result_Type))
13497 Present (Source_Location)
13500 ("parameter profile and source location cannot be used "
13501 & "together in pragma%");
13504 Process_Eliminate_Pragma
13513 -----------------------------------
13514 -- Enable_Atomic_Synchronization --
13515 -----------------------------------
13517 -- pragma Enable_Atomic_Synchronization [(Entity)];
13519 when Pragma_Enable_Atomic_Synchronization =>
13521 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
13528 -- [ Convention =>] convention_IDENTIFIER,
13529 -- [ Entity =>] LOCAL_NAME
13530 -- [, [External_Name =>] static_string_EXPRESSION ]
13531 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13533 when Pragma_Export => Export : declare
13535 Def_Id : Entity_Id;
13537 pragma Warnings (Off, C);
13540 Check_Ada_83_Warning;
13544 Name_External_Name,
13547 Check_At_Least_N_Arguments (2);
13548 Check_At_Most_N_Arguments (4);
13550 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13551 -- pragma Export (Entity, "external name");
13553 if Relaxed_RM_Semantics
13554 and then Arg_Count = 2
13555 and then Nkind (Expression (Arg2)) = N_String_Literal
13558 Def_Id := Get_Pragma_Arg (Arg1);
13561 if not Is_Entity_Name (Def_Id) then
13562 Error_Pragma_Arg ("entity name required", Arg1);
13565 Def_Id := Entity (Def_Id);
13566 Set_Exported (Def_Id, Arg1);
13569 Process_Convention (C, Def_Id);
13571 -- A pragma that applies to a Ghost entity becomes Ghost for
13572 -- the purposes of legality checks and removal of ignored Ghost
13575 Mark_Pragma_As_Ghost (N, Def_Id);
13577 if Ekind (Def_Id) /= E_Constant then
13578 Note_Possible_Modification
13579 (Get_Pragma_Arg (Arg2), Sure => False);
13582 Process_Interface_Name (Def_Id, Arg3, Arg4);
13583 Set_Exported (Def_Id, Arg2);
13586 -- If the entity is a deferred constant, propagate the information
13587 -- to the full view, because gigi elaborates the full view only.
13589 if Ekind (Def_Id) = E_Constant
13590 and then Present (Full_View (Def_Id))
13593 Id2 : constant Entity_Id := Full_View (Def_Id);
13595 Set_Is_Exported (Id2, Is_Exported (Def_Id));
13596 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
13597 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
13602 ---------------------
13603 -- Export_Function --
13604 ---------------------
13606 -- pragma Export_Function (
13607 -- [Internal =>] LOCAL_NAME
13608 -- [, [External =>] EXTERNAL_SYMBOL]
13609 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13610 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13611 -- [, [Mechanism =>] MECHANISM]
13612 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13614 -- EXTERNAL_SYMBOL ::=
13616 -- | static_string_EXPRESSION
13618 -- PARAMETER_TYPES ::=
13620 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13622 -- TYPE_DESIGNATOR ::=
13624 -- | subtype_Name ' Access
13628 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13630 -- MECHANISM_ASSOCIATION ::=
13631 -- [formal_parameter_NAME =>] MECHANISM_NAME
13633 -- MECHANISM_NAME ::=
13637 when Pragma_Export_Function => Export_Function : declare
13638 Args : Args_List (1 .. 6);
13639 Names : constant Name_List (1 .. 6) := (
13642 Name_Parameter_Types,
13645 Name_Result_Mechanism);
13647 Internal : Node_Id renames Args (1);
13648 External : Node_Id renames Args (2);
13649 Parameter_Types : Node_Id renames Args (3);
13650 Result_Type : Node_Id renames Args (4);
13651 Mechanism : Node_Id renames Args (5);
13652 Result_Mechanism : Node_Id renames Args (6);
13656 Gather_Associations (Names, Args);
13657 Process_Extended_Import_Export_Subprogram_Pragma (
13658 Arg_Internal => Internal,
13659 Arg_External => External,
13660 Arg_Parameter_Types => Parameter_Types,
13661 Arg_Result_Type => Result_Type,
13662 Arg_Mechanism => Mechanism,
13663 Arg_Result_Mechanism => Result_Mechanism);
13664 end Export_Function;
13666 -------------------
13667 -- Export_Object --
13668 -------------------
13670 -- pragma Export_Object (
13671 -- [Internal =>] LOCAL_NAME
13672 -- [, [External =>] EXTERNAL_SYMBOL]
13673 -- [, [Size =>] EXTERNAL_SYMBOL]);
13675 -- EXTERNAL_SYMBOL ::=
13677 -- | static_string_EXPRESSION
13679 -- PARAMETER_TYPES ::=
13681 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13683 -- TYPE_DESIGNATOR ::=
13685 -- | subtype_Name ' Access
13689 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13691 -- MECHANISM_ASSOCIATION ::=
13692 -- [formal_parameter_NAME =>] MECHANISM_NAME
13694 -- MECHANISM_NAME ::=
13698 when Pragma_Export_Object => Export_Object : declare
13699 Args : Args_List (1 .. 3);
13700 Names : constant Name_List (1 .. 3) := (
13705 Internal : Node_Id renames Args (1);
13706 External : Node_Id renames Args (2);
13707 Size : Node_Id renames Args (3);
13711 Gather_Associations (Names, Args);
13712 Process_Extended_Import_Export_Object_Pragma (
13713 Arg_Internal => Internal,
13714 Arg_External => External,
13718 ----------------------
13719 -- Export_Procedure --
13720 ----------------------
13722 -- pragma Export_Procedure (
13723 -- [Internal =>] LOCAL_NAME
13724 -- [, [External =>] EXTERNAL_SYMBOL]
13725 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13726 -- [, [Mechanism =>] MECHANISM]);
13728 -- EXTERNAL_SYMBOL ::=
13730 -- | static_string_EXPRESSION
13732 -- PARAMETER_TYPES ::=
13734 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13736 -- TYPE_DESIGNATOR ::=
13738 -- | subtype_Name ' Access
13742 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13744 -- MECHANISM_ASSOCIATION ::=
13745 -- [formal_parameter_NAME =>] MECHANISM_NAME
13747 -- MECHANISM_NAME ::=
13751 when Pragma_Export_Procedure => Export_Procedure : declare
13752 Args : Args_List (1 .. 4);
13753 Names : constant Name_List (1 .. 4) := (
13756 Name_Parameter_Types,
13759 Internal : Node_Id renames Args (1);
13760 External : Node_Id renames Args (2);
13761 Parameter_Types : Node_Id renames Args (3);
13762 Mechanism : Node_Id renames Args (4);
13766 Gather_Associations (Names, Args);
13767 Process_Extended_Import_Export_Subprogram_Pragma (
13768 Arg_Internal => Internal,
13769 Arg_External => External,
13770 Arg_Parameter_Types => Parameter_Types,
13771 Arg_Mechanism => Mechanism);
13772 end Export_Procedure;
13778 -- pragma Export_Value (
13779 -- [Value =>] static_integer_EXPRESSION,
13780 -- [Link_Name =>] static_string_EXPRESSION);
13782 when Pragma_Export_Value =>
13784 Check_Arg_Order ((Name_Value, Name_Link_Name));
13785 Check_Arg_Count (2);
13787 Check_Optional_Identifier (Arg1, Name_Value);
13788 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
13790 Check_Optional_Identifier (Arg2, Name_Link_Name);
13791 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
13793 -----------------------------
13794 -- Export_Valued_Procedure --
13795 -----------------------------
13797 -- pragma Export_Valued_Procedure (
13798 -- [Internal =>] LOCAL_NAME
13799 -- [, [External =>] EXTERNAL_SYMBOL,]
13800 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13801 -- [, [Mechanism =>] MECHANISM]);
13803 -- EXTERNAL_SYMBOL ::=
13805 -- | static_string_EXPRESSION
13807 -- PARAMETER_TYPES ::=
13809 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13811 -- TYPE_DESIGNATOR ::=
13813 -- | subtype_Name ' Access
13817 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13819 -- MECHANISM_ASSOCIATION ::=
13820 -- [formal_parameter_NAME =>] MECHANISM_NAME
13822 -- MECHANISM_NAME ::=
13826 when Pragma_Export_Valued_Procedure =>
13827 Export_Valued_Procedure : declare
13828 Args : Args_List (1 .. 4);
13829 Names : constant Name_List (1 .. 4) := (
13832 Name_Parameter_Types,
13835 Internal : Node_Id renames Args (1);
13836 External : Node_Id renames Args (2);
13837 Parameter_Types : Node_Id renames Args (3);
13838 Mechanism : Node_Id renames Args (4);
13842 Gather_Associations (Names, Args);
13843 Process_Extended_Import_Export_Subprogram_Pragma (
13844 Arg_Internal => Internal,
13845 Arg_External => External,
13846 Arg_Parameter_Types => Parameter_Types,
13847 Arg_Mechanism => Mechanism);
13848 end Export_Valued_Procedure;
13850 -------------------
13851 -- Extend_System --
13852 -------------------
13854 -- pragma Extend_System ([Name =>] Identifier);
13856 when Pragma_Extend_System => Extend_System : declare
13859 Check_Valid_Configuration_Pragma;
13860 Check_Arg_Count (1);
13861 Check_Optional_Identifier (Arg1, Name_Name);
13862 Check_Arg_Is_Identifier (Arg1);
13864 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13867 and then Name_Buffer (1 .. 4) = "aux_"
13869 if Present (System_Extend_Pragma_Arg) then
13870 if Chars (Get_Pragma_Arg (Arg1)) =
13871 Chars (Expression (System_Extend_Pragma_Arg))
13875 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
13876 Error_Pragma ("pragma% conflicts with that #");
13880 System_Extend_Pragma_Arg := Arg1;
13882 if not GNAT_Mode then
13883 System_Extend_Unit := Arg1;
13887 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
13891 ------------------------
13892 -- Extensions_Allowed --
13893 ------------------------
13895 -- pragma Extensions_Allowed (ON | OFF);
13897 when Pragma_Extensions_Allowed =>
13899 Check_Arg_Count (1);
13900 Check_No_Identifiers;
13901 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13903 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13904 Extensions_Allowed := True;
13905 Ada_Version := Ada_Version_Type'Last;
13908 Extensions_Allowed := False;
13909 Ada_Version := Ada_Version_Explicit;
13910 Ada_Version_Pragma := Empty;
13913 ------------------------
13914 -- Extensions_Visible --
13915 ------------------------
13917 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13919 -- Characteristics:
13921 -- * Analysis - The annotation is fully analyzed immediately upon
13922 -- elaboration as its expression must be static.
13924 -- * Expansion - None.
13926 -- * Template - The annotation utilizes the generic template of the
13927 -- related subprogram [body] when it is:
13929 -- aspect on subprogram declaration
13930 -- aspect on stand alone subprogram body
13931 -- pragma on stand alone subprogram body
13933 -- The annotation must prepare its own template when it is:
13935 -- pragma on subprogram declaration
13937 -- * Globals - Capture of global references must occur after full
13940 -- * Instance - The annotation is instantiated automatically when
13941 -- the related generic subprogram [body] is instantiated except for
13942 -- the "pragma on subprogram declaration" case. In that scenario
13943 -- the annotation must instantiate itself.
13945 when Pragma_Extensions_Visible => Extensions_Visible : declare
13947 Formal : Entity_Id;
13948 Has_OK_Formal : Boolean := False;
13949 Spec_Id : Entity_Id;
13950 Subp_Decl : Node_Id;
13954 Check_No_Identifiers;
13955 Check_At_Most_N_Arguments (1);
13958 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
13960 -- Generic subprogram declaration
13962 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13965 -- Body acts as spec
13967 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13968 and then No (Corresponding_Spec (Subp_Decl))
13972 -- Body stub acts as spec
13974 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13975 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13979 -- Subprogram declaration
13981 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13984 -- Otherwise the pragma is associated with an illegal construct
13987 Error_Pragma ("pragma % must apply to a subprogram");
13991 Spec_Id := Corresponding_Spec_Of (Subp_Decl);
13993 -- Mark the pragma as Ghost if the related subprogram is also
13994 -- Ghost. This also ensures that any expansion performed further
13995 -- below will produce Ghost nodes.
13997 Mark_Pragma_As_Ghost (N, Spec_Id);
13999 -- Examine the formals of the related subprogram
14001 Formal := First_Formal (Spec_Id);
14002 while Present (Formal) loop
14004 -- At least one of the formals is of a specific tagged type,
14005 -- the pragma is legal.
14007 if Is_Specific_Tagged_Type (Etype (Formal)) then
14008 Has_OK_Formal := True;
14011 -- A generic subprogram with at least one formal of a private
14012 -- type ensures the legality of the pragma because the actual
14013 -- may be specifically tagged. Note that this is verified by
14014 -- the check above at instantiation time.
14016 elsif Is_Private_Type (Etype (Formal))
14017 and then Is_Generic_Type (Etype (Formal))
14019 Has_OK_Formal := True;
14023 Next_Formal (Formal);
14026 if not Has_OK_Formal then
14027 Error_Msg_Name_1 := Pname;
14028 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
14030 ("\subprogram & lacks parameter of specific tagged or "
14031 & "generic private type", N, Spec_Id);
14036 -- Analyze the Boolean expression (if any)
14038 if Present (Arg1) then
14039 Expr := Expression (Get_Argument (N, Spec_Id));
14041 Analyze_And_Resolve (Expr, Standard_Boolean);
14043 if not Is_OK_Static_Expression (Expr) then
14045 ("expression of pragma % must be static", Expr);
14050 -- Chain the pragma on the contract for completeness
14052 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14053 end Extensions_Visible;
14059 -- pragma External (
14060 -- [ Convention =>] convention_IDENTIFIER,
14061 -- [ Entity =>] LOCAL_NAME
14062 -- [, [External_Name =>] static_string_EXPRESSION ]
14063 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14065 when Pragma_External => External : declare
14068 pragma Warnings (Off, C);
14075 Name_External_Name,
14077 Check_At_Least_N_Arguments (2);
14078 Check_At_Most_N_Arguments (4);
14079 Process_Convention (C, E);
14081 -- A pragma that applies to a Ghost entity becomes Ghost for the
14082 -- purposes of legality checks and removal of ignored Ghost code.
14084 Mark_Pragma_As_Ghost (N, E);
14086 Note_Possible_Modification
14087 (Get_Pragma_Arg (Arg2), Sure => False);
14088 Process_Interface_Name (E, Arg3, Arg4);
14089 Set_Exported (E, Arg2);
14092 --------------------------
14093 -- External_Name_Casing --
14094 --------------------------
14096 -- pragma External_Name_Casing (
14097 -- UPPERCASE | LOWERCASE
14098 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14100 when Pragma_External_Name_Casing => External_Name_Casing : declare
14103 Check_No_Identifiers;
14105 if Arg_Count = 2 then
14106 Check_Arg_Is_One_Of
14107 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14109 case Chars (Get_Pragma_Arg (Arg2)) is
14111 Opt.External_Name_Exp_Casing := As_Is;
14113 when Name_Uppercase =>
14114 Opt.External_Name_Exp_Casing := Uppercase;
14116 when Name_Lowercase =>
14117 Opt.External_Name_Exp_Casing := Lowercase;
14124 Check_Arg_Count (1);
14127 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14129 case Chars (Get_Pragma_Arg (Arg1)) is
14130 when Name_Uppercase =>
14131 Opt.External_Name_Imp_Casing := Uppercase;
14133 when Name_Lowercase =>
14134 Opt.External_Name_Imp_Casing := Lowercase;
14139 end External_Name_Casing;
14145 -- pragma Fast_Math;
14147 when Pragma_Fast_Math =>
14149 Check_No_Identifiers;
14150 Check_Valid_Configuration_Pragma;
14153 --------------------------
14154 -- Favor_Top_Level --
14155 --------------------------
14157 -- pragma Favor_Top_Level (type_NAME);
14159 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14164 Check_No_Identifiers;
14165 Check_Arg_Count (1);
14166 Check_Arg_Is_Local_Name (Arg1);
14167 Typ := Entity (Get_Pragma_Arg (Arg1));
14169 -- A pragma that applies to a Ghost entity becomes Ghost for the
14170 -- purposes of legality checks and removal of ignored Ghost code.
14172 Mark_Pragma_As_Ghost (N, Typ);
14174 -- If it's an access-to-subprogram type (in particular, not a
14175 -- subtype), set the flag on that type.
14177 if Is_Access_Subprogram_Type (Typ) then
14178 Set_Can_Use_Internal_Rep (Typ, False);
14180 -- Otherwise it's an error (name denotes the wrong sort of entity)
14184 ("access-to-subprogram type expected",
14185 Get_Pragma_Arg (Arg1));
14187 end Favor_Top_Level;
14189 ---------------------------
14190 -- Finalize_Storage_Only --
14191 ---------------------------
14193 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14195 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14196 Assoc : constant Node_Id := Arg1;
14197 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14202 Check_No_Identifiers;
14203 Check_Arg_Count (1);
14204 Check_Arg_Is_Local_Name (Arg1);
14206 Find_Type (Type_Id);
14207 Typ := Entity (Type_Id);
14210 or else Rep_Item_Too_Early (Typ, N)
14214 Typ := Underlying_Type (Typ);
14217 if not Is_Controlled (Typ) then
14218 Error_Pragma ("pragma% must specify controlled type");
14221 Check_First_Subtype (Arg1);
14223 if Finalize_Storage_Only (Typ) then
14224 Error_Pragma ("duplicate pragma%, only one allowed");
14226 elsif not Rep_Item_Too_Late (Typ, N) then
14227 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14229 end Finalize_Storage;
14235 -- pragma Ghost [ (boolean_EXPRESSION) ];
14237 when Pragma_Ghost => Ghost : declare
14241 Orig_Stmt : Node_Id;
14242 Prev_Id : Entity_Id;
14247 Check_No_Identifiers;
14248 Check_At_Most_N_Arguments (1);
14250 Context := Parent (N);
14252 -- Handle compilation units
14254 if Nkind (Context) = N_Compilation_Unit_Aux then
14255 Context := Unit (Parent (Context));
14260 while Present (Stmt) loop
14262 -- Skip prior pragmas, but check for duplicates
14264 if Nkind (Stmt) = N_Pragma then
14265 if Pragma_Name (Stmt) = Pname then
14266 Error_Msg_Name_1 := Pname;
14267 Error_Msg_Sloc := Sloc (Stmt);
14268 Error_Msg_N ("pragma % duplicates pragma declared#", N);
14271 -- Protected and task types cannot be subject to pragma Ghost
14272 -- (SPARK RM 6.9(19)).
14274 elsif Nkind (Stmt) = N_Protected_Type_Declaration then
14275 Error_Pragma ("pragma % cannot apply to a protected type");
14278 elsif Nkind (Stmt) = N_Task_Type_Declaration then
14279 Error_Pragma ("pragma % cannot apply to a task type");
14282 -- Skip internally generated code
14284 elsif not Comes_From_Source (Stmt) then
14285 Orig_Stmt := Original_Node (Stmt);
14287 -- When pragma Ghost applies to an untagged derivation, the
14288 -- derivation is transformed into a [sub]type declaration.
14290 if Nkind_In (Stmt, N_Full_Type_Declaration,
14291 N_Subtype_Declaration)
14292 and then Comes_From_Source (Orig_Stmt)
14293 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
14294 and then Nkind (Type_Definition (Orig_Stmt)) =
14295 N_Derived_Type_Definition
14297 Id := Defining_Entity (Stmt);
14300 -- When pragma Ghost applies to an expression function, the
14301 -- expression function is transformed into a subprogram.
14303 elsif Nkind (Stmt) = N_Subprogram_Declaration
14304 and then Comes_From_Source (Orig_Stmt)
14305 and then Nkind (Orig_Stmt) = N_Expression_Function
14307 Id := Defining_Entity (Stmt);
14311 -- The pragma applies to a legal construct, stop the traversal
14313 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
14314 N_Full_Type_Declaration,
14315 N_Generic_Subprogram_Declaration,
14316 N_Object_Declaration,
14317 N_Private_Extension_Declaration,
14318 N_Private_Type_Declaration,
14319 N_Subprogram_Declaration,
14320 N_Subtype_Declaration)
14322 Id := Defining_Entity (Stmt);
14325 -- The pragma does not apply to a legal construct, issue an
14326 -- error and stop the analysis.
14330 ("pragma % must apply to an object, package, subprogram "
14335 Stmt := Prev (Stmt);
14340 -- When pragma Ghost is associated with a [generic] package, it
14341 -- appears in the visible declarations.
14343 if Nkind (Context) = N_Package_Specification
14344 and then Present (Visible_Declarations (Context))
14345 and then List_Containing (N) = Visible_Declarations (Context)
14347 Id := Defining_Entity (Context);
14349 -- Pragma Ghost applies to a stand alone subprogram body
14351 elsif Nkind (Context) = N_Subprogram_Body
14352 and then No (Corresponding_Spec (Context))
14354 Id := Defining_Entity (Context);
14360 ("pragma % must apply to an object, package, subprogram or "
14365 -- A derived type or type extension cannot be subject to pragma
14366 -- Ghost if either the parent type or one of the progenitor types
14367 -- is not Ghost (SPARK RM 6.9(9)).
14369 if Is_Derived_Type (Id) then
14370 Check_Ghost_Derivation (Id);
14373 -- Handle completions of types and constants that are subject to
14376 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
14377 Prev_Id := Incomplete_Or_Partial_View (Id);
14379 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
14380 Error_Msg_Name_1 := Pname;
14382 -- The full declaration of a deferred constant cannot be
14383 -- subject to pragma Ghost unless the deferred declaration
14384 -- is also Ghost (SPARK RM 6.9(10)).
14386 if Ekind (Prev_Id) = E_Constant then
14387 Error_Msg_Name_1 := Pname;
14388 Error_Msg_NE (Fix_Error
14389 ("pragma % must apply to declaration of deferred "
14390 & "constant &"), N, Id);
14393 -- Pragma Ghost may appear on the full view of an incomplete
14394 -- type because the incomplete declaration lacks aspects and
14395 -- cannot be subject to pragma Ghost.
14397 elsif Ekind (Prev_Id) = E_Incomplete_Type then
14400 -- The full declaration of a type cannot be subject to
14401 -- pragma Ghost unless the partial view is also Ghost
14402 -- (SPARK RM 6.9(10)).
14405 Error_Msg_NE (Fix_Error
14406 ("pragma % must apply to partial view of type &"),
14412 -- A synchronized object cannot be subject to pragma Ghost
14413 -- (SPARK RM 6.9(19)).
14415 elsif Ekind (Id) = E_Variable then
14416 if Is_Protected_Type (Etype (Id)) then
14417 Error_Pragma ("pragma % cannot apply to a protected object");
14420 elsif Is_Task_Type (Etype (Id)) then
14421 Error_Pragma ("pragma % cannot apply to a task object");
14426 -- Analyze the Boolean expression (if any)
14428 if Present (Arg1) then
14429 Expr := Get_Pragma_Arg (Arg1);
14431 Analyze_And_Resolve (Expr, Standard_Boolean);
14433 if Is_OK_Static_Expression (Expr) then
14435 -- "Ghostness" cannot be turned off once enabled within a
14436 -- region (SPARK RM 6.9(7)).
14438 if Is_False (Expr_Value (Expr))
14439 and then Ghost_Mode > None
14442 ("pragma % with value False cannot appear in enabled "
14447 -- Otherwie the expression is not static
14451 ("expression of pragma % must be static", Expr);
14456 Set_Is_Ghost_Entity (Id);
14463 -- pragma Global (GLOBAL_SPECIFICATION);
14465 -- GLOBAL_SPECIFICATION ::=
14468 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14470 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14472 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14473 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14474 -- GLOBAL_ITEM ::= NAME
14476 -- Characteristics:
14478 -- * Analysis - The annotation undergoes initial checks to verify
14479 -- the legal placement and context. Secondary checks fully analyze
14480 -- the dependency clauses in:
14482 -- Analyze_Global_In_Decl_Part
14484 -- * Expansion - None.
14486 -- * Template - The annotation utilizes the generic template of the
14487 -- related subprogram [body] when it is:
14489 -- aspect on subprogram declaration
14490 -- aspect on stand alone subprogram body
14491 -- pragma on stand alone subprogram body
14493 -- The annotation must prepare its own template when it is:
14495 -- pragma on subprogram declaration
14497 -- * Globals - Capture of global references must occur after full
14500 -- * Instance - The annotation is instantiated automatically when
14501 -- the related generic subprogram [body] is instantiated except for
14502 -- the "pragma on subprogram declaration" case. In that scenario
14503 -- the annotation must instantiate itself.
14505 when Pragma_Global =>
14506 Analyze_Depends_Global;
14512 -- pragma Ident (static_string_EXPRESSION)
14514 -- Note: pragma Comment shares this processing. Pragma Ident is
14515 -- identical in effect to pragma Commment.
14517 when Pragma_Ident | Pragma_Comment => Ident : declare
14522 Check_Arg_Count (1);
14523 Check_No_Identifiers;
14524 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
14527 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
14534 GP := Parent (Parent (N));
14536 if Nkind_In (GP, N_Package_Declaration,
14537 N_Generic_Package_Declaration)
14542 -- If we have a compilation unit, then record the ident value,
14543 -- checking for improper duplication.
14545 if Nkind (GP) = N_Compilation_Unit then
14546 CS := Ident_String (Current_Sem_Unit);
14548 if Present (CS) then
14550 -- If we have multiple instances, concatenate them, but
14551 -- not in ASIS, where we want the original tree.
14553 if not ASIS_Mode then
14554 Start_String (Strval (CS));
14555 Store_String_Char (' ');
14556 Store_String_Chars (Strval (Str));
14557 Set_Strval (CS, End_String);
14561 Set_Ident_String (Current_Sem_Unit, Str);
14564 -- For subunits, we just ignore the Ident, since in GNAT these
14565 -- are not separate object files, and hence not separate units
14566 -- in the unit table.
14568 elsif Nkind (GP) = N_Subunit then
14574 -------------------
14575 -- Ignore_Pragma --
14576 -------------------
14578 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
14580 -- Entirely handled in the parser, nothing to do here
14582 when Pragma_Ignore_Pragma =>
14585 ----------------------------
14586 -- Implementation_Defined --
14587 ----------------------------
14589 -- pragma Implementation_Defined (LOCAL_NAME);
14591 -- Marks previously declared entity as implementation defined. For
14592 -- an overloaded entity, applies to the most recent homonym.
14594 -- pragma Implementation_Defined;
14596 -- The form with no arguments appears anywhere within a scope, most
14597 -- typically a package spec, and indicates that all entities that are
14598 -- defined within the package spec are Implementation_Defined.
14600 when Pragma_Implementation_Defined => Implementation_Defined : declare
14605 Check_No_Identifiers;
14607 -- Form with no arguments
14609 if Arg_Count = 0 then
14610 Set_Is_Implementation_Defined (Current_Scope);
14612 -- Form with one argument
14615 Check_Arg_Count (1);
14616 Check_Arg_Is_Local_Name (Arg1);
14617 Ent := Entity (Get_Pragma_Arg (Arg1));
14618 Set_Is_Implementation_Defined (Ent);
14620 end Implementation_Defined;
14626 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14628 -- IMPLEMENTATION_KIND ::=
14629 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14631 -- "By_Any" and "Optional" are treated as synonyms in order to
14632 -- support Ada 2012 aspect Synchronization.
14634 when Pragma_Implemented => Implemented : declare
14635 Proc_Id : Entity_Id;
14640 Check_Arg_Count (2);
14641 Check_No_Identifiers;
14642 Check_Arg_Is_Identifier (Arg1);
14643 Check_Arg_Is_Local_Name (Arg1);
14644 Check_Arg_Is_One_Of (Arg2,
14647 Name_By_Protected_Procedure,
14650 -- Extract the name of the local procedure
14652 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
14654 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14655 -- primitive procedure of a synchronized tagged type.
14657 if Ekind (Proc_Id) = E_Procedure
14658 and then Is_Primitive (Proc_Id)
14659 and then Present (First_Formal (Proc_Id))
14661 Typ := Etype (First_Formal (Proc_Id));
14663 if Is_Tagged_Type (Typ)
14666 -- Check for a protected, a synchronized or a task interface
14668 ((Is_Interface (Typ)
14669 and then Is_Synchronized_Interface (Typ))
14671 -- Check for a protected type or a task type that implements
14675 (Is_Concurrent_Record_Type (Typ)
14676 and then Present (Interfaces (Typ)))
14678 -- In analysis-only mode, examine original protected type
14681 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
14682 and then Present (Interface_List (Parent (Typ))))
14684 -- Check for a private record extension with keyword
14688 (Ekind_In (Typ, E_Record_Type_With_Private,
14689 E_Record_Subtype_With_Private)
14690 and then Synchronized_Present (Parent (Typ))))
14695 ("controlling formal must be of synchronized tagged type",
14700 -- Procedures declared inside a protected type must be accepted
14702 elsif Ekind (Proc_Id) = E_Procedure
14703 and then Is_Protected_Type (Scope (Proc_Id))
14707 -- The first argument is not a primitive procedure
14711 ("pragma % must be applied to a primitive procedure", Arg1);
14715 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14716 -- By_Protected_Procedure to the primitive procedure of a task
14719 if Chars (Arg2) = Name_By_Protected_Procedure
14720 and then Is_Interface (Typ)
14721 and then Is_Task_Interface (Typ)
14724 ("implementation kind By_Protected_Procedure cannot be "
14725 & "applied to a task interface primitive", Arg2);
14729 Record_Rep_Item (Proc_Id, N);
14732 ----------------------
14733 -- Implicit_Packing --
14734 ----------------------
14736 -- pragma Implicit_Packing;
14738 when Pragma_Implicit_Packing =>
14740 Check_Arg_Count (0);
14741 Implicit_Packing := True;
14748 -- [Convention =>] convention_IDENTIFIER,
14749 -- [Entity =>] LOCAL_NAME
14750 -- [, [External_Name =>] static_string_EXPRESSION ]
14751 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14753 when Pragma_Import =>
14754 Check_Ada_83_Warning;
14758 Name_External_Name,
14761 Check_At_Least_N_Arguments (2);
14762 Check_At_Most_N_Arguments (4);
14763 Process_Import_Or_Interface;
14765 ---------------------
14766 -- Import_Function --
14767 ---------------------
14769 -- pragma Import_Function (
14770 -- [Internal =>] LOCAL_NAME,
14771 -- [, [External =>] EXTERNAL_SYMBOL]
14772 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14773 -- [, [Result_Type =>] SUBTYPE_MARK]
14774 -- [, [Mechanism =>] MECHANISM]
14775 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14777 -- EXTERNAL_SYMBOL ::=
14779 -- | static_string_EXPRESSION
14781 -- PARAMETER_TYPES ::=
14783 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14785 -- TYPE_DESIGNATOR ::=
14787 -- | subtype_Name ' Access
14791 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14793 -- MECHANISM_ASSOCIATION ::=
14794 -- [formal_parameter_NAME =>] MECHANISM_NAME
14796 -- MECHANISM_NAME ::=
14800 when Pragma_Import_Function => Import_Function : declare
14801 Args : Args_List (1 .. 6);
14802 Names : constant Name_List (1 .. 6) := (
14805 Name_Parameter_Types,
14808 Name_Result_Mechanism);
14810 Internal : Node_Id renames Args (1);
14811 External : Node_Id renames Args (2);
14812 Parameter_Types : Node_Id renames Args (3);
14813 Result_Type : Node_Id renames Args (4);
14814 Mechanism : Node_Id renames Args (5);
14815 Result_Mechanism : Node_Id renames Args (6);
14819 Gather_Associations (Names, Args);
14820 Process_Extended_Import_Export_Subprogram_Pragma (
14821 Arg_Internal => Internal,
14822 Arg_External => External,
14823 Arg_Parameter_Types => Parameter_Types,
14824 Arg_Result_Type => Result_Type,
14825 Arg_Mechanism => Mechanism,
14826 Arg_Result_Mechanism => Result_Mechanism);
14827 end Import_Function;
14829 -------------------
14830 -- Import_Object --
14831 -------------------
14833 -- pragma Import_Object (
14834 -- [Internal =>] LOCAL_NAME
14835 -- [, [External =>] EXTERNAL_SYMBOL]
14836 -- [, [Size =>] EXTERNAL_SYMBOL]);
14838 -- EXTERNAL_SYMBOL ::=
14840 -- | static_string_EXPRESSION
14842 when Pragma_Import_Object => Import_Object : declare
14843 Args : Args_List (1 .. 3);
14844 Names : constant Name_List (1 .. 3) := (
14849 Internal : Node_Id renames Args (1);
14850 External : Node_Id renames Args (2);
14851 Size : Node_Id renames Args (3);
14855 Gather_Associations (Names, Args);
14856 Process_Extended_Import_Export_Object_Pragma (
14857 Arg_Internal => Internal,
14858 Arg_External => External,
14862 ----------------------
14863 -- Import_Procedure --
14864 ----------------------
14866 -- pragma Import_Procedure (
14867 -- [Internal =>] LOCAL_NAME
14868 -- [, [External =>] EXTERNAL_SYMBOL]
14869 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14870 -- [, [Mechanism =>] MECHANISM]);
14872 -- EXTERNAL_SYMBOL ::=
14874 -- | static_string_EXPRESSION
14876 -- PARAMETER_TYPES ::=
14878 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14880 -- TYPE_DESIGNATOR ::=
14882 -- | subtype_Name ' Access
14886 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14888 -- MECHANISM_ASSOCIATION ::=
14889 -- [formal_parameter_NAME =>] MECHANISM_NAME
14891 -- MECHANISM_NAME ::=
14895 when Pragma_Import_Procedure => Import_Procedure : declare
14896 Args : Args_List (1 .. 4);
14897 Names : constant Name_List (1 .. 4) := (
14900 Name_Parameter_Types,
14903 Internal : Node_Id renames Args (1);
14904 External : Node_Id renames Args (2);
14905 Parameter_Types : Node_Id renames Args (3);
14906 Mechanism : Node_Id renames Args (4);
14910 Gather_Associations (Names, Args);
14911 Process_Extended_Import_Export_Subprogram_Pragma (
14912 Arg_Internal => Internal,
14913 Arg_External => External,
14914 Arg_Parameter_Types => Parameter_Types,
14915 Arg_Mechanism => Mechanism);
14916 end Import_Procedure;
14918 -----------------------------
14919 -- Import_Valued_Procedure --
14920 -----------------------------
14922 -- pragma Import_Valued_Procedure (
14923 -- [Internal =>] LOCAL_NAME
14924 -- [, [External =>] EXTERNAL_SYMBOL]
14925 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14926 -- [, [Mechanism =>] MECHANISM]);
14928 -- EXTERNAL_SYMBOL ::=
14930 -- | static_string_EXPRESSION
14932 -- PARAMETER_TYPES ::=
14934 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14936 -- TYPE_DESIGNATOR ::=
14938 -- | subtype_Name ' Access
14942 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14944 -- MECHANISM_ASSOCIATION ::=
14945 -- [formal_parameter_NAME =>] MECHANISM_NAME
14947 -- MECHANISM_NAME ::=
14951 when Pragma_Import_Valued_Procedure =>
14952 Import_Valued_Procedure : declare
14953 Args : Args_List (1 .. 4);
14954 Names : constant Name_List (1 .. 4) := (
14957 Name_Parameter_Types,
14960 Internal : Node_Id renames Args (1);
14961 External : Node_Id renames Args (2);
14962 Parameter_Types : Node_Id renames Args (3);
14963 Mechanism : Node_Id renames Args (4);
14967 Gather_Associations (Names, Args);
14968 Process_Extended_Import_Export_Subprogram_Pragma (
14969 Arg_Internal => Internal,
14970 Arg_External => External,
14971 Arg_Parameter_Types => Parameter_Types,
14972 Arg_Mechanism => Mechanism);
14973 end Import_Valued_Procedure;
14979 -- pragma Independent (LOCAL_NAME);
14981 when Pragma_Independent =>
14982 Process_Atomic_Independent_Shared_Volatile;
14984 ----------------------------
14985 -- Independent_Components --
14986 ----------------------------
14988 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14990 when Pragma_Independent_Components => Independent_Components : declare
14998 Check_Ada_83_Warning;
15000 Check_No_Identifiers;
15001 Check_Arg_Count (1);
15002 Check_Arg_Is_Local_Name (Arg1);
15003 E_Id := Get_Pragma_Arg (Arg1);
15005 if Etype (E_Id) = Any_Type then
15009 E := Entity (E_Id);
15011 -- A pragma that applies to a Ghost entity becomes Ghost for the
15012 -- purposes of legality checks and removal of ignored Ghost code.
15014 Mark_Pragma_As_Ghost (N, E);
15016 -- Check duplicate before we chain ourselves
15018 Check_Duplicate_Pragma (E);
15020 -- Check appropriate entity
15022 if Rep_Item_Too_Early (E, N)
15024 Rep_Item_Too_Late (E, N)
15029 D := Declaration_Node (E);
15032 -- The flag is set on the base type, or on the object
15034 if K = N_Full_Type_Declaration
15035 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15037 Set_Has_Independent_Components (Base_Type (E));
15038 Record_Independence_Check (N, Base_Type (E));
15040 -- For record type, set all components independent
15042 if Is_Record_Type (E) then
15043 C := First_Component (E);
15044 while Present (C) loop
15045 Set_Is_Independent (C);
15046 Next_Component (C);
15050 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15051 and then Nkind (D) = N_Object_Declaration
15052 and then Nkind (Object_Definition (D)) =
15053 N_Constrained_Array_Definition
15055 Set_Has_Independent_Components (E);
15056 Record_Independence_Check (N, E);
15059 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15061 end Independent_Components;
15063 -----------------------
15064 -- Initial_Condition --
15065 -----------------------
15067 -- pragma Initial_Condition (boolean_EXPRESSION);
15069 -- Characteristics:
15071 -- * Analysis - The annotation undergoes initial checks to verify
15072 -- the legal placement and context. Secondary checks preanalyze the
15075 -- Analyze_Initial_Condition_In_Decl_Part
15077 -- * Expansion - The annotation is expanded during the expansion of
15078 -- the package body whose declaration is subject to the annotation
15081 -- Expand_Pragma_Initial_Condition
15083 -- * Template - The annotation utilizes the generic template of the
15084 -- related package declaration.
15086 -- * Globals - Capture of global references must occur after full
15089 -- * Instance - The annotation is instantiated automatically when
15090 -- the related generic package is instantiated.
15092 when Pragma_Initial_Condition => Initial_Condition : declare
15093 Pack_Decl : Node_Id;
15094 Pack_Id : Entity_Id;
15098 Check_No_Identifiers;
15099 Check_Arg_Count (1);
15101 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15103 -- Ensure the proper placement of the pragma. Initial_Condition
15104 -- must be associated with a package declaration.
15106 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15107 N_Package_Declaration)
15111 -- Otherwise the pragma is associated with an illegal context
15118 -- The pragma must be analyzed at the end of the visible
15119 -- declarations of the related package. Save the pragma for later
15120 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15121 -- the contract of the package.
15123 Pack_Id := Defining_Entity (Pack_Decl);
15125 -- A pragma that applies to a Ghost entity becomes Ghost for the
15126 -- purposes of legality checks and removal of ignored Ghost code.
15128 Mark_Pragma_As_Ghost (N, Pack_Id);
15130 -- Verify the declaration order of pragma Initial_Condition with
15131 -- respect to pragmas Abstract_State and Initializes when SPARK
15132 -- checks are enabled.
15134 if SPARK_Mode /= Off then
15135 Check_Declaration_Order
15136 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15139 Check_Declaration_Order
15140 (First => Get_Pragma (Pack_Id, Pragma_Initializes),
15144 -- Chain the pragma on the contract for further processing by
15145 -- Analyze_Initial_Condition_In_Decl_Part.
15147 Add_Contract_Item (N, Pack_Id);
15148 end Initial_Condition;
15150 ------------------------
15151 -- Initialize_Scalars --
15152 ------------------------
15154 -- pragma Initialize_Scalars;
15156 when Pragma_Initialize_Scalars =>
15158 Check_Arg_Count (0);
15159 Check_Valid_Configuration_Pragma;
15160 Check_Restriction (No_Initialize_Scalars, N);
15162 -- Initialize_Scalars creates false positives in CodePeer, and
15163 -- incorrect negative results in GNATprove mode, so ignore this
15164 -- pragma in these modes.
15166 if not Restriction_Active (No_Initialize_Scalars)
15167 and then not (CodePeer_Mode or GNATprove_Mode)
15169 Init_Or_Norm_Scalars := True;
15170 Initialize_Scalars := True;
15177 -- pragma Initializes (INITIALIZATION_SPEC);
15179 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15181 -- INITIALIZATION_LIST ::=
15182 -- INITIALIZATION_ITEM
15183 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15185 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15190 -- | (INPUT {, INPUT})
15194 -- Characteristics:
15196 -- * Analysis - The annotation undergoes initial checks to verify
15197 -- the legal placement and context. Secondary checks preanalyze the
15200 -- Analyze_Initializes_In_Decl_Part
15202 -- * Expansion - None.
15204 -- * Template - The annotation utilizes the generic template of the
15205 -- related package declaration.
15207 -- * Globals - Capture of global references must occur after full
15210 -- * Instance - The annotation is instantiated automatically when
15211 -- the related generic package is instantiated.
15213 when Pragma_Initializes => Initializes : declare
15214 Pack_Decl : Node_Id;
15215 Pack_Id : Entity_Id;
15219 Check_No_Identifiers;
15220 Check_Arg_Count (1);
15222 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15224 -- Ensure the proper placement of the pragma. Initializes must be
15225 -- associated with a package declaration.
15227 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15228 N_Package_Declaration)
15232 -- Otherwise the pragma is associated with an illegal construc
15239 Pack_Id := Defining_Entity (Pack_Decl);
15241 -- A pragma that applies to a Ghost entity becomes Ghost for the
15242 -- purposes of legality checks and removal of ignored Ghost code.
15244 Mark_Pragma_As_Ghost (N, Pack_Id);
15245 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
15247 -- Verify the declaration order of pragmas Abstract_State and
15248 -- Initializes when SPARK checks are enabled.
15250 if SPARK_Mode /= Off then
15251 Check_Declaration_Order
15252 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15256 -- Chain the pragma on the contract for further processing by
15257 -- Analyze_Initializes_In_Decl_Part.
15259 Add_Contract_Item (N, Pack_Id);
15266 -- pragma Inline ( NAME {, NAME} );
15268 when Pragma_Inline =>
15270 -- Pragma always active unless in GNATprove mode. It is disabled
15271 -- in GNATprove mode because frontend inlining is applied
15272 -- independently of pragmas Inline and Inline_Always for
15273 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15276 if not GNATprove_Mode then
15278 -- Inline status is Enabled if inlining option is active
15280 if Inline_Active then
15281 Process_Inline (Enabled);
15283 Process_Inline (Disabled);
15287 -------------------
15288 -- Inline_Always --
15289 -------------------
15291 -- pragma Inline_Always ( NAME {, NAME} );
15293 when Pragma_Inline_Always =>
15296 -- Pragma always active unless in CodePeer mode or GNATprove
15297 -- mode. It is disabled in CodePeer mode because inlining is
15298 -- not helpful, and enabling it caused walk order issues. It
15299 -- is disabled in GNATprove mode because frontend inlining is
15300 -- applied independently of pragmas Inline and Inline_Always for
15301 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15304 if not CodePeer_Mode and not GNATprove_Mode then
15305 Process_Inline (Enabled);
15308 --------------------
15309 -- Inline_Generic --
15310 --------------------
15312 -- pragma Inline_Generic (NAME {, NAME});
15314 when Pragma_Inline_Generic =>
15316 Process_Generic_List;
15318 ----------------------
15319 -- Inspection_Point --
15320 ----------------------
15322 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15324 when Pragma_Inspection_Point => Inspection_Point : declare
15331 if Arg_Count > 0 then
15334 Exp := Get_Pragma_Arg (Arg);
15337 if not Is_Entity_Name (Exp)
15338 or else not Is_Object (Entity (Exp))
15340 Error_Pragma_Arg ("object name required", Arg);
15344 exit when No (Arg);
15347 end Inspection_Point;
15353 -- pragma Interface (
15354 -- [ Convention =>] convention_IDENTIFIER,
15355 -- [ Entity =>] LOCAL_NAME
15356 -- [, [External_Name =>] static_string_EXPRESSION ]
15357 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15359 when Pragma_Interface =>
15364 Name_External_Name,
15366 Check_At_Least_N_Arguments (2);
15367 Check_At_Most_N_Arguments (4);
15368 Process_Import_Or_Interface;
15370 -- In Ada 2005, the permission to use Interface (a reserved word)
15371 -- as a pragma name is considered an obsolescent feature, and this
15372 -- pragma was already obsolescent in Ada 95.
15374 if Ada_Version >= Ada_95 then
15376 (No_Obsolescent_Features, Pragma_Identifier (N));
15378 if Warn_On_Obsolescent_Feature then
15380 ("pragma Interface is an obsolescent feature?j?", N);
15382 ("|use pragma Import instead?j?", N);
15386 --------------------
15387 -- Interface_Name --
15388 --------------------
15390 -- pragma Interface_Name (
15391 -- [ Entity =>] LOCAL_NAME
15392 -- [,[External_Name =>] static_string_EXPRESSION ]
15393 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15395 when Pragma_Interface_Name => Interface_Name : declare
15397 Def_Id : Entity_Id;
15398 Hom_Id : Entity_Id;
15404 ((Name_Entity, Name_External_Name, Name_Link_Name));
15405 Check_At_Least_N_Arguments (2);
15406 Check_At_Most_N_Arguments (3);
15407 Id := Get_Pragma_Arg (Arg1);
15410 -- This is obsolete from Ada 95 on, but it is an implementation
15411 -- defined pragma, so we do not consider that it violates the
15412 -- restriction (No_Obsolescent_Features).
15414 if Ada_Version >= Ada_95 then
15415 if Warn_On_Obsolescent_Feature then
15417 ("pragma Interface_Name is an obsolescent feature?j?", N);
15419 ("|use pragma Import instead?j?", N);
15423 if not Is_Entity_Name (Id) then
15425 ("first argument for pragma% must be entity name", Arg1);
15426 elsif Etype (Id) = Any_Type then
15429 Def_Id := Entity (Id);
15432 -- Special DEC-compatible processing for the object case, forces
15433 -- object to be imported.
15435 if Ekind (Def_Id) = E_Variable then
15436 Kill_Size_Check_Code (Def_Id);
15437 Note_Possible_Modification (Id, Sure => False);
15439 -- Initialization is not allowed for imported variable
15441 if Present (Expression (Parent (Def_Id)))
15442 and then Comes_From_Source (Expression (Parent (Def_Id)))
15444 Error_Msg_Sloc := Sloc (Def_Id);
15446 ("no initialization allowed for declaration of& #",
15450 -- For compatibility, support VADS usage of providing both
15451 -- pragmas Interface and Interface_Name to obtain the effect
15452 -- of a single Import pragma.
15454 if Is_Imported (Def_Id)
15455 and then Present (First_Rep_Item (Def_Id))
15456 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
15458 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
15462 Set_Imported (Def_Id);
15465 Set_Is_Public (Def_Id);
15466 Process_Interface_Name (Def_Id, Arg2, Arg3);
15469 -- Otherwise must be subprogram
15471 elsif not Is_Subprogram (Def_Id) then
15473 ("argument of pragma% is not subprogram", Arg1);
15476 Check_At_Most_N_Arguments (3);
15480 -- Loop through homonyms
15483 Def_Id := Get_Base_Subprogram (Hom_Id);
15485 if Is_Imported (Def_Id) then
15486 Process_Interface_Name (Def_Id, Arg2, Arg3);
15490 exit when From_Aspect_Specification (N);
15491 Hom_Id := Homonym (Hom_Id);
15493 exit when No (Hom_Id)
15494 or else Scope (Hom_Id) /= Current_Scope;
15499 ("argument of pragma% is not imported subprogram",
15503 end Interface_Name;
15505 -----------------------
15506 -- Interrupt_Handler --
15507 -----------------------
15509 -- pragma Interrupt_Handler (handler_NAME);
15511 when Pragma_Interrupt_Handler =>
15512 Check_Ada_83_Warning;
15513 Check_Arg_Count (1);
15514 Check_No_Identifiers;
15516 if No_Run_Time_Mode then
15517 Error_Msg_CRT ("Interrupt_Handler pragma", N);
15519 Check_Interrupt_Or_Attach_Handler;
15520 Process_Interrupt_Or_Attach_Handler;
15523 ------------------------
15524 -- Interrupt_Priority --
15525 ------------------------
15527 -- pragma Interrupt_Priority [(EXPRESSION)];
15529 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
15530 P : constant Node_Id := Parent (N);
15535 Check_Ada_83_Warning;
15537 if Arg_Count /= 0 then
15538 Arg := Get_Pragma_Arg (Arg1);
15539 Check_Arg_Count (1);
15540 Check_No_Identifiers;
15542 -- The expression must be analyzed in the special manner
15543 -- described in "Handling of Default and Per-Object
15544 -- Expressions" in sem.ads.
15546 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
15549 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
15554 Ent := Defining_Identifier (Parent (P));
15556 -- Check duplicate pragma before we chain the pragma in the Rep
15557 -- Item chain of Ent.
15559 Check_Duplicate_Pragma (Ent);
15560 Record_Rep_Item (Ent, N);
15562 end Interrupt_Priority;
15564 ---------------------
15565 -- Interrupt_State --
15566 ---------------------
15568 -- pragma Interrupt_State (
15569 -- [Name =>] INTERRUPT_ID,
15570 -- [State =>] INTERRUPT_STATE);
15572 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15573 -- INTERRUPT_STATE => System | Runtime | User
15575 -- Note: if the interrupt id is given as an identifier, then it must
15576 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15577 -- given as a static integer expression which must be in the range of
15578 -- Ada.Interrupts.Interrupt_ID.
15580 when Pragma_Interrupt_State => Interrupt_State : declare
15581 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
15582 -- This is the entity Ada.Interrupts.Interrupt_ID;
15584 State_Type : Character;
15585 -- Set to 's'/'r'/'u' for System/Runtime/User
15588 -- Index to entry in Interrupt_States table
15591 -- Value of interrupt
15593 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
15594 -- The first argument to the pragma
15596 Int_Ent : Entity_Id;
15597 -- Interrupt entity in Ada.Interrupts.Names
15601 Check_Arg_Order ((Name_Name, Name_State));
15602 Check_Arg_Count (2);
15604 Check_Optional_Identifier (Arg1, Name_Name);
15605 Check_Optional_Identifier (Arg2, Name_State);
15606 Check_Arg_Is_Identifier (Arg2);
15608 -- First argument is identifier
15610 if Nkind (Arg1X) = N_Identifier then
15612 -- Search list of names in Ada.Interrupts.Names
15614 Int_Ent := First_Entity (RTE (RE_Names));
15616 if No (Int_Ent) then
15617 Error_Pragma_Arg ("invalid interrupt name", Arg1);
15619 elsif Chars (Int_Ent) = Chars (Arg1X) then
15620 Int_Val := Expr_Value (Constant_Value (Int_Ent));
15624 Next_Entity (Int_Ent);
15627 -- First argument is not an identifier, so it must be a static
15628 -- expression of type Ada.Interrupts.Interrupt_ID.
15631 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
15632 Int_Val := Expr_Value (Arg1X);
15634 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
15636 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
15639 ("value not in range of type "
15640 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
15646 case Chars (Get_Pragma_Arg (Arg2)) is
15647 when Name_Runtime => State_Type := 'r';
15648 when Name_System => State_Type := 's';
15649 when Name_User => State_Type := 'u';
15652 Error_Pragma_Arg ("invalid interrupt state", Arg2);
15655 -- Check if entry is already stored
15657 IST_Num := Interrupt_States.First;
15659 -- If entry not found, add it
15661 if IST_Num > Interrupt_States.Last then
15662 Interrupt_States.Append
15663 ((Interrupt_Number => UI_To_Int (Int_Val),
15664 Interrupt_State => State_Type,
15665 Pragma_Loc => Loc));
15668 -- Case of entry for the same entry
15670 elsif Int_Val = Interrupt_States.Table (IST_Num).
15673 -- If state matches, done, no need to make redundant entry
15676 State_Type = Interrupt_States.Table (IST_Num).
15679 -- Otherwise if state does not match, error
15682 Interrupt_States.Table (IST_Num).Pragma_Loc;
15684 ("state conflicts with that given #", Arg2);
15688 IST_Num := IST_Num + 1;
15690 end Interrupt_State;
15696 -- pragma Invariant
15697 -- ([Entity =>] type_LOCAL_NAME,
15698 -- [Check =>] EXPRESSION
15699 -- [,[Message =>] String_Expression]);
15701 when Pragma_Invariant => Invariant : declare
15702 GM : constant Ghost_Mode_Type := Ghost_Mode;
15709 Check_At_Least_N_Arguments (2);
15710 Check_At_Most_N_Arguments (3);
15711 Check_Optional_Identifier (Arg1, Name_Entity);
15712 Check_Optional_Identifier (Arg2, Name_Check);
15714 if Arg_Count = 3 then
15715 Check_Optional_Identifier (Arg3, Name_Message);
15716 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
15719 Check_Arg_Is_Local_Name (Arg1);
15721 Type_Id := Get_Pragma_Arg (Arg1);
15722 Find_Type (Type_Id);
15723 Typ := Entity (Type_Id);
15725 if Typ = Any_Type then
15728 -- Invariants allowed in interface types (RM 7.3.2(3/3))
15730 elsif Is_Interface (Typ) then
15733 -- An invariant must apply to a private type, or appear in the
15734 -- private part of a package spec and apply to a completion.
15735 -- a class-wide invariant can only appear on a private declaration
15736 -- or private extension, not a completion.
15738 elsif Ekind_In (Typ, E_Private_Type,
15739 E_Record_Type_With_Private,
15740 E_Limited_Private_Type)
15744 elsif In_Private_Part (Current_Scope)
15745 and then Has_Private_Declaration (Typ)
15746 and then not Class_Present (N)
15750 elsif In_Private_Part (Current_Scope) then
15752 ("pragma% only allowed for private type declared in "
15753 & "visible part", Arg1);
15757 ("pragma% only allowed for private type", Arg1);
15760 -- A pragma that applies to a Ghost entity becomes Ghost for the
15761 -- purposes of legality checks and removal of ignored Ghost code.
15763 Mark_Pragma_As_Ghost (N, Typ);
15765 -- Not allowed for abstract type in the non-class case (it is
15766 -- allowed to use Invariant'Class for abstract types).
15768 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
15770 ("pragma% not allowed for abstract type", Arg1);
15773 -- Link the pragma on to the rep item chain, for processing when
15774 -- the type is frozen.
15776 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15778 -- Note that the type has at least one invariant, and also that
15779 -- it has inheritable invariants if we have Invariant'Class
15780 -- or Type_Invariant'Class. Build the corresponding invariant
15781 -- procedure declaration, so that calls to it can be generated
15782 -- before the body is built (e.g. within an expression function).
15784 -- Interface types have no invariant procedure; their invariants
15785 -- are propagated to the build invariant procedure of all the
15786 -- types covering the interface type.
15788 if not Is_Interface (Typ) then
15789 Insert_After_And_Analyze
15790 (N, Build_Invariant_Procedure_Declaration (Typ));
15793 if Class_Present (N) then
15794 Set_Has_Inheritable_Invariants (Typ);
15797 -- Restore the original Ghost mode once analysis and expansion
15798 -- have taken place.
15803 ----------------------
15804 -- Java_Constructor --
15805 ----------------------
15807 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15809 -- Also handles pragma CIL_Constructor
15811 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
15812 Java_Constructor : declare
15813 Convention : Convention_Id;
15814 Def_Id : Entity_Id;
15815 Hom_Id : Entity_Id;
15817 This_Formal : Entity_Id;
15821 Check_Arg_Count (1);
15822 Check_Optional_Identifier (Arg1, Name_Entity);
15823 Check_Arg_Is_Local_Name (Arg1);
15825 Id := Get_Pragma_Arg (Arg1);
15826 Find_Program_Unit_Name (Id);
15828 -- If we did not find the name, we are done
15830 if Etype (Id) = Any_Type then
15834 -- Check wrong use of pragma in wrong VM target
15836 if VM_Target = No_VM then
15839 elsif VM_Target = CLI_Target
15840 and then Prag_Id = Pragma_Java_Constructor
15842 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
15844 elsif VM_Target = JVM_Target
15845 and then Prag_Id = Pragma_CIL_Constructor
15847 Error_Pragma ("must use pragma 'Java_'Constructor");
15851 when Pragma_CIL_Constructor => Convention := Convention_CIL;
15852 when Pragma_Java_Constructor => Convention := Convention_Java;
15853 when others => null;
15856 Hom_Id := Entity (Id);
15858 -- Loop through homonyms
15861 Def_Id := Get_Base_Subprogram (Hom_Id);
15863 -- The constructor is required to be a function
15865 if Ekind (Def_Id) /= E_Function then
15866 if VM_Target = JVM_Target then
15868 ("pragma% requires function returning a 'Java access "
15872 ("pragma% requires function returning a 'C'I'L access "
15877 -- Check arguments: For tagged type the first formal must be
15878 -- named "this" and its type must be a named access type
15879 -- designating a class-wide tagged type that has convention
15880 -- CIL/Java. The first formal must also have a null default
15881 -- value. For example:
15883 -- type Typ is tagged ...
15884 -- type Ref is access all Typ;
15885 -- pragma Convention (CIL, Typ);
15887 -- function New_Typ (This : Ref) return Ref;
15888 -- function New_Typ (This : Ref; I : Integer) return Ref;
15889 -- pragma Cil_Constructor (New_Typ);
15891 -- Reason: The first formal must NOT be a primitive of the
15894 -- This rule also applies to constructors of delegates used
15895 -- to interface with standard target libraries. For example:
15897 -- type Delegate is access procedure ...
15898 -- pragma Import (CIL, Delegate, ...);
15900 -- function new_Delegate
15901 -- (This : Delegate := null; ... ) return Delegate;
15903 -- For value-types this rule does not apply.
15905 if not Is_Value_Type (Etype (Def_Id)) then
15906 if No (First_Formal (Def_Id)) then
15907 Error_Msg_Name_1 := Pname;
15908 Error_Msg_N ("% function must have parameters", Def_Id);
15912 -- In the JRE library we have several occurrences in which
15913 -- the "this" parameter is not the first formal.
15915 This_Formal := First_Formal (Def_Id);
15917 -- In the JRE library we have several occurrences in which
15918 -- the "this" parameter is not the first formal. Search for
15921 if VM_Target = JVM_Target then
15922 while Present (This_Formal)
15923 and then Get_Name_String (Chars (This_Formal)) /= "this"
15925 Next_Formal (This_Formal);
15928 if No (This_Formal) then
15929 This_Formal := First_Formal (Def_Id);
15933 -- Warning: The first parameter should be named "this".
15934 -- We temporarily allow it because we have the following
15935 -- case in the Java runtime (file s-osinte.ads) ???
15937 -- function new_Thread
15938 -- (Self_Id : System.Address) return Thread_Id;
15939 -- pragma Java_Constructor (new_Thread);
15941 if VM_Target = JVM_Target
15942 and then Get_Name_String (Chars (First_Formal (Def_Id)))
15944 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
15948 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
15949 Error_Msg_Name_1 := Pname;
15951 ("first formal of % function must be named `this`",
15952 Parent (This_Formal));
15954 elsif not Is_Access_Type (Etype (This_Formal)) then
15955 Error_Msg_Name_1 := Pname;
15957 ("first formal of % function must be an access type",
15958 Parameter_Type (Parent (This_Formal)));
15960 -- For delegates the type of the first formal must be a
15961 -- named access-to-subprogram type (see previous example)
15963 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
15964 and then Ekind (Etype (This_Formal))
15965 /= E_Access_Subprogram_Type
15967 Error_Msg_Name_1 := Pname;
15969 ("first formal of % function must be a named access "
15970 & "to subprogram type",
15971 Parameter_Type (Parent (This_Formal)));
15973 -- Warning: We should reject anonymous access types because
15974 -- the constructor must not be handled as a primitive of the
15975 -- tagged type. We temporarily allow it because this profile
15976 -- is currently generated by cil2ada???
15978 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
15979 and then not Ekind_In (Etype (This_Formal),
15981 E_General_Access_Type,
15982 E_Anonymous_Access_Type)
15984 Error_Msg_Name_1 := Pname;
15986 ("first formal of % function must be a named access "
15987 & "type", Parameter_Type (Parent (This_Formal)));
15989 elsif Atree.Convention
15990 (Designated_Type (Etype (This_Formal))) /= Convention
15992 Error_Msg_Name_1 := Pname;
15994 if Convention = Convention_Java then
15996 ("pragma% requires convention 'Cil in designated "
15997 & "type", Parameter_Type (Parent (This_Formal)));
16000 ("pragma% requires convention 'Java in designated "
16001 & "type", Parameter_Type (Parent (This_Formal)));
16004 elsif No (Expression (Parent (This_Formal)))
16005 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
16007 Error_Msg_Name_1 := Pname;
16009 ("pragma% requires first formal with default `null`",
16010 Parameter_Type (Parent (This_Formal)));
16014 -- Check result type: the constructor must be a function
16016 -- * a value type (only allowed in the CIL compiler)
16017 -- * an access-to-subprogram type with convention Java/CIL
16018 -- * an access-type designating a type that has convention
16021 if Is_Value_Type (Etype (Def_Id)) then
16024 -- Access-to-subprogram type with convention Java/CIL
16026 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
16027 if Atree.Convention (Etype (Def_Id)) /= Convention then
16028 if Convention = Convention_Java then
16030 ("pragma% requires function returning a 'Java "
16031 & "access type", Arg1);
16033 pragma Assert (Convention = Convention_CIL);
16035 ("pragma% requires function returning a 'C'I'L "
16036 & "access type", Arg1);
16040 elsif Is_Access_Type (Etype (Def_Id)) then
16041 if not Ekind_In (Etype (Def_Id), E_Access_Type,
16042 E_General_Access_Type)
16045 (Designated_Type (Etype (Def_Id))) /= Convention
16047 Error_Msg_Name_1 := Pname;
16049 if Convention = Convention_Java then
16051 ("pragma% requires function returning a named "
16052 & "'Java access type", Arg1);
16055 ("pragma% requires function returning a named "
16056 & "'C'I'L access type", Arg1);
16061 Set_Is_Constructor (Def_Id);
16062 Set_Convention (Def_Id, Convention);
16063 Set_Is_Imported (Def_Id);
16065 exit when From_Aspect_Specification (N);
16066 Hom_Id := Homonym (Hom_Id);
16068 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
16070 end Java_Constructor;
16072 ----------------------
16073 -- Java_Interface --
16074 ----------------------
16076 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16078 when Pragma_Java_Interface => Java_Interface : declare
16084 Check_Arg_Count (1);
16085 Check_Optional_Identifier (Arg1, Name_Entity);
16086 Check_Arg_Is_Local_Name (Arg1);
16088 Arg := Get_Pragma_Arg (Arg1);
16091 if Etype (Arg) = Any_Type then
16095 if not Is_Entity_Name (Arg)
16096 or else not Is_Type (Entity (Arg))
16098 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
16101 Typ := Underlying_Type (Entity (Arg));
16103 -- For now simply check some of the semantic constraints on the
16104 -- type. This currently leaves out some restrictions on interface
16105 -- types, namely that the parent type must be java.lang.Object.Typ
16106 -- and that all primitives of the type should be declared
16109 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
16111 ("pragma% requires an abstract tagged type", Arg1);
16113 elsif not Has_Discriminants (Typ)
16114 or else Ekind (Etype (First_Discriminant (Typ)))
16115 /= E_Anonymous_Access_Type
16117 not Is_Class_Wide_Type
16118 (Designated_Type (Etype (First_Discriminant (Typ))))
16121 ("type must have a class-wide access discriminant", Arg1);
16123 end Java_Interface;
16129 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16131 when Pragma_Keep_Names => Keep_Names : declare
16136 Check_Arg_Count (1);
16137 Check_Optional_Identifier (Arg1, Name_On);
16138 Check_Arg_Is_Local_Name (Arg1);
16140 Arg := Get_Pragma_Arg (Arg1);
16143 if Etype (Arg) = Any_Type then
16147 if not Is_Entity_Name (Arg)
16148 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16151 ("pragma% requires a local enumeration type", Arg1);
16154 Set_Discard_Names (Entity (Arg), False);
16161 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16163 when Pragma_License =>
16166 -- Do not analyze pragma any further in CodePeer mode, to avoid
16167 -- extraneous errors in this implementation-dependent pragma,
16168 -- which has a different profile on other compilers.
16170 if CodePeer_Mode then
16174 Check_Arg_Count (1);
16175 Check_No_Identifiers;
16176 Check_Valid_Configuration_Pragma;
16177 Check_Arg_Is_Identifier (Arg1);
16180 Sind : constant Source_File_Index :=
16181 Source_Index (Current_Sem_Unit);
16184 case Chars (Get_Pragma_Arg (Arg1)) is
16186 Set_License (Sind, GPL);
16188 when Name_Modified_GPL =>
16189 Set_License (Sind, Modified_GPL);
16191 when Name_Restricted =>
16192 Set_License (Sind, Restricted);
16194 when Name_Unrestricted =>
16195 Set_License (Sind, Unrestricted);
16198 Error_Pragma_Arg ("invalid license name", Arg1);
16206 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16208 when Pragma_Link_With => Link_With : declare
16214 if Operating_Mode = Generate_Code
16215 and then In_Extended_Main_Source_Unit (N)
16217 Check_At_Least_N_Arguments (1);
16218 Check_No_Identifiers;
16219 Check_Is_In_Decl_Part_Or_Package_Spec;
16220 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16224 while Present (Arg) loop
16225 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16227 -- Store argument, converting sequences of spaces to a
16228 -- single null character (this is one of the differences
16229 -- in processing between Link_With and Linker_Options).
16231 Arg_Store : declare
16232 C : constant Char_Code := Get_Char_Code (' ');
16233 S : constant String_Id :=
16234 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16235 L : constant Nat := String_Length (S);
16238 procedure Skip_Spaces;
16239 -- Advance F past any spaces
16245 procedure Skip_Spaces is
16247 while F <= L and then Get_String_Char (S, F) = C loop
16252 -- Start of processing for Arg_Store
16255 Skip_Spaces; -- skip leading spaces
16257 -- Loop through characters, changing any embedded
16258 -- sequence of spaces to a single null character (this
16259 -- is how Link_With/Linker_Options differ)
16262 if Get_String_Char (S, F) = C then
16265 Store_String_Char (ASCII.NUL);
16268 Store_String_Char (Get_String_Char (S, F));
16276 if Present (Arg) then
16277 Store_String_Char (ASCII.NUL);
16281 Store_Linker_Option_String (End_String);
16289 -- pragma Linker_Alias (
16290 -- [Entity =>] LOCAL_NAME
16291 -- [Target =>] static_string_EXPRESSION);
16293 when Pragma_Linker_Alias =>
16295 Check_Arg_Order ((Name_Entity, Name_Target));
16296 Check_Arg_Count (2);
16297 Check_Optional_Identifier (Arg1, Name_Entity);
16298 Check_Optional_Identifier (Arg2, Name_Target);
16299 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16300 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16302 -- The only processing required is to link this item on to the
16303 -- list of rep items for the given entity. This is accomplished
16304 -- by the call to Rep_Item_Too_Late (when no error is detected
16305 -- and False is returned).
16307 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16310 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16313 ------------------------
16314 -- Linker_Constructor --
16315 ------------------------
16317 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16319 -- Code is shared with Linker_Destructor
16321 -----------------------
16322 -- Linker_Destructor --
16323 -----------------------
16325 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16327 when Pragma_Linker_Constructor |
16328 Pragma_Linker_Destructor =>
16329 Linker_Constructor : declare
16335 Check_Arg_Count (1);
16336 Check_No_Identifiers;
16337 Check_Arg_Is_Local_Name (Arg1);
16338 Arg1_X := Get_Pragma_Arg (Arg1);
16340 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16342 if not Is_Library_Level_Entity (Proc) then
16344 ("argument for pragma% must be library level entity", Arg1);
16347 -- The only processing required is to link this item on to the
16348 -- list of rep items for the given entity. This is accomplished
16349 -- by the call to Rep_Item_Too_Late (when no error is detected
16350 -- and False is returned).
16352 if Rep_Item_Too_Late (Proc, N) then
16355 Set_Has_Gigi_Rep_Item (Proc);
16357 end Linker_Constructor;
16359 --------------------
16360 -- Linker_Options --
16361 --------------------
16363 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16365 when Pragma_Linker_Options => Linker_Options : declare
16369 Check_Ada_83_Warning;
16370 Check_No_Identifiers;
16371 Check_Arg_Count (1);
16372 Check_Is_In_Decl_Part_Or_Package_Spec;
16373 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16374 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16377 while Present (Arg) loop
16378 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16379 Store_String_Char (ASCII.NUL);
16381 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16385 if Operating_Mode = Generate_Code
16386 and then In_Extended_Main_Source_Unit (N)
16388 Store_Linker_Option_String (End_String);
16390 end Linker_Options;
16392 --------------------
16393 -- Linker_Section --
16394 --------------------
16396 -- pragma Linker_Section (
16397 -- [Entity =>] LOCAL_NAME
16398 -- [Section =>] static_string_EXPRESSION);
16400 when Pragma_Linker_Section => Linker_Section : declare
16405 Ghost_Error_Posted : Boolean := False;
16406 -- Flag set when an error concerning the illegal mix of Ghost and
16407 -- non-Ghost subprograms is emitted.
16409 Ghost_Id : Entity_Id := Empty;
16410 -- The entity of the first Ghost subprogram encountered while
16411 -- processing the arguments of the pragma.
16415 Check_Arg_Order ((Name_Entity, Name_Section));
16416 Check_Arg_Count (2);
16417 Check_Optional_Identifier (Arg1, Name_Entity);
16418 Check_Optional_Identifier (Arg2, Name_Section);
16419 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16420 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16422 -- Check kind of entity
16424 Arg := Get_Pragma_Arg (Arg1);
16425 Ent := Entity (Arg);
16427 case Ekind (Ent) is
16429 -- Objects (constants and variables) and types. For these cases
16430 -- all we need to do is to set the Linker_Section_pragma field,
16431 -- checking that we do not have a duplicate.
16433 when E_Constant | E_Variable | Type_Kind =>
16434 LPE := Linker_Section_Pragma (Ent);
16436 if Present (LPE) then
16437 Error_Msg_Sloc := Sloc (LPE);
16439 ("Linker_Section already specified for &#", Arg1, Ent);
16442 Set_Linker_Section_Pragma (Ent, N);
16444 -- A pragma that applies to a Ghost entity becomes Ghost for
16445 -- the purposes of legality checks and removal of ignored
16448 Mark_Pragma_As_Ghost (N, Ent);
16452 when Subprogram_Kind =>
16454 -- Aspect case, entity already set
16456 if From_Aspect_Specification (N) then
16457 Set_Linker_Section_Pragma
16458 (Entity (Corresponding_Aspect (N)), N);
16460 -- Pragma case, we must climb the homonym chain, but skip
16461 -- any for which the linker section is already set.
16465 if No (Linker_Section_Pragma (Ent)) then
16466 Set_Linker_Section_Pragma (Ent, N);
16468 -- A pragma that applies to a Ghost entity becomes
16469 -- Ghost for the purposes of legality checks and
16470 -- removal of ignored Ghost code.
16472 Mark_Pragma_As_Ghost (N, Ent);
16474 -- Capture the entity of the first Ghost subprogram
16475 -- being processed for error detection purposes.
16477 if Is_Ghost_Entity (Ent) then
16478 if No (Ghost_Id) then
16482 -- Otherwise the subprogram is non-Ghost. It is
16483 -- illegal to mix references to Ghost and non-Ghost
16484 -- entities (SPARK RM 6.9).
16486 elsif Present (Ghost_Id)
16487 and then not Ghost_Error_Posted
16489 Ghost_Error_Posted := True;
16491 Error_Msg_Name_1 := Pname;
16493 ("pragma % cannot mention ghost and "
16494 & "non-ghost subprograms", N);
16496 Error_Msg_Sloc := Sloc (Ghost_Id);
16498 ("\& # declared as ghost", N, Ghost_Id);
16500 Error_Msg_Sloc := Sloc (Ent);
16502 ("\& # declared as non-ghost", N, Ent);
16506 Ent := Homonym (Ent);
16508 or else Scope (Ent) /= Current_Scope;
16512 -- All other cases are illegal
16516 ("pragma% applies only to objects, subprograms, and types",
16519 end Linker_Section;
16525 -- pragma List (On | Off)
16527 -- There is nothing to do here, since we did all the processing for
16528 -- this pragma in Par.Prag (so that it works properly even in syntax
16531 when Pragma_List =>
16538 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16540 when Pragma_Lock_Free => Lock_Free : declare
16541 P : constant Node_Id := Parent (N);
16547 Check_No_Identifiers;
16548 Check_At_Most_N_Arguments (1);
16550 -- Protected definition case
16552 if Nkind (P) = N_Protected_Definition then
16553 Ent := Defining_Identifier (Parent (P));
16557 if Arg_Count = 1 then
16558 Arg := Get_Pragma_Arg (Arg1);
16559 Val := Is_True (Static_Boolean (Arg));
16561 -- No arguments (expression is considered to be True)
16567 -- Check duplicate pragma before we chain the pragma in the Rep
16568 -- Item chain of Ent.
16570 Check_Duplicate_Pragma (Ent);
16571 Record_Rep_Item (Ent, N);
16572 Set_Uses_Lock_Free (Ent, Val);
16574 -- Anything else is incorrect placement
16581 --------------------
16582 -- Locking_Policy --
16583 --------------------
16585 -- pragma Locking_Policy (policy_IDENTIFIER);
16587 when Pragma_Locking_Policy => declare
16588 subtype LP_Range is Name_Id
16589 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
16594 Check_Ada_83_Warning;
16595 Check_Arg_Count (1);
16596 Check_No_Identifiers;
16597 Check_Arg_Is_Locking_Policy (Arg1);
16598 Check_Valid_Configuration_Pragma;
16599 LP_Val := Chars (Get_Pragma_Arg (Arg1));
16602 when Name_Ceiling_Locking =>
16604 when Name_Inheritance_Locking =>
16606 when Name_Concurrent_Readers_Locking =>
16610 if Locking_Policy /= ' '
16611 and then Locking_Policy /= LP
16613 Error_Msg_Sloc := Locking_Policy_Sloc;
16614 Error_Pragma ("locking policy incompatible with policy#");
16616 -- Set new policy, but always preserve System_Location since we
16617 -- like the error message with the run time name.
16620 Locking_Policy := LP;
16622 if Locking_Policy_Sloc /= System_Location then
16623 Locking_Policy_Sloc := Loc;
16628 -------------------
16629 -- Loop_Optimize --
16630 -------------------
16632 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16634 -- OPTIMIZATION_HINT ::=
16635 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16637 when Pragma_Loop_Optimize => Loop_Optimize : declare
16642 Check_At_Least_N_Arguments (1);
16643 Check_No_Identifiers;
16645 Hint := First (Pragma_Argument_Associations (N));
16646 while Present (Hint) loop
16647 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
16655 Check_Loop_Pragma_Placement;
16662 -- pragma Loop_Variant
16663 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16665 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16667 -- CHANGE_DIRECTION ::= Increases | Decreases
16669 when Pragma_Loop_Variant => Loop_Variant : declare
16674 Check_At_Least_N_Arguments (1);
16675 Check_Loop_Pragma_Placement;
16677 -- Process all increasing / decreasing expressions
16679 Variant := First (Pragma_Argument_Associations (N));
16680 while Present (Variant) loop
16681 if not Nam_In (Chars (Variant), Name_Decreases,
16684 Error_Pragma_Arg ("wrong change modifier", Variant);
16687 Preanalyze_Assert_Expression
16688 (Expression (Variant), Any_Discrete);
16694 -----------------------
16695 -- Machine_Attribute --
16696 -----------------------
16698 -- pragma Machine_Attribute (
16699 -- [Entity =>] LOCAL_NAME,
16700 -- [Attribute_Name =>] static_string_EXPRESSION
16701 -- [, [Info =>] static_EXPRESSION] );
16703 when Pragma_Machine_Attribute => Machine_Attribute : declare
16704 Def_Id : Entity_Id;
16708 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
16710 if Arg_Count = 3 then
16711 Check_Optional_Identifier (Arg3, Name_Info);
16712 Check_Arg_Is_OK_Static_Expression (Arg3);
16714 Check_Arg_Count (2);
16717 Check_Optional_Identifier (Arg1, Name_Entity);
16718 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
16719 Check_Arg_Is_Local_Name (Arg1);
16720 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16721 Def_Id := Entity (Get_Pragma_Arg (Arg1));
16723 if Is_Access_Type (Def_Id) then
16724 Def_Id := Designated_Type (Def_Id);
16727 if Rep_Item_Too_Early (Def_Id, N) then
16731 Def_Id := Underlying_Type (Def_Id);
16733 -- The only processing required is to link this item on to the
16734 -- list of rep items for the given entity. This is accomplished
16735 -- by the call to Rep_Item_Too_Late (when no error is detected
16736 -- and False is returned).
16738 if Rep_Item_Too_Late (Def_Id, N) then
16741 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16743 end Machine_Attribute;
16750 -- (MAIN_OPTION [, MAIN_OPTION]);
16753 -- [STACK_SIZE =>] static_integer_EXPRESSION
16754 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16755 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16757 when Pragma_Main => Main : declare
16758 Args : Args_List (1 .. 3);
16759 Names : constant Name_List (1 .. 3) := (
16761 Name_Task_Stack_Size_Default,
16762 Name_Time_Slicing_Enabled);
16768 Gather_Associations (Names, Args);
16770 for J in 1 .. 2 loop
16771 if Present (Args (J)) then
16772 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16776 if Present (Args (3)) then
16777 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
16781 while Present (Nod) loop
16782 if Nkind (Nod) = N_Pragma
16783 and then Pragma_Name (Nod) = Name_Main
16785 Error_Msg_Name_1 := Pname;
16786 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16797 -- pragma Main_Storage
16798 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16800 -- MAIN_STORAGE_OPTION ::=
16801 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16802 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16804 when Pragma_Main_Storage => Main_Storage : declare
16805 Args : Args_List (1 .. 2);
16806 Names : constant Name_List (1 .. 2) := (
16807 Name_Working_Storage,
16814 Gather_Associations (Names, Args);
16816 for J in 1 .. 2 loop
16817 if Present (Args (J)) then
16818 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16822 Check_In_Main_Program;
16825 while Present (Nod) loop
16826 if Nkind (Nod) = N_Pragma
16827 and then Pragma_Name (Nod) = Name_Main_Storage
16829 Error_Msg_Name_1 := Pname;
16830 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16841 -- pragma Memory_Size (NUMERIC_LITERAL)
16843 when Pragma_Memory_Size =>
16846 -- Memory size is simply ignored
16848 Check_No_Identifiers;
16849 Check_Arg_Count (1);
16850 Check_Arg_Is_Integer_Literal (Arg1);
16858 -- The only correct use of this pragma is on its own in a file, in
16859 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16860 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16861 -- check for a file containing nothing but a No_Body pragma). If we
16862 -- attempt to process it during normal semantics processing, it means
16863 -- it was misplaced.
16865 when Pragma_No_Body =>
16869 -----------------------------
16870 -- No_Elaboration_Code_All --
16871 -----------------------------
16873 -- pragma No_Elaboration_Code_All;
16875 when Pragma_No_Elaboration_Code_All =>
16877 Check_Valid_Library_Unit_Pragma;
16879 if Nkind (N) = N_Null_Statement then
16883 -- Must appear for a spec or generic spec
16885 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
16886 N_Generic_Package_Declaration,
16887 N_Generic_Subprogram_Declaration,
16888 N_Package_Declaration,
16889 N_Subprogram_Declaration)
16893 ("pragma% can only occur for package "
16894 & "or subprogram spec"));
16897 -- Set flag in unit table
16899 Set_No_Elab_Code_All (Current_Sem_Unit);
16901 -- Set restriction No_Elaboration_Code if this is the main unit
16903 if Current_Sem_Unit = Main_Unit then
16904 Set_Restriction (No_Elaboration_Code, N);
16907 -- If we are in the main unit or in an extended main source unit,
16908 -- then we also add it to the configuration restrictions so that
16909 -- it will apply to all units in the extended main source.
16911 if Current_Sem_Unit = Main_Unit
16912 or else In_Extended_Main_Source_Unit (N)
16914 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
16917 -- If in main extended unit, activate transitive with test
16919 if In_Extended_Main_Source_Unit (N) then
16920 Opt.No_Elab_Code_All_Pragma := N;
16927 -- pragma No_Inline ( NAME {, NAME} );
16929 when Pragma_No_Inline =>
16931 Process_Inline (Suppressed);
16937 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16939 when Pragma_No_Return => No_Return : declare
16945 Ghost_Error_Posted : Boolean := False;
16946 -- Flag set when an error concerning the illegal mix of Ghost and
16947 -- non-Ghost subprograms is emitted.
16949 Ghost_Id : Entity_Id := Empty;
16950 -- The entity of the first Ghost procedure encountered while
16951 -- processing the arguments of the pragma.
16955 Check_At_Least_N_Arguments (1);
16957 -- Loop through arguments of pragma
16960 while Present (Arg) loop
16961 Check_Arg_Is_Local_Name (Arg);
16962 Id := Get_Pragma_Arg (Arg);
16965 if not Is_Entity_Name (Id) then
16966 Error_Pragma_Arg ("entity name required", Arg);
16969 if Etype (Id) = Any_Type then
16973 -- Loop to find matching procedures
16979 and then Scope (E) = Current_Scope
16981 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
16984 -- A pragma that applies to a Ghost entity becomes Ghost
16985 -- for the purposes of legality checks and removal of
16986 -- ignored Ghost code.
16988 Mark_Pragma_As_Ghost (N, E);
16990 -- Capture the entity of the first Ghost procedure being
16991 -- processed for error detection purposes.
16993 if Is_Ghost_Entity (E) then
16994 if No (Ghost_Id) then
16998 -- Otherwise the subprogram is non-Ghost. It is illegal
16999 -- to mix references to Ghost and non-Ghost entities
17002 elsif Present (Ghost_Id)
17003 and then not Ghost_Error_Posted
17005 Ghost_Error_Posted := True;
17007 Error_Msg_Name_1 := Pname;
17009 ("pragma % cannot mention ghost and non-ghost "
17010 & "procedures", N);
17012 Error_Msg_Sloc := Sloc (Ghost_Id);
17013 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17015 Error_Msg_Sloc := Sloc (E);
17016 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17019 -- Set flag on any alias as well
17021 if Is_Overloadable (E) and then Present (Alias (E)) then
17022 Set_No_Return (Alias (E));
17028 exit when From_Aspect_Specification (N);
17032 -- If entity in not in current scope it may be the enclosing
17033 -- suprogram body to which the aspect applies.
17036 if Entity (Id) = Current_Scope
17037 and then From_Aspect_Specification (N)
17039 Set_No_Return (Entity (Id));
17041 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17053 -- pragma No_Run_Time;
17055 -- Note: this pragma is retained for backwards compatibility. See
17056 -- body of Rtsfind for full details on its handling.
17058 when Pragma_No_Run_Time =>
17060 Check_Valid_Configuration_Pragma;
17061 Check_Arg_Count (0);
17063 No_Run_Time_Mode := True;
17064 Configurable_Run_Time_Mode := True;
17066 -- Set Duration to 32 bits if word size is 32
17068 if Ttypes.System_Word_Size = 32 then
17069 Duration_32_Bits_On_Target := True;
17072 -- Set appropriate restrictions
17074 Set_Restriction (No_Finalization, N);
17075 Set_Restriction (No_Exception_Handlers, N);
17076 Set_Restriction (Max_Tasks, N, 0);
17077 Set_Restriction (No_Tasking, N);
17079 -----------------------
17080 -- No_Tagged_Streams --
17081 -----------------------
17083 -- pragma No_Tagged_Streams;
17084 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17086 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17092 Check_At_Most_N_Arguments (1);
17094 -- One argument case
17096 if Arg_Count = 1 then
17097 Check_Optional_Identifier (Arg1, Name_Entity);
17098 Check_Arg_Is_Local_Name (Arg1);
17099 E_Id := Get_Pragma_Arg (Arg1);
17101 if Etype (E_Id) = Any_Type then
17105 E := Entity (E_Id);
17107 Check_Duplicate_Pragma (E);
17109 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17111 ("argument for pragma% must be root tagged type", Arg1);
17114 if Rep_Item_Too_Early (E, N)
17116 Rep_Item_Too_Late (E, N)
17120 Set_No_Tagged_Streams_Pragma (E, N);
17123 -- Zero argument case
17126 Check_Is_In_Decl_Part_Or_Package_Spec;
17127 No_Tagged_Streams := N;
17129 end No_Tagged_Strms;
17131 ------------------------
17132 -- No_Strict_Aliasing --
17133 ------------------------
17135 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17137 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17142 Check_At_Most_N_Arguments (1);
17144 if Arg_Count = 0 then
17145 Check_Valid_Configuration_Pragma;
17146 Opt.No_Strict_Aliasing := True;
17149 Check_Optional_Identifier (Arg2, Name_Entity);
17150 Check_Arg_Is_Local_Name (Arg1);
17151 E_Id := Entity (Get_Pragma_Arg (Arg1));
17153 if E_Id = Any_Type then
17155 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17156 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17159 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17161 end No_Strict_Aliasing;
17163 -----------------------
17164 -- Normalize_Scalars --
17165 -----------------------
17167 -- pragma Normalize_Scalars;
17169 when Pragma_Normalize_Scalars =>
17170 Check_Ada_83_Warning;
17171 Check_Arg_Count (0);
17172 Check_Valid_Configuration_Pragma;
17174 -- Normalize_Scalars creates false positives in CodePeer, and
17175 -- incorrect negative results in GNATprove mode, so ignore this
17176 -- pragma in these modes.
17178 if not (CodePeer_Mode or GNATprove_Mode) then
17179 Normalize_Scalars := True;
17180 Init_Or_Norm_Scalars := True;
17187 -- pragma Obsolescent;
17189 -- pragma Obsolescent (
17190 -- [Message =>] static_string_EXPRESSION
17191 -- [,[Version =>] Ada_05]]);
17193 -- pragma Obsolescent (
17194 -- [Entity =>] NAME
17195 -- [,[Message =>] static_string_EXPRESSION
17196 -- [,[Version =>] Ada_05]] );
17198 when Pragma_Obsolescent => Obsolescent : declare
17202 procedure Set_Obsolescent (E : Entity_Id);
17203 -- Given an entity Ent, mark it as obsolescent if appropriate
17205 ---------------------
17206 -- Set_Obsolescent --
17207 ---------------------
17209 procedure Set_Obsolescent (E : Entity_Id) is
17218 -- A pragma that applies to a Ghost entity becomes Ghost for
17219 -- the purposes of legality checks and removal of ignored Ghost
17222 Mark_Pragma_As_Ghost (N, E);
17224 -- Entity name was given
17226 if Present (Ename) then
17228 -- If entity name matches, we are fine. Save entity in
17229 -- pragma argument, for ASIS use.
17231 if Chars (Ename) = Chars (Ent) then
17232 Set_Entity (Ename, Ent);
17233 Generate_Reference (Ent, Ename);
17235 -- If entity name does not match, only possibility is an
17236 -- enumeration literal from an enumeration type declaration.
17238 elsif Ekind (Ent) /= E_Enumeration_Type then
17240 ("pragma % entity name does not match declaration");
17243 Ent := First_Literal (E);
17247 ("pragma % entity name does not match any "
17248 & "enumeration literal");
17250 elsif Chars (Ent) = Chars (Ename) then
17251 Set_Entity (Ename, Ent);
17252 Generate_Reference (Ent, Ename);
17256 Ent := Next_Literal (Ent);
17262 -- Ent points to entity to be marked
17264 if Arg_Count >= 1 then
17266 -- Deal with static string argument
17268 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17269 S := Strval (Get_Pragma_Arg (Arg1));
17271 for J in 1 .. String_Length (S) loop
17272 if not In_Character_Range (Get_String_Char (S, J)) then
17274 ("pragma% argument does not allow wide characters",
17279 Obsolescent_Warnings.Append
17280 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17282 -- Check for Ada_05 parameter
17284 if Arg_Count /= 1 then
17285 Check_Arg_Count (2);
17288 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17291 Check_Arg_Is_Identifier (Argx);
17293 if Chars (Argx) /= Name_Ada_05 then
17294 Error_Msg_Name_2 := Name_Ada_05;
17296 ("only allowed argument for pragma% is %", Argx);
17299 if Ada_Version_Explicit < Ada_2005
17300 or else not Warn_On_Ada_2005_Compatibility
17308 -- Set flag if pragma active
17311 Set_Is_Obsolescent (Ent);
17315 end Set_Obsolescent;
17317 -- Start of processing for pragma Obsolescent
17322 Check_At_Most_N_Arguments (3);
17324 -- See if first argument specifies an entity name
17328 (Chars (Arg1) = Name_Entity
17330 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17332 N_Operator_Symbol))
17334 Ename := Get_Pragma_Arg (Arg1);
17336 -- Eliminate first argument, so we can share processing
17340 Arg_Count := Arg_Count - 1;
17342 -- No Entity name argument given
17348 if Arg_Count >= 1 then
17349 Check_Optional_Identifier (Arg1, Name_Message);
17351 if Arg_Count = 2 then
17352 Check_Optional_Identifier (Arg2, Name_Version);
17356 -- Get immediately preceding declaration
17359 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17363 -- Cases where we do not follow anything other than another pragma
17367 -- First case: library level compilation unit declaration with
17368 -- the pragma immediately following the declaration.
17370 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17372 (Defining_Entity (Unit (Parent (Parent (N)))));
17375 -- Case 2: library unit placement for package
17379 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17381 if Is_Package_Or_Generic_Package (Ent) then
17382 Set_Obsolescent (Ent);
17388 -- Cases where we must follow a declaration, including an
17389 -- abstract subprogram declaration, which is not in the
17390 -- other node subtypes.
17393 if Nkind (Decl) not in N_Declaration
17394 and then Nkind (Decl) not in N_Later_Decl_Item
17395 and then Nkind (Decl) not in N_Generic_Declaration
17396 and then Nkind (Decl) not in N_Renaming_Declaration
17397 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
17400 ("pragma% misplaced, "
17401 & "must immediately follow a declaration");
17404 Set_Obsolescent (Defining_Entity (Decl));
17414 -- pragma Optimize (Time | Space | Off);
17416 -- The actual check for optimize is done in Gigi. Note that this
17417 -- pragma does not actually change the optimization setting, it
17418 -- simply checks that it is consistent with the pragma.
17420 when Pragma_Optimize =>
17421 Check_No_Identifiers;
17422 Check_Arg_Count (1);
17423 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17425 ------------------------
17426 -- Optimize_Alignment --
17427 ------------------------
17429 -- pragma Optimize_Alignment (Time | Space | Off);
17431 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17433 Check_No_Identifiers;
17434 Check_Arg_Count (1);
17435 Check_Valid_Configuration_Pragma;
17438 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17442 Opt.Optimize_Alignment := 'T';
17444 Opt.Optimize_Alignment := 'S';
17446 Opt.Optimize_Alignment := 'O';
17448 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17452 -- Set indication that mode is set locally. If we are in fact in a
17453 -- configuration pragma file, this setting is harmless since the
17454 -- switch will get reset anyway at the start of each unit.
17456 Optimize_Alignment_Local := True;
17457 end Optimize_Alignment;
17463 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17465 when Pragma_Ordered => Ordered : declare
17466 Assoc : constant Node_Id := Arg1;
17472 Check_No_Identifiers;
17473 Check_Arg_Count (1);
17474 Check_Arg_Is_Local_Name (Arg1);
17476 Type_Id := Get_Pragma_Arg (Assoc);
17477 Find_Type (Type_Id);
17478 Typ := Entity (Type_Id);
17480 if Typ = Any_Type then
17483 Typ := Underlying_Type (Typ);
17486 if not Is_Enumeration_Type (Typ) then
17487 Error_Pragma ("pragma% must specify enumeration type");
17490 Check_First_Subtype (Arg1);
17491 Set_Has_Pragma_Ordered (Base_Type (Typ));
17494 -------------------
17495 -- Overflow_Mode --
17496 -------------------
17498 -- pragma Overflow_Mode
17499 -- ([General => ] MODE [, [Assertions => ] MODE]);
17501 -- MODE := STRICT | MINIMIZED | ELIMINATED
17503 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17504 -- since System.Bignums makes this assumption. This is true of nearly
17505 -- all (all?) targets.
17507 when Pragma_Overflow_Mode => Overflow_Mode : declare
17508 function Get_Overflow_Mode
17510 Arg : Node_Id) return Overflow_Mode_Type;
17511 -- Function to process one pragma argument, Arg. If an identifier
17512 -- is present, it must be Name. Mode type is returned if a valid
17513 -- argument exists, otherwise an error is signalled.
17515 -----------------------
17516 -- Get_Overflow_Mode --
17517 -----------------------
17519 function Get_Overflow_Mode
17521 Arg : Node_Id) return Overflow_Mode_Type
17523 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
17526 Check_Optional_Identifier (Arg, Name);
17527 Check_Arg_Is_Identifier (Argx);
17529 if Chars (Argx) = Name_Strict then
17532 elsif Chars (Argx) = Name_Minimized then
17535 elsif Chars (Argx) = Name_Eliminated then
17536 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
17538 ("Eliminated not implemented on this target", Argx);
17544 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
17546 end Get_Overflow_Mode;
17548 -- Start of processing for Overflow_Mode
17552 Check_At_Least_N_Arguments (1);
17553 Check_At_Most_N_Arguments (2);
17555 -- Process first argument
17557 Scope_Suppress.Overflow_Mode_General :=
17558 Get_Overflow_Mode (Name_General, Arg1);
17560 -- Case of only one argument
17562 if Arg_Count = 1 then
17563 Scope_Suppress.Overflow_Mode_Assertions :=
17564 Scope_Suppress.Overflow_Mode_General;
17566 -- Case of two arguments present
17569 Scope_Suppress.Overflow_Mode_Assertions :=
17570 Get_Overflow_Mode (Name_Assertions, Arg2);
17574 --------------------------
17575 -- Overriding Renamings --
17576 --------------------------
17578 -- pragma Overriding_Renamings;
17580 when Pragma_Overriding_Renamings =>
17582 Check_Arg_Count (0);
17583 Check_Valid_Configuration_Pragma;
17584 Overriding_Renamings := True;
17590 -- pragma Pack (first_subtype_LOCAL_NAME);
17592 when Pragma_Pack => Pack : declare
17593 Assoc : constant Node_Id := Arg1;
17595 Ignore : Boolean := False;
17600 Check_No_Identifiers;
17601 Check_Arg_Count (1);
17602 Check_Arg_Is_Local_Name (Arg1);
17603 Type_Id := Get_Pragma_Arg (Assoc);
17605 if not Is_Entity_Name (Type_Id)
17606 or else not Is_Type (Entity (Type_Id))
17609 ("argument for pragma% must be type or subtype", Arg1);
17612 Find_Type (Type_Id);
17613 Typ := Entity (Type_Id);
17616 or else Rep_Item_Too_Early (Typ, N)
17620 Typ := Underlying_Type (Typ);
17623 -- A pragma that applies to a Ghost entity becomes Ghost for the
17624 -- purposes of legality checks and removal of ignored Ghost code.
17626 Mark_Pragma_As_Ghost (N, Typ);
17628 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
17629 Error_Pragma ("pragma% must specify array or record type");
17632 Check_First_Subtype (Arg1);
17633 Check_Duplicate_Pragma (Typ);
17637 if Is_Array_Type (Typ) then
17638 Ctyp := Component_Type (Typ);
17640 -- Ignore pack that does nothing
17642 if Known_Static_Esize (Ctyp)
17643 and then Known_Static_RM_Size (Ctyp)
17644 and then Esize (Ctyp) = RM_Size (Ctyp)
17645 and then Addressable (Esize (Ctyp))
17650 -- Process OK pragma Pack. Note that if there is a separate
17651 -- component clause present, the Pack will be cancelled. This
17652 -- processing is in Freeze.
17654 if not Rep_Item_Too_Late (Typ, N) then
17656 -- In CodePeer mode, we do not need complex front-end
17657 -- expansions related to pragma Pack, so disable handling
17660 if CodePeer_Mode then
17663 -- Don't attempt any packing for VM targets. We possibly
17664 -- could deal with some cases of array bit-packing, but we
17665 -- don't bother, since this is not a typical kind of
17666 -- representation in the VM context anyway (and would not
17667 -- for example work nicely with the debugger).
17669 elsif VM_Target /= No_VM then
17670 if not GNAT_Mode then
17672 ("??pragma% ignored in this configuration");
17675 -- Normal case where we do the pack action
17679 Set_Is_Packed (Base_Type (Typ));
17680 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17683 Set_Has_Pragma_Pack (Base_Type (Typ));
17687 -- For record types, the pack is always effective
17689 else pragma Assert (Is_Record_Type (Typ));
17690 if not Rep_Item_Too_Late (Typ, N) then
17692 -- Ignore pack request with warning in VM mode (skip warning
17693 -- if we are compiling GNAT run time library).
17695 if VM_Target /= No_VM then
17696 if not GNAT_Mode then
17698 ("??pragma% ignored in this configuration");
17701 -- Normal case of pack request active
17704 Set_Is_Packed (Base_Type (Typ));
17705 Set_Has_Pragma_Pack (Base_Type (Typ));
17706 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17718 -- There is nothing to do here, since we did all the processing for
17719 -- this pragma in Par.Prag (so that it works properly even in syntax
17722 when Pragma_Page =>
17729 -- pragma Part_Of (ABSTRACT_STATE);
17731 -- ABSTRACT_STATE ::= NAME
17733 when Pragma_Part_Of => Part_Of : declare
17734 procedure Propagate_Part_Of
17735 (Pack_Id : Entity_Id;
17736 State_Id : Entity_Id;
17737 Instance : Node_Id);
17738 -- Propagate the Part_Of indicator to all abstract states and
17739 -- objects declared in the visible state space of a package
17740 -- denoted by Pack_Id. State_Id is the encapsulating state.
17741 -- Instance is the package instantiation node.
17743 -----------------------
17744 -- Propagate_Part_Of --
17745 -----------------------
17747 procedure Propagate_Part_Of
17748 (Pack_Id : Entity_Id;
17749 State_Id : Entity_Id;
17750 Instance : Node_Id)
17752 Has_Item : Boolean := False;
17753 -- Flag set when the visible state space contains at least one
17754 -- abstract state or variable.
17756 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
17757 -- Propagate the Part_Of indicator to all abstract states and
17758 -- objects declared in the visible state space of a package
17759 -- denoted by Pack_Id.
17761 -----------------------
17762 -- Propagate_Part_Of --
17763 -----------------------
17765 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
17766 Item_Id : Entity_Id;
17769 -- Traverse the entity chain of the package and set relevant
17770 -- attributes of abstract states and objects declared in the
17771 -- visible state space of the package.
17773 Item_Id := First_Entity (Pack_Id);
17774 while Present (Item_Id)
17775 and then not In_Private_Part (Item_Id)
17777 -- Do not consider internally generated items
17779 if not Comes_From_Source (Item_Id) then
17782 -- The Part_Of indicator turns an abstract state or an
17783 -- object into a constituent of the encapsulating state.
17785 elsif Ekind_In (Item_Id, E_Abstract_State,
17791 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17792 Set_Encapsulating_State (Item_Id, State_Id);
17794 -- Recursively handle nested packages and instantiations
17796 elsif Ekind (Item_Id) = E_Package then
17797 Propagate_Part_Of (Item_Id);
17800 Next_Entity (Item_Id);
17802 end Propagate_Part_Of;
17804 -- Start of processing for Propagate_Part_Of
17807 Propagate_Part_Of (Pack_Id);
17809 -- Detect a package instantiation that is subject to a Part_Of
17810 -- indicator, but has no visible state.
17812 if not Has_Item then
17814 ("package instantiation & has Part_Of indicator but "
17815 & "lacks visible state", Instance, Pack_Id);
17817 end Propagate_Part_Of;
17821 Item_Id : Entity_Id;
17824 State_Id : Entity_Id;
17827 -- Start of processing for Part_Of
17831 Check_No_Identifiers;
17832 Check_Arg_Count (1);
17834 -- Ensure the proper placement of the pragma. Part_Of must appear
17835 -- on an object declaration or a package instantiation.
17838 while Present (Stmt) loop
17840 -- Skip prior pragmas, but check for duplicates
17842 if Nkind (Stmt) = N_Pragma then
17843 if Pragma_Name (Stmt) = Pname then
17844 Error_Msg_Name_1 := Pname;
17845 Error_Msg_Sloc := Sloc (Stmt);
17846 Error_Msg_N ("pragma% duplicates pragma declared#", N);
17849 -- Skip internally generated code
17851 elsif not Comes_From_Source (Stmt) then
17854 -- The pragma applies to an object declaration (possibly a
17855 -- variable) or a package instantiation. Stop the traversal
17856 -- and continue the analysis.
17858 elsif Nkind_In (Stmt, N_Object_Declaration,
17859 N_Package_Instantiation)
17863 -- The pragma does not apply to a legal construct, issue an
17864 -- error and stop the analysis.
17871 Stmt := Prev (Stmt);
17874 -- Extract the entity of the related object declaration or package
17875 -- instantiation. In the case of the instantiation, use the entity
17876 -- of the instance spec.
17878 if Nkind (Stmt) = N_Package_Instantiation then
17879 Stmt := Instance_Spec (Stmt);
17882 Item_Id := Defining_Entity (Stmt);
17883 State := Get_Pragma_Arg (Arg1);
17885 -- A pragma that applies to a Ghost entity becomes Ghost for the
17886 -- purposes of legality checks and removal of ignored Ghost code.
17888 Mark_Pragma_As_Ghost (N, Item_Id);
17890 -- Detect any discrepancies between the placement of the object
17891 -- or package instantiation with respect to state space and the
17892 -- encapsulating state.
17895 (Item_Id => Item_Id,
17901 State_Id := Entity (State);
17903 -- The Part_Of indicator turns an object into a constituent of
17904 -- the encapsulating state.
17906 if Ekind_In (Item_Id, E_Constant, E_Variable) then
17907 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17908 Set_Encapsulating_State (Item_Id, State_Id);
17910 -- Propagate the Part_Of indicator to the visible state space
17911 -- of the package instantiation.
17915 (Pack_Id => Item_Id,
17916 State_Id => State_Id,
17920 -- Add the pragma to the contract of the item. This aids with
17921 -- the detection of a missing but required Part_Of indicator.
17923 Add_Contract_Item (N, Item_Id);
17927 ----------------------------------
17928 -- Partition_Elaboration_Policy --
17929 ----------------------------------
17931 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17933 when Pragma_Partition_Elaboration_Policy => declare
17934 subtype PEP_Range is Name_Id
17935 range First_Partition_Elaboration_Policy_Name
17936 .. Last_Partition_Elaboration_Policy_Name;
17937 PEP_Val : PEP_Range;
17942 Check_Arg_Count (1);
17943 Check_No_Identifiers;
17944 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
17945 Check_Valid_Configuration_Pragma;
17946 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
17949 when Name_Concurrent =>
17951 when Name_Sequential =>
17955 if Partition_Elaboration_Policy /= ' '
17956 and then Partition_Elaboration_Policy /= PEP
17958 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
17960 ("partition elaboration policy incompatible with policy#");
17962 -- Set new policy, but always preserve System_Location since we
17963 -- like the error message with the run time name.
17966 Partition_Elaboration_Policy := PEP;
17968 if Partition_Elaboration_Policy_Sloc /= System_Location then
17969 Partition_Elaboration_Policy_Sloc := Loc;
17978 -- pragma Passive [(PASSIVE_FORM)];
17980 -- PASSIVE_FORM ::= Semaphore | No
17982 when Pragma_Passive =>
17985 if Nkind (Parent (N)) /= N_Task_Definition then
17986 Error_Pragma ("pragma% must be within task definition");
17989 if Arg_Count /= 0 then
17990 Check_Arg_Count (1);
17991 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
17994 ----------------------------------
17995 -- Preelaborable_Initialization --
17996 ----------------------------------
17998 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18000 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18005 Check_Arg_Count (1);
18006 Check_No_Identifiers;
18007 Check_Arg_Is_Identifier (Arg1);
18008 Check_Arg_Is_Local_Name (Arg1);
18009 Check_First_Subtype (Arg1);
18010 Ent := Entity (Get_Pragma_Arg (Arg1));
18012 -- A pragma that applies to a Ghost entity becomes Ghost for the
18013 -- purposes of legality checks and removal of ignored Ghost code.
18015 Mark_Pragma_As_Ghost (N, Ent);
18017 -- The pragma may come from an aspect on a private declaration,
18018 -- even if the freeze point at which this is analyzed in the
18019 -- private part after the full view.
18021 if Has_Private_Declaration (Ent)
18022 and then From_Aspect_Specification (N)
18026 -- Check appropriate type argument
18028 elsif Is_Private_Type (Ent)
18029 or else Is_Protected_Type (Ent)
18030 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18032 -- AI05-0028: The pragma applies to all composite types. Note
18033 -- that we apply this binding interpretation to earlier versions
18034 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18035 -- choice since there are other compilers that do the same.
18037 or else Is_Composite_Type (Ent)
18043 ("pragma % can only be applied to private, formal derived, "
18044 & "protected, or composite type", Arg1);
18047 -- Give an error if the pragma is applied to a protected type that
18048 -- does not qualify (due to having entries, or due to components
18049 -- that do not qualify).
18051 if Is_Protected_Type (Ent)
18052 and then not Has_Preelaborable_Initialization (Ent)
18055 ("protected type & does not have preelaborable "
18056 & "initialization", Ent);
18058 -- Otherwise mark the type as definitely having preelaborable
18062 Set_Known_To_Have_Preelab_Init (Ent);
18065 if Has_Pragma_Preelab_Init (Ent)
18066 and then Warn_On_Redundant_Constructs
18068 Error_Pragma ("?r?duplicate pragma%!");
18070 Set_Has_Pragma_Preelab_Init (Ent);
18074 --------------------
18075 -- Persistent_BSS --
18076 --------------------
18078 -- pragma Persistent_BSS [(object_NAME)];
18080 when Pragma_Persistent_BSS => Persistent_BSS : declare
18087 Check_At_Most_N_Arguments (1);
18089 -- Case of application to specific object (one argument)
18091 if Arg_Count = 1 then
18092 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18094 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18096 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18099 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18102 Ent := Entity (Get_Pragma_Arg (Arg1));
18103 Decl := Parent (Ent);
18105 -- A pragma that applies to a Ghost entity becomes Ghost for
18106 -- the purposes of legality checks and removal of ignored Ghost
18109 Mark_Pragma_As_Ghost (N, Ent);
18111 -- Check for duplication before inserting in list of
18112 -- representation items.
18114 Check_Duplicate_Pragma (Ent);
18116 if Rep_Item_Too_Late (Ent, N) then
18120 if Present (Expression (Decl)) then
18122 ("object for pragma% cannot have initialization", Arg1);
18125 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18127 ("object type for pragma% is not potentially persistent",
18132 Make_Linker_Section_Pragma
18133 (Ent, Sloc (N), ".persistent.bss");
18134 Insert_After (N, Prag);
18137 -- Case of use as configuration pragma with no arguments
18140 Check_Valid_Configuration_Pragma;
18141 Persistent_BSS_Mode := True;
18143 end Persistent_BSS;
18149 -- pragma Polling (ON | OFF);
18151 when Pragma_Polling =>
18153 Check_Arg_Count (1);
18154 Check_No_Identifiers;
18155 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18156 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18158 -----------------------------------
18159 -- Post/Post_Class/Postcondition --
18160 -----------------------------------
18162 -- pragma Post (Boolean_EXPRESSION);
18163 -- pragma Post_Class (Boolean_EXPRESSION);
18164 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18165 -- [,[Message =>] String_EXPRESSION]);
18167 -- Characteristics:
18169 -- * Analysis - The annotation undergoes initial checks to verify
18170 -- the legal placement and context. Secondary checks preanalyze the
18173 -- Analyze_Pre_Post_Condition_In_Decl_Part
18175 -- * Expansion - The annotation is expanded during the expansion of
18176 -- the related subprogram [body] contract as performed in:
18178 -- Expand_Subprogram_Contract
18180 -- * Template - The annotation utilizes the generic template of the
18181 -- related subprogram [body] when it is:
18183 -- aspect on subprogram declaration
18184 -- aspect on stand alone subprogram body
18185 -- pragma on stand alone subprogram body
18187 -- The annotation must prepare its own template when it is:
18189 -- pragma on subprogram declaration
18191 -- * Globals - Capture of global references must occur after full
18194 -- * Instance - The annotation is instantiated automatically when
18195 -- the related generic subprogram [body] is instantiated except for
18196 -- the "pragma on subprogram declaration" case. In that scenario
18197 -- the annotation must instantiate itself.
18200 Pragma_Post_Class |
18201 Pragma_Postcondition =>
18202 Analyze_Pre_Post_Condition;
18204 --------------------------------
18205 -- Pre/Pre_Class/Precondition --
18206 --------------------------------
18208 -- pragma Pre (Boolean_EXPRESSION);
18209 -- pragma Pre_Class (Boolean_EXPRESSION);
18210 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18211 -- [,[Message =>] String_EXPRESSION]);
18213 -- Characteristics:
18215 -- * Analysis - The annotation undergoes initial checks to verify
18216 -- the legal placement and context. Secondary checks preanalyze the
18219 -- Analyze_Pre_Post_Condition_In_Decl_Part
18221 -- * Expansion - The annotation is expanded during the expansion of
18222 -- the related subprogram [body] contract as performed in:
18224 -- Expand_Subprogram_Contract
18226 -- * Template - The annotation utilizes the generic template of the
18227 -- related subprogram [body] when it is:
18229 -- aspect on subprogram declaration
18230 -- aspect on stand alone subprogram body
18231 -- pragma on stand alone subprogram body
18233 -- The annotation must prepare its own template when it is:
18235 -- pragma on subprogram declaration
18237 -- * Globals - Capture of global references must occur after full
18240 -- * Instance - The annotation is instantiated automatically when
18241 -- the related generic subprogram [body] is instantiated except for
18242 -- the "pragma on subprogram declaration" case. In that scenario
18243 -- the annotation must instantiate itself.
18247 Pragma_Precondition =>
18248 Analyze_Pre_Post_Condition;
18254 -- pragma Predicate
18255 -- ([Entity =>] type_LOCAL_NAME,
18256 -- [Check =>] boolean_EXPRESSION);
18258 when Pragma_Predicate => Predicate : declare
18265 Check_Arg_Count (2);
18266 Check_Optional_Identifier (Arg1, Name_Entity);
18267 Check_Optional_Identifier (Arg2, Name_Check);
18269 Check_Arg_Is_Local_Name (Arg1);
18271 Type_Id := Get_Pragma_Arg (Arg1);
18272 Find_Type (Type_Id);
18273 Typ := Entity (Type_Id);
18275 if Typ = Any_Type then
18279 -- A pragma that applies to a Ghost entity becomes Ghost for the
18280 -- purposes of legality checks and removal of ignored Ghost code.
18282 Mark_Pragma_As_Ghost (N, Typ);
18284 -- The remaining processing is simply to link the pragma on to
18285 -- the rep item chain, for processing when the type is frozen.
18286 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18287 -- mark the type as having predicates.
18289 Set_Has_Predicates (Typ);
18290 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18297 -- pragma Preelaborate [(library_unit_NAME)];
18299 -- Set the flag Is_Preelaborated of program unit name entity
18301 when Pragma_Preelaborate => Preelaborate : declare
18302 Pa : constant Node_Id := Parent (N);
18303 Pk : constant Node_Kind := Nkind (Pa);
18307 Check_Ada_83_Warning;
18308 Check_Valid_Library_Unit_Pragma;
18310 if Nkind (N) = N_Null_Statement then
18314 Ent := Find_Lib_Unit_Name;
18316 -- A pragma that applies to a Ghost entity becomes Ghost for the
18317 -- purposes of legality checks and removal of ignored Ghost code.
18319 Mark_Pragma_As_Ghost (N, Ent);
18320 Check_Duplicate_Pragma (Ent);
18322 -- This filters out pragmas inside generic parents that show up
18323 -- inside instantiations. Pragmas that come from aspects in the
18324 -- unit are not ignored.
18326 if Present (Ent) then
18327 if Pk = N_Package_Specification
18328 and then Present (Generic_Parent (Pa))
18329 and then not From_Aspect_Specification (N)
18334 if not Debug_Flag_U then
18335 Set_Is_Preelaborated (Ent);
18336 Set_Suppress_Elaboration_Warnings (Ent);
18342 -------------------------------
18343 -- Prefix_Exception_Messages --
18344 -------------------------------
18346 -- pragma Prefix_Exception_Messages;
18348 when Pragma_Prefix_Exception_Messages =>
18350 Check_Valid_Configuration_Pragma;
18351 Check_Arg_Count (0);
18352 Prefix_Exception_Messages := True;
18358 -- pragma Priority (EXPRESSION);
18360 when Pragma_Priority => Priority : declare
18361 P : constant Node_Id := Parent (N);
18366 Check_No_Identifiers;
18367 Check_Arg_Count (1);
18371 if Nkind (P) = N_Subprogram_Body then
18372 Check_In_Main_Program;
18374 Ent := Defining_Unit_Name (Specification (P));
18376 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18377 Ent := Defining_Identifier (Ent);
18380 Arg := Get_Pragma_Arg (Arg1);
18381 Analyze_And_Resolve (Arg, Standard_Integer);
18385 if not Is_OK_Static_Expression (Arg) then
18386 Flag_Non_Static_Expr
18387 ("main subprogram priority is not static!", Arg);
18390 -- If constraint error, then we already signalled an error
18392 elsif Raises_Constraint_Error (Arg) then
18395 -- Otherwise check in range except if Relaxed_RM_Semantics
18396 -- where we ignore the value if out of range.
18400 Val : constant Uint := Expr_Value (Arg);
18402 if not Relaxed_RM_Semantics
18405 or else Val > Expr_Value (Expression
18406 (Parent (RTE (RE_Max_Priority)))))
18409 ("main subprogram priority is out of range", Arg1);
18412 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18417 -- Load an arbitrary entity from System.Tasking.Stages or
18418 -- System.Tasking.Restricted.Stages (depending on the
18419 -- supported profile) to make sure that one of these packages
18420 -- is implicitly with'ed, since we need to have the tasking
18421 -- run time active for the pragma Priority to have any effect.
18422 -- Previously we with'ed the package System.Tasking, but this
18423 -- package does not trigger the required initialization of the
18424 -- run-time library.
18427 Discard : Entity_Id;
18428 pragma Warnings (Off, Discard);
18430 if Restricted_Profile then
18431 Discard := RTE (RE_Activate_Restricted_Tasks);
18433 Discard := RTE (RE_Activate_Tasks);
18437 -- Task or Protected, must be of type Integer
18439 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18440 Arg := Get_Pragma_Arg (Arg1);
18441 Ent := Defining_Identifier (Parent (P));
18443 -- The expression must be analyzed in the special manner
18444 -- described in "Handling of Default and Per-Object
18445 -- Expressions" in sem.ads.
18447 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18449 if not Is_OK_Static_Expression (Arg) then
18450 Check_Restriction (Static_Priorities, Arg);
18453 -- Anything else is incorrect
18459 -- Check duplicate pragma before we chain the pragma in the Rep
18460 -- Item chain of Ent.
18462 Check_Duplicate_Pragma (Ent);
18463 Record_Rep_Item (Ent, N);
18466 -----------------------------------
18467 -- Priority_Specific_Dispatching --
18468 -----------------------------------
18470 -- pragma Priority_Specific_Dispatching (
18471 -- policy_IDENTIFIER,
18472 -- first_priority_EXPRESSION,
18473 -- last_priority_EXPRESSION);
18475 when Pragma_Priority_Specific_Dispatching =>
18476 Priority_Specific_Dispatching : declare
18477 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18478 -- This is the entity System.Any_Priority;
18481 Lower_Bound : Node_Id;
18482 Upper_Bound : Node_Id;
18488 Check_Arg_Count (3);
18489 Check_No_Identifiers;
18490 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18491 Check_Valid_Configuration_Pragma;
18492 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18493 DP := Fold_Upper (Name_Buffer (1));
18495 Lower_Bound := Get_Pragma_Arg (Arg2);
18496 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
18497 Lower_Val := Expr_Value (Lower_Bound);
18499 Upper_Bound := Get_Pragma_Arg (Arg3);
18500 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
18501 Upper_Val := Expr_Value (Upper_Bound);
18503 -- It is not allowed to use Task_Dispatching_Policy and
18504 -- Priority_Specific_Dispatching in the same partition.
18506 if Task_Dispatching_Policy /= ' ' then
18507 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18509 ("pragma% incompatible with Task_Dispatching_Policy#");
18511 -- Check lower bound in range
18513 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18515 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
18518 ("first_priority is out of range", Arg2);
18520 -- Check upper bound in range
18522 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18524 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
18527 ("last_priority is out of range", Arg3);
18529 -- Check that the priority range is valid
18531 elsif Lower_Val > Upper_Val then
18533 ("last_priority_expression must be greater than or equal to "
18534 & "first_priority_expression");
18536 -- Store the new policy, but always preserve System_Location since
18537 -- we like the error message with the run-time name.
18540 -- Check overlapping in the priority ranges specified in other
18541 -- Priority_Specific_Dispatching pragmas within the same
18542 -- partition. We can only check those we know about.
18545 Specific_Dispatching.First .. Specific_Dispatching.Last
18547 if Specific_Dispatching.Table (J).First_Priority in
18548 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18549 or else Specific_Dispatching.Table (J).Last_Priority in
18550 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18553 Specific_Dispatching.Table (J).Pragma_Loc;
18555 ("priority range overlaps with "
18556 & "Priority_Specific_Dispatching#");
18560 -- The use of Priority_Specific_Dispatching is incompatible
18561 -- with Task_Dispatching_Policy.
18563 if Task_Dispatching_Policy /= ' ' then
18564 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18566 ("Priority_Specific_Dispatching incompatible "
18567 & "with Task_Dispatching_Policy#");
18570 -- The use of Priority_Specific_Dispatching forces ceiling
18573 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
18574 Error_Msg_Sloc := Locking_Policy_Sloc;
18576 ("Priority_Specific_Dispatching incompatible "
18577 & "with Locking_Policy#");
18579 -- Set the Ceiling_Locking policy, but preserve System_Location
18580 -- since we like the error message with the run time name.
18583 Locking_Policy := 'C';
18585 if Locking_Policy_Sloc /= System_Location then
18586 Locking_Policy_Sloc := Loc;
18590 -- Add entry in the table
18592 Specific_Dispatching.Append
18593 ((Dispatching_Policy => DP,
18594 First_Priority => UI_To_Int (Lower_Val),
18595 Last_Priority => UI_To_Int (Upper_Val),
18596 Pragma_Loc => Loc));
18598 end Priority_Specific_Dispatching;
18604 -- pragma Profile (profile_IDENTIFIER);
18606 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18608 when Pragma_Profile =>
18610 Check_Arg_Count (1);
18611 Check_Valid_Configuration_Pragma;
18612 Check_No_Identifiers;
18615 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18618 if Chars (Argx) = Name_Ravenscar then
18619 Set_Ravenscar_Profile (N);
18621 elsif Chars (Argx) = Name_Restricted then
18622 Set_Profile_Restrictions
18624 N, Warn => Treat_Restrictions_As_Warnings);
18626 elsif Chars (Argx) = Name_Rational then
18627 Set_Rational_Profile;
18629 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18630 Set_Profile_Restrictions
18631 (No_Implementation_Extensions,
18632 N, Warn => Treat_Restrictions_As_Warnings);
18635 Error_Pragma_Arg ("& is not a valid profile", Argx);
18639 ----------------------
18640 -- Profile_Warnings --
18641 ----------------------
18643 -- pragma Profile_Warnings (profile_IDENTIFIER);
18645 -- profile_IDENTIFIER => Restricted | Ravenscar
18647 when Pragma_Profile_Warnings =>
18649 Check_Arg_Count (1);
18650 Check_Valid_Configuration_Pragma;
18651 Check_No_Identifiers;
18654 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18657 if Chars (Argx) = Name_Ravenscar then
18658 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
18660 elsif Chars (Argx) = Name_Restricted then
18661 Set_Profile_Restrictions (Restricted, N, Warn => True);
18663 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18664 Set_Profile_Restrictions
18665 (No_Implementation_Extensions, N, Warn => True);
18668 Error_Pragma_Arg ("& is not a valid profile", Argx);
18672 --------------------------
18673 -- Propagate_Exceptions --
18674 --------------------------
18676 -- pragma Propagate_Exceptions;
18678 -- Note: this pragma is obsolete and has no effect
18680 when Pragma_Propagate_Exceptions =>
18682 Check_Arg_Count (0);
18684 if Warn_On_Obsolescent_Feature then
18686 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18687 "and has no effect?j?", N);
18690 -----------------------------
18691 -- Provide_Shift_Operators --
18692 -----------------------------
18694 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18696 when Pragma_Provide_Shift_Operators =>
18697 Provide_Shift_Operators : declare
18700 procedure Declare_Shift_Operator (Nam : Name_Id);
18701 -- Insert declaration and pragma Instrinsic for named shift op
18703 ----------------------------
18704 -- Declare_Shift_Operator --
18705 ----------------------------
18707 procedure Declare_Shift_Operator (Nam : Name_Id) is
18713 Make_Subprogram_Declaration (Loc,
18714 Make_Function_Specification (Loc,
18715 Defining_Unit_Name =>
18716 Make_Defining_Identifier (Loc, Chars => Nam),
18718 Result_Definition =>
18719 Make_Identifier (Loc, Chars => Chars (Ent)),
18721 Parameter_Specifications => New_List (
18722 Make_Parameter_Specification (Loc,
18723 Defining_Identifier =>
18724 Make_Defining_Identifier (Loc, Name_Value),
18726 Make_Identifier (Loc, Chars => Chars (Ent))),
18728 Make_Parameter_Specification (Loc,
18729 Defining_Identifier =>
18730 Make_Defining_Identifier (Loc, Name_Amount),
18732 New_Occurrence_Of (Standard_Natural, Loc)))));
18736 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
18737 Pragma_Argument_Associations => New_List (
18738 Make_Pragma_Argument_Association (Loc,
18739 Expression => Make_Identifier (Loc, Name_Intrinsic)),
18740 Make_Pragma_Argument_Association (Loc,
18741 Expression => Make_Identifier (Loc, Nam))));
18743 Insert_After (N, Import);
18744 Insert_After (N, Func);
18745 end Declare_Shift_Operator;
18747 -- Start of processing for Provide_Shift_Operators
18751 Check_Arg_Count (1);
18752 Check_Arg_Is_Local_Name (Arg1);
18754 Arg1 := Get_Pragma_Arg (Arg1);
18756 -- We must have an entity name
18758 if not Is_Entity_Name (Arg1) then
18760 ("pragma % must apply to integer first subtype", Arg1);
18763 -- If no Entity, means there was a prior error so ignore
18765 if Present (Entity (Arg1)) then
18766 Ent := Entity (Arg1);
18768 -- Apply error checks
18770 if not Is_First_Subtype (Ent) then
18772 ("cannot apply pragma %",
18773 "\& is not a first subtype",
18776 elsif not Is_Integer_Type (Ent) then
18778 ("cannot apply pragma %",
18779 "\& is not an integer type",
18782 elsif Has_Shift_Operator (Ent) then
18784 ("cannot apply pragma %",
18785 "\& already has declared shift operators",
18788 elsif Is_Frozen (Ent) then
18790 ("pragma % appears too late",
18791 "\& is already frozen",
18795 -- Now declare the operators. We do this during analysis rather
18796 -- than expansion, since we want the operators available if we
18797 -- are operating in -gnatc or ASIS mode.
18799 Declare_Shift_Operator (Name_Rotate_Left);
18800 Declare_Shift_Operator (Name_Rotate_Right);
18801 Declare_Shift_Operator (Name_Shift_Left);
18802 Declare_Shift_Operator (Name_Shift_Right);
18803 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
18805 end Provide_Shift_Operators;
18811 -- pragma Psect_Object (
18812 -- [Internal =>] LOCAL_NAME,
18813 -- [, [External =>] EXTERNAL_SYMBOL]
18814 -- [, [Size =>] EXTERNAL_SYMBOL]);
18816 when Pragma_Psect_Object | Pragma_Common_Object =>
18817 Psect_Object : declare
18818 Args : Args_List (1 .. 3);
18819 Names : constant Name_List (1 .. 3) := (
18824 Internal : Node_Id renames Args (1);
18825 External : Node_Id renames Args (2);
18826 Size : Node_Id renames Args (3);
18828 Def_Id : Entity_Id;
18830 procedure Check_Arg (Arg : Node_Id);
18831 -- Checks that argument is either a string literal or an
18832 -- identifier, and posts error message if not.
18838 procedure Check_Arg (Arg : Node_Id) is
18840 if not Nkind_In (Original_Node (Arg),
18845 ("inappropriate argument for pragma %", Arg);
18849 -- Start of processing for Common_Object/Psect_Object
18853 Gather_Associations (Names, Args);
18854 Process_Extended_Import_Export_Internal_Arg (Internal);
18856 Def_Id := Entity (Internal);
18858 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
18860 ("pragma% must designate an object", Internal);
18863 Check_Arg (Internal);
18865 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
18867 ("cannot use pragma% for imported/exported object",
18871 if Is_Concurrent_Type (Etype (Internal)) then
18873 ("cannot specify pragma % for task/protected object",
18877 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
18879 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
18881 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
18884 if Ekind (Def_Id) = E_Constant then
18886 ("cannot specify pragma % for a constant", Internal);
18889 if Is_Record_Type (Etype (Internal)) then
18895 Ent := First_Entity (Etype (Internal));
18896 while Present (Ent) loop
18897 Decl := Declaration_Node (Ent);
18899 if Ekind (Ent) = E_Component
18900 and then Nkind (Decl) = N_Component_Declaration
18901 and then Present (Expression (Decl))
18902 and then Warn_On_Export_Import
18905 ("?x?object for pragma % has defaults", Internal);
18915 if Present (Size) then
18919 if Present (External) then
18920 Check_Arg_Is_External_Name (External);
18923 -- If all error tests pass, link pragma on to the rep item chain
18925 Record_Rep_Item (Def_Id, N);
18932 -- pragma Pure [(library_unit_NAME)];
18934 when Pragma_Pure => Pure : declare
18938 Check_Ada_83_Warning;
18939 Check_Valid_Library_Unit_Pragma;
18941 if Nkind (N) = N_Null_Statement then
18945 Ent := Find_Lib_Unit_Name;
18947 -- A pragma that applies to a Ghost entity becomes Ghost for the
18948 -- purposes of legality checks and removal of ignored Ghost code.
18950 Mark_Pragma_As_Ghost (N, Ent);
18952 Set_Has_Pragma_Pure (Ent);
18953 Set_Suppress_Elaboration_Warnings (Ent);
18956 -------------------
18957 -- Pure_Function --
18958 -------------------
18960 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18962 when Pragma_Pure_Function => Pure_Function : declare
18963 Def_Id : Entity_Id;
18966 Effective : Boolean := False;
18970 Check_Arg_Count (1);
18971 Check_Optional_Identifier (Arg1, Name_Entity);
18972 Check_Arg_Is_Local_Name (Arg1);
18973 E_Id := Get_Pragma_Arg (Arg1);
18975 if Error_Posted (E_Id) then
18979 -- Loop through homonyms (overloadings) of referenced entity
18981 E := Entity (E_Id);
18983 -- A pragma that applies to a Ghost entity becomes Ghost for the
18984 -- purposes of legality checks and removal of ignored Ghost code.
18986 Mark_Pragma_As_Ghost (N, E);
18988 if Present (E) then
18990 Def_Id := Get_Base_Subprogram (E);
18992 if not Ekind_In (Def_Id, E_Function,
18993 E_Generic_Function,
18997 ("pragma% requires a function name", Arg1);
19000 Set_Is_Pure (Def_Id);
19002 if not Has_Pragma_Pure_Function (Def_Id) then
19003 Set_Has_Pragma_Pure_Function (Def_Id);
19007 exit when From_Aspect_Specification (N);
19009 exit when No (E) or else Scope (E) /= Current_Scope;
19013 and then Warn_On_Redundant_Constructs
19016 ("pragma Pure_Function on& is redundant?r?",
19022 --------------------
19023 -- Queuing_Policy --
19024 --------------------
19026 -- pragma Queuing_Policy (policy_IDENTIFIER);
19028 when Pragma_Queuing_Policy => declare
19032 Check_Ada_83_Warning;
19033 Check_Arg_Count (1);
19034 Check_No_Identifiers;
19035 Check_Arg_Is_Queuing_Policy (Arg1);
19036 Check_Valid_Configuration_Pragma;
19037 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19038 QP := Fold_Upper (Name_Buffer (1));
19040 if Queuing_Policy /= ' '
19041 and then Queuing_Policy /= QP
19043 Error_Msg_Sloc := Queuing_Policy_Sloc;
19044 Error_Pragma ("queuing policy incompatible with policy#");
19046 -- Set new policy, but always preserve System_Location since we
19047 -- like the error message with the run time name.
19050 Queuing_Policy := QP;
19052 if Queuing_Policy_Sloc /= System_Location then
19053 Queuing_Policy_Sloc := Loc;
19062 -- pragma Rational, for compatibility with foreign compiler
19064 when Pragma_Rational =>
19065 Set_Rational_Profile;
19067 ------------------------------------
19068 -- Refined_Depends/Refined_Global --
19069 ------------------------------------
19071 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19073 -- DEPENDENCY_RELATION ::=
19075 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
19077 -- DEPENDENCY_CLAUSE ::=
19078 -- OUTPUT_LIST =>[+] INPUT_LIST
19079 -- | NULL_DEPENDENCY_CLAUSE
19081 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19083 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19085 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19087 -- OUTPUT ::= NAME | FUNCTION_RESULT
19090 -- where FUNCTION_RESULT is a function Result attribute_reference
19092 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19094 -- GLOBAL_SPECIFICATION ::=
19097 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
19099 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19101 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19102 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19103 -- GLOBAL_ITEM ::= NAME
19105 -- Characteristics:
19107 -- * Analysis - The annotation undergoes initial checks to verify
19108 -- the legal placement and context. Secondary checks fully analyze
19109 -- the dependency clauses/global list in:
19111 -- Analyze_Refined_Depends_In_Decl_Part
19112 -- Analyze_Refined_Global_In_Decl_Part
19114 -- * Expansion - None.
19116 -- * Template - The annotation utilizes the generic template of the
19117 -- related subprogram body.
19119 -- * Globals - Capture of global references must occur after full
19122 -- * Instance - The annotation is instantiated automatically when
19123 -- the related generic subprogram body is instantiated.
19125 when Pragma_Refined_Depends |
19126 Pragma_Refined_Global => Refined_Depends_Global :
19128 Body_Id : Entity_Id;
19130 Spec_Id : Entity_Id;
19133 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19135 -- Chain the pragma on the contract for further processing by
19136 -- Analyze_Refined_[Depends|Global]_In_Decl_Part.
19139 Add_Contract_Item (N, Body_Id);
19141 end Refined_Depends_Global;
19147 -- pragma Refined_Post (boolean_EXPRESSION);
19149 -- Characteristics:
19151 -- * Analysis - The annotation is fully analyzed immediately upon
19152 -- elaboration as it cannot forward reference entities.
19154 -- * Expansion - The annotation is expanded during the expansion of
19155 -- the related subprogram body contract as performed in:
19157 -- Expand_Subprogram_Contract
19159 -- * Template - The annotation utilizes the generic template of the
19160 -- related subprogram body.
19162 -- * Globals - Capture of global references must occur after full
19165 -- * Instance - The annotation is instantiated automatically when
19166 -- the related generic subprogram body is instantiated.
19168 when Pragma_Refined_Post => Refined_Post : declare
19169 Body_Id : Entity_Id;
19171 Spec_Id : Entity_Id;
19174 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19176 -- Fully analyze the pragma when it appears inside a subprogram
19177 -- body because it cannot benefit from forward references.
19180 Analyze_Pre_Post_Condition_In_Decl_Part (N);
19182 -- Currently it is not possible to inline pre/postconditions on
19183 -- a subprogram subject to pragma Inline_Always.
19185 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
19187 -- Chain the pragma on the contract for completeness
19189 Add_Contract_Item (N, Body_Id);
19193 -------------------
19194 -- Refined_State --
19195 -------------------
19197 -- pragma Refined_State (REFINEMENT_LIST);
19199 -- REFINEMENT_LIST ::=
19200 -- REFINEMENT_CLAUSE
19201 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19203 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19205 -- CONSTITUENT_LIST ::=
19208 -- | (CONSTITUENT {, CONSTITUENT})
19210 -- CONSTITUENT ::= object_NAME | state_NAME
19212 -- Characteristics:
19214 -- * Analysis - The annotation undergoes initial checks to verify
19215 -- the legal placement and context. Secondary checks preanalyze the
19216 -- refinement clauses in:
19218 -- Analyze_Refined_State_In_Decl_Part
19220 -- * Expansion - None.
19222 -- * Template - The annotation utilizes the template of the related
19225 -- * Globals - Capture of global references must occur after full
19228 -- * Instance - The annotation is instantiated automatically when
19229 -- the related generic package body is instantiated.
19231 when Pragma_Refined_State => Refined_State : declare
19232 Pack_Decl : Node_Id;
19233 Spec_Id : Entity_Id;
19237 Check_No_Identifiers;
19238 Check_Arg_Count (1);
19240 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
19242 -- Ensure the proper placement of the pragma. Refined states must
19243 -- be associated with a package body.
19245 if Nkind (Pack_Decl) = N_Package_Body then
19248 -- Otherwise the pragma is associated with an illegal construct
19255 Spec_Id := Corresponding_Spec (Pack_Decl);
19257 -- A pragma that applies to a Ghost entity becomes Ghost for the
19258 -- purposes of legality checks and removal of ignored Ghost code.
19260 Mark_Pragma_As_Ghost (N, Spec_Id);
19262 -- State refinement is allowed only when the corresponding package
19263 -- declaration has non-null pragma Abstract_State. Refinement not
19264 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19266 if SPARK_Mode /= Off
19268 (No (Abstract_States (Spec_Id))
19269 or else Has_Null_Abstract_State (Spec_Id))
19272 ("useless refinement, package & does not define abstract "
19273 & "states", N, Spec_Id);
19277 -- Chain the pragma on the contract for further processing by
19278 -- Analyze_Refined_State_In_Decl_Part.
19280 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
19283 -----------------------
19284 -- Relative_Deadline --
19285 -----------------------
19287 -- pragma Relative_Deadline (time_span_EXPRESSION);
19289 when Pragma_Relative_Deadline => Relative_Deadline : declare
19290 P : constant Node_Id := Parent (N);
19295 Check_No_Identifiers;
19296 Check_Arg_Count (1);
19298 Arg := Get_Pragma_Arg (Arg1);
19300 -- The expression must be analyzed in the special manner described
19301 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19303 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19307 if Nkind (P) = N_Subprogram_Body then
19308 Check_In_Main_Program;
19310 -- Only Task and subprogram cases allowed
19312 elsif Nkind (P) /= N_Task_Definition then
19316 -- Check duplicate pragma before we set the corresponding flag
19318 if Has_Relative_Deadline_Pragma (P) then
19319 Error_Pragma ("duplicate pragma% not allowed");
19322 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19323 -- Relative_Deadline pragma node cannot be inserted in the Rep
19324 -- Item chain of Ent since it is rewritten by the expander as a
19325 -- procedure call statement that will break the chain.
19327 Set_Has_Relative_Deadline_Pragma (P);
19328 end Relative_Deadline;
19330 ------------------------
19331 -- Remote_Access_Type --
19332 ------------------------
19334 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19336 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19341 Check_Arg_Count (1);
19342 Check_Optional_Identifier (Arg1, Name_Entity);
19343 Check_Arg_Is_Local_Name (Arg1);
19345 E := Entity (Get_Pragma_Arg (Arg1));
19347 -- A pragma that applies to a Ghost entity becomes Ghost for the
19348 -- purposes of legality checks and removal of ignored Ghost code.
19350 Mark_Pragma_As_Ghost (N, E);
19352 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19353 and then Ekind (E) = E_General_Access_Type
19354 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19355 and then Scope (Root_Type (Directly_Designated_Type (E)))
19357 and then Is_Valid_Remote_Object_Type
19358 (Root_Type (Directly_Designated_Type (E)))
19360 Set_Is_Remote_Types (E);
19364 ("pragma% applies only to formal access to classwide types",
19367 end Remote_Access_Type;
19369 ---------------------------
19370 -- Remote_Call_Interface --
19371 ---------------------------
19373 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19375 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19376 Cunit_Node : Node_Id;
19377 Cunit_Ent : Entity_Id;
19381 Check_Ada_83_Warning;
19382 Check_Valid_Library_Unit_Pragma;
19384 if Nkind (N) = N_Null_Statement then
19388 Cunit_Node := Cunit (Current_Sem_Unit);
19389 K := Nkind (Unit (Cunit_Node));
19390 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19392 -- A pragma that applies to a Ghost entity becomes Ghost for the
19393 -- purposes of legality checks and removal of ignored Ghost code.
19395 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19397 if K = N_Package_Declaration
19398 or else K = N_Generic_Package_Declaration
19399 or else K = N_Subprogram_Declaration
19400 or else K = N_Generic_Subprogram_Declaration
19401 or else (K = N_Subprogram_Body
19402 and then Acts_As_Spec (Unit (Cunit_Node)))
19407 "pragma% must apply to package or subprogram declaration");
19410 Set_Is_Remote_Call_Interface (Cunit_Ent);
19411 end Remote_Call_Interface;
19417 -- pragma Remote_Types [(library_unit_NAME)];
19419 when Pragma_Remote_Types => Remote_Types : declare
19420 Cunit_Node : Node_Id;
19421 Cunit_Ent : Entity_Id;
19424 Check_Ada_83_Warning;
19425 Check_Valid_Library_Unit_Pragma;
19427 if Nkind (N) = N_Null_Statement then
19431 Cunit_Node := Cunit (Current_Sem_Unit);
19432 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19434 -- A pragma that applies to a Ghost entity becomes Ghost for the
19435 -- purposes of legality checks and removal of ignored Ghost code.
19437 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19439 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19440 N_Generic_Package_Declaration)
19443 ("pragma% can only apply to a package declaration");
19446 Set_Is_Remote_Types (Cunit_Ent);
19453 -- pragma Ravenscar;
19455 when Pragma_Ravenscar =>
19457 Check_Arg_Count (0);
19458 Check_Valid_Configuration_Pragma;
19459 Set_Ravenscar_Profile (N);
19461 if Warn_On_Obsolescent_Feature then
19463 ("pragma Ravenscar is an obsolescent feature?j?", N);
19465 ("|use pragma Profile (Ravenscar) instead?j?", N);
19468 -------------------------
19469 -- Restricted_Run_Time --
19470 -------------------------
19472 -- pragma Restricted_Run_Time;
19474 when Pragma_Restricted_Run_Time =>
19476 Check_Arg_Count (0);
19477 Check_Valid_Configuration_Pragma;
19478 Set_Profile_Restrictions
19479 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
19481 if Warn_On_Obsolescent_Feature then
19483 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19486 ("|use pragma Profile (Restricted) instead?j?", N);
19493 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19496 -- restriction_IDENTIFIER
19497 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19499 when Pragma_Restrictions =>
19500 Process_Restrictions_Or_Restriction_Warnings
19501 (Warn => Treat_Restrictions_As_Warnings);
19503 --------------------------
19504 -- Restriction_Warnings --
19505 --------------------------
19507 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19510 -- restriction_IDENTIFIER
19511 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19513 when Pragma_Restriction_Warnings =>
19515 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
19521 -- pragma Reviewable;
19523 when Pragma_Reviewable =>
19524 Check_Ada_83_Warning;
19525 Check_Arg_Count (0);
19527 -- Call dummy debugging function rv. This is done to assist front
19528 -- end debugging. By placing a Reviewable pragma in the source
19529 -- program, a breakpoint on rv catches this place in the source,
19530 -- allowing convenient stepping to the point of interest.
19534 --------------------------
19535 -- Short_Circuit_And_Or --
19536 --------------------------
19538 -- pragma Short_Circuit_And_Or;
19540 when Pragma_Short_Circuit_And_Or =>
19542 Check_Arg_Count (0);
19543 Check_Valid_Configuration_Pragma;
19544 Short_Circuit_And_Or := True;
19546 -------------------
19547 -- Share_Generic --
19548 -------------------
19550 -- pragma Share_Generic (GNAME {, GNAME});
19552 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19554 when Pragma_Share_Generic =>
19556 Process_Generic_List;
19562 -- pragma Shared (LOCAL_NAME);
19564 when Pragma_Shared =>
19566 Process_Atomic_Independent_Shared_Volatile;
19568 --------------------
19569 -- Shared_Passive --
19570 --------------------
19572 -- pragma Shared_Passive [(library_unit_NAME)];
19574 -- Set the flag Is_Shared_Passive of program unit name entity
19576 when Pragma_Shared_Passive => Shared_Passive : declare
19577 Cunit_Node : Node_Id;
19578 Cunit_Ent : Entity_Id;
19581 Check_Ada_83_Warning;
19582 Check_Valid_Library_Unit_Pragma;
19584 if Nkind (N) = N_Null_Statement then
19588 Cunit_Node := Cunit (Current_Sem_Unit);
19589 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19591 -- A pragma that applies to a Ghost entity becomes Ghost for the
19592 -- purposes of legality checks and removal of ignored Ghost code.
19594 Mark_Pragma_As_Ghost (N, Cunit_Ent);
19596 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19597 N_Generic_Package_Declaration)
19600 ("pragma% can only apply to a package declaration");
19603 Set_Is_Shared_Passive (Cunit_Ent);
19604 end Shared_Passive;
19606 -----------------------
19607 -- Short_Descriptors --
19608 -----------------------
19610 -- pragma Short_Descriptors;
19612 -- Recognize and validate, but otherwise ignore
19614 when Pragma_Short_Descriptors =>
19616 Check_Arg_Count (0);
19617 Check_Valid_Configuration_Pragma;
19619 ------------------------------
19620 -- Simple_Storage_Pool_Type --
19621 ------------------------------
19623 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19625 when Pragma_Simple_Storage_Pool_Type =>
19626 Simple_Storage_Pool_Type : declare
19632 Check_Arg_Count (1);
19633 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19635 Type_Id := Get_Pragma_Arg (Arg1);
19636 Find_Type (Type_Id);
19637 Typ := Entity (Type_Id);
19639 if Typ = Any_Type then
19643 -- A pragma that applies to a Ghost entity becomes Ghost for the
19644 -- purposes of legality checks and removal of ignored Ghost code.
19646 Mark_Pragma_As_Ghost (N, Typ);
19648 -- We require the pragma to apply to a type declared in a package
19649 -- declaration, but not (immediately) within a package body.
19651 if Ekind (Current_Scope) /= E_Package
19652 or else In_Package_Body (Current_Scope)
19655 ("pragma% can only apply to type declared immediately "
19656 & "within a package declaration");
19659 -- A simple storage pool type must be an immutably limited record
19660 -- or private type. If the pragma is given for a private type,
19661 -- the full type is similarly restricted (which is checked later
19662 -- in Freeze_Entity).
19664 if Is_Record_Type (Typ)
19665 and then not Is_Limited_View (Typ)
19668 ("pragma% can only apply to explicitly limited record type");
19670 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
19672 ("pragma% can only apply to a private type that is limited");
19674 elsif not Is_Record_Type (Typ)
19675 and then not Is_Private_Type (Typ)
19678 ("pragma% can only apply to limited record or private type");
19681 Record_Rep_Item (Typ, N);
19682 end Simple_Storage_Pool_Type;
19684 ----------------------
19685 -- Source_File_Name --
19686 ----------------------
19688 -- There are five forms for this pragma:
19690 -- pragma Source_File_Name (
19691 -- [UNIT_NAME =>] unit_NAME,
19692 -- BODY_FILE_NAME => STRING_LITERAL
19693 -- [, [INDEX =>] INTEGER_LITERAL]);
19695 -- pragma Source_File_Name (
19696 -- [UNIT_NAME =>] unit_NAME,
19697 -- SPEC_FILE_NAME => STRING_LITERAL
19698 -- [, [INDEX =>] INTEGER_LITERAL]);
19700 -- pragma Source_File_Name (
19701 -- BODY_FILE_NAME => STRING_LITERAL
19702 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19703 -- [, CASING => CASING_SPEC]);
19705 -- pragma Source_File_Name (
19706 -- SPEC_FILE_NAME => STRING_LITERAL
19707 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19708 -- [, CASING => CASING_SPEC]);
19710 -- pragma Source_File_Name (
19711 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19712 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19713 -- [, CASING => CASING_SPEC]);
19715 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19717 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19718 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19719 -- only be used when no project file is used, while SFNP can only be
19720 -- used when a project file is used.
19722 -- No processing here. Processing was completed during parsing, since
19723 -- we need to have file names set as early as possible. Units are
19724 -- loaded well before semantic processing starts.
19726 -- The only processing we defer to this point is the check for
19727 -- correct placement.
19729 when Pragma_Source_File_Name =>
19731 Check_Valid_Configuration_Pragma;
19733 ------------------------------
19734 -- Source_File_Name_Project --
19735 ------------------------------
19737 -- See Source_File_Name for syntax
19739 -- No processing here. Processing was completed during parsing, since
19740 -- we need to have file names set as early as possible. Units are
19741 -- loaded well before semantic processing starts.
19743 -- The only processing we defer to this point is the check for
19744 -- correct placement.
19746 when Pragma_Source_File_Name_Project =>
19748 Check_Valid_Configuration_Pragma;
19750 -- Check that a pragma Source_File_Name_Project is used only in a
19751 -- configuration pragmas file.
19753 -- Pragmas Source_File_Name_Project should only be generated by
19754 -- the Project Manager in configuration pragmas files.
19756 -- This is really an ugly test. It seems to depend on some
19757 -- accidental and undocumented property. At the very least it
19758 -- needs to be documented, but it would be better to have a
19759 -- clean way of testing if we are in a configuration file???
19761 if Present (Parent (N)) then
19763 ("pragma% can only appear in a configuration pragmas file");
19766 ----------------------
19767 -- Source_Reference --
19768 ----------------------
19770 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19772 -- Nothing to do, all processing completed in Par.Prag, since we need
19773 -- the information for possible parser messages that are output.
19775 when Pragma_Source_Reference =>
19782 -- pragma SPARK_Mode [(On | Off)];
19784 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
19785 Mode_Id : SPARK_Mode_Type;
19787 procedure Check_Pragma_Conformance
19788 (Context_Pragma : Node_Id;
19789 Entity_Pragma : Node_Id;
19790 Entity : Entity_Id);
19791 -- If Context_Pragma is not Empty, verify that the new pragma N
19792 -- is compatible with the pragma Context_Pragma that was inherited
19793 -- from the context:
19794 -- . if Context_Pragma is ON, then the new mode can be anything
19795 -- . if Context_Pragma is OFF, then the only allowed new mode is
19798 -- If Entity is not Empty, verify that the new pragma N is
19799 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19800 -- for Entity (which may be Empty):
19801 -- . if Entity_Pragma is ON, then the new mode can be anything
19802 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19804 -- . if Entity_Pragma is Empty, we always issue an error, as this
19805 -- corresponds to a case where a previous section of Entity
19806 -- had no SPARK_Mode set.
19808 procedure Check_Library_Level_Entity (E : Entity_Id);
19809 -- Verify that pragma is applied to library-level entity E
19811 procedure Set_SPARK_Flags;
19812 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19813 -- and ensures that Dynamic_Elaboration_Checks are off if the
19814 -- call sets SPARK_Mode On.
19816 ------------------------------
19817 -- Check_Pragma_Conformance --
19818 ------------------------------
19820 procedure Check_Pragma_Conformance
19821 (Context_Pragma : Node_Id;
19822 Entity_Pragma : Node_Id;
19823 Entity : Entity_Id)
19825 Arg : Node_Id := Arg1;
19828 -- The current pragma may appear without an argument. If this
19829 -- is the case, associate all error messages with the pragma
19836 -- The mode of the current pragma is compared against that of
19837 -- an enclosing context.
19839 if Present (Context_Pragma) then
19840 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
19842 -- Issue an error if the new mode is less restrictive than
19843 -- that of the context.
19845 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off
19846 and then Get_SPARK_Mode_From_Pragma (N) = On
19849 ("cannot change SPARK_Mode from Off to On", Arg);
19850 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19851 Error_Msg_N ("\SPARK_Mode was set to Off#", Arg);
19856 -- The mode of the current pragma is compared against that of
19857 -- an initial package/subprogram declaration.
19859 if Present (Entity) then
19861 -- Both the initial declaration and the completion carry
19862 -- SPARK_Mode pragmas.
19864 if Present (Entity_Pragma) then
19865 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
19867 -- Issue an error if the new mode is less restrictive
19868 -- than that of the initial declaration.
19870 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off
19871 and then Get_SPARK_Mode_From_Pragma (N) = On
19873 Error_Msg_N ("incorrect use of SPARK_Mode", Arg);
19874 Error_Msg_Sloc := Sloc (Entity_Pragma);
19876 ("\value Off was set for SPARK_Mode on&#",
19881 -- Otherwise the initial declaration lacks a SPARK_Mode
19882 -- pragma in which case the current pragma is illegal as
19883 -- it cannot "complete".
19886 Error_Msg_N ("incorrect use of SPARK_Mode", Arg);
19887 Error_Msg_Sloc := Sloc (Entity);
19889 ("\no value was set for SPARK_Mode on&#",
19894 end Check_Pragma_Conformance;
19896 --------------------------------
19897 -- Check_Library_Level_Entity --
19898 --------------------------------
19900 procedure Check_Library_Level_Entity (E : Entity_Id) is
19901 MsgF : constant String := "incorrect placement of pragma%";
19904 if not Is_Library_Level_Entity (E) then
19905 Error_Msg_Name_1 := Pname;
19906 Error_Msg_N (Fix_Error (MsgF), N);
19908 if Ekind_In (E, E_Generic_Package,
19913 ("\& is not a library-level package", N, E);
19916 ("\& is not a library-level subprogram", N, E);
19921 end Check_Library_Level_Entity;
19923 ---------------------
19924 -- Set_SPARK_Flags --
19925 ---------------------
19927 procedure Set_SPARK_Flags is
19929 SPARK_Mode := Mode_Id;
19930 SPARK_Mode_Pragma := N;
19932 if SPARK_Mode = On then
19933 Dynamic_Elaboration_Checks := False;
19935 end Set_SPARK_Flags;
19939 Body_Id : Entity_Id;
19942 Spec_Id : Entity_Id;
19945 -- Start of processing for Do_SPARK_Mode
19948 -- When a SPARK_Mode pragma appears inside an instantiation whose
19949 -- enclosing context has SPARK_Mode set to "off", the pragma has
19950 -- no semantic effect.
19952 if Ignore_Pragma_SPARK_Mode then
19953 Rewrite (N, Make_Null_Statement (Loc));
19959 Check_No_Identifiers;
19960 Check_At_Most_N_Arguments (1);
19962 -- Check the legality of the mode (no argument = ON)
19964 if Arg_Count = 1 then
19965 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19966 Mode := Chars (Get_Pragma_Arg (Arg1));
19971 Mode_Id := Get_SPARK_Mode_Type (Mode);
19972 Context := Parent (N);
19974 -- The pragma appears in a configuration pragmas file
19976 if No (Context) then
19977 Check_Valid_Configuration_Pragma;
19979 if Present (SPARK_Mode_Pragma) then
19980 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19981 Error_Msg_N ("pragma% duplicates pragma declared#", N);
19987 -- The pragma acts as a configuration pragma in a compilation unit
19989 -- pragma SPARK_Mode ...;
19990 -- package Pack is ...;
19992 elsif Nkind (Context) = N_Compilation_Unit
19993 and then List_Containing (N) = Context_Items (Context)
19995 Check_Valid_Configuration_Pragma;
19998 -- Otherwise the placement of the pragma within the tree dictates
19999 -- its associated construct. Inspect the declarative list where
20000 -- the pragma resides to find a potential construct.
20004 while Present (Stmt) loop
20006 -- Skip prior pragmas, but check for duplicates
20008 if Nkind (Stmt) = N_Pragma then
20009 if Pragma_Name (Stmt) = Pname then
20010 Error_Msg_Name_1 := Pname;
20011 Error_Msg_Sloc := Sloc (Stmt);
20012 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20016 -- The pragma applies to a [generic] subprogram declaration.
20017 -- Note that this case covers an internally generated spec
20018 -- for a stand alone body.
20021 -- procedure Proc ...;
20022 -- pragma SPARK_Mode ..;
20024 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
20025 N_Subprogram_Declaration)
20027 Spec_Id := Defining_Entity (Stmt);
20028 Check_Library_Level_Entity (Spec_Id);
20029 Check_Pragma_Conformance
20030 (Context_Pragma => SPARK_Pragma (Spec_Id),
20031 Entity_Pragma => Empty,
20034 Set_SPARK_Pragma (Spec_Id, N);
20035 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20038 -- Skip internally generated code
20040 elsif not Comes_From_Source (Stmt) then
20043 -- Otherwise the pragma does not apply to a legal construct
20044 -- or it does not appear at the top of a declarative or a
20045 -- statement list. Issue an error and stop the analysis.
20055 -- The pragma applies to a package or a subprogram that acts as
20056 -- a compilation unit.
20058 -- procedure Proc ...;
20059 -- pragma SPARK_Mode ...;
20061 if Nkind (Context) = N_Compilation_Unit_Aux then
20062 Context := Unit (Parent (Context));
20065 -- The pragma appears within package declarations
20067 if Nkind (Context) = N_Package_Specification then
20068 Spec_Id := Defining_Entity (Context);
20069 Check_Library_Level_Entity (Spec_Id);
20071 -- The pragma is at the top of the visible declarations
20074 -- pragma SPARK_Mode ...;
20076 if List_Containing (N) = Visible_Declarations (Context) then
20077 Check_Pragma_Conformance
20078 (Context_Pragma => SPARK_Pragma (Spec_Id),
20079 Entity_Pragma => Empty,
20083 Set_SPARK_Pragma (Spec_Id, N);
20084 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20085 Set_SPARK_Aux_Pragma (Spec_Id, N);
20086 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20088 -- The pragma is at the top of the private declarations
20092 -- pragma SPARK_Mode ...;
20095 Check_Pragma_Conformance
20096 (Context_Pragma => Empty,
20097 Entity_Pragma => SPARK_Pragma (Spec_Id),
20098 Entity => Spec_Id);
20101 Set_SPARK_Aux_Pragma (Spec_Id, N);
20102 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
20105 -- The pragma appears at the top of package body declarations
20107 -- package body Pack is
20108 -- pragma SPARK_Mode ...;
20110 elsif Nkind (Context) = N_Package_Body then
20111 Spec_Id := Corresponding_Spec (Context);
20112 Body_Id := Defining_Entity (Context);
20113 Check_Library_Level_Entity (Body_Id);
20114 Check_Pragma_Conformance
20115 (Context_Pragma => SPARK_Pragma (Body_Id),
20116 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id),
20117 Entity => Spec_Id);
20120 Set_SPARK_Pragma (Body_Id, N);
20121 Set_SPARK_Pragma_Inherited (Body_Id, False);
20122 Set_SPARK_Aux_Pragma (Body_Id, N);
20123 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20125 -- The pragma appears at the top of package body statements
20127 -- package body Pack is
20129 -- pragma SPARK_Mode;
20131 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
20132 and then Nkind (Parent (Context)) = N_Package_Body
20134 Context := Parent (Context);
20135 Spec_Id := Corresponding_Spec (Context);
20136 Body_Id := Defining_Entity (Context);
20137 Check_Library_Level_Entity (Body_Id);
20138 Check_Pragma_Conformance
20139 (Context_Pragma => Empty,
20140 Entity_Pragma => SPARK_Pragma (Body_Id),
20141 Entity => Body_Id);
20144 Set_SPARK_Aux_Pragma (Body_Id, N);
20145 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20147 -- The pragma appeared as an aspect of a [generic] subprogram
20148 -- declaration that acts as a compilation unit.
20151 -- procedure Proc ...;
20152 -- pragma SPARK_Mode ...;
20154 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
20155 N_Subprogram_Declaration)
20157 Spec_Id := Defining_Entity (Context);
20158 Check_Library_Level_Entity (Spec_Id);
20159 Check_Pragma_Conformance
20160 (Context_Pragma => SPARK_Pragma (Spec_Id),
20161 Entity_Pragma => Empty,
20164 Set_SPARK_Pragma (Spec_Id, N);
20165 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20167 -- The pragma appears at the top of subprogram body
20170 -- procedure Proc ... is
20171 -- pragma SPARK_Mode;
20173 elsif Nkind (Context) = N_Subprogram_Body then
20174 Spec_Id := Corresponding_Spec (Context);
20175 Context := Specification (Context);
20176 Body_Id := Defining_Entity (Context);
20178 -- Ignore pragma when applied to the special body created
20179 -- for inlining, recognized by its internal name _Parent.
20181 if Chars (Body_Id) = Name_uParent then
20185 Check_Library_Level_Entity (Body_Id);
20187 -- The body is a completion of a previous declaration
20189 if Present (Spec_Id) then
20190 Check_Pragma_Conformance
20191 (Context_Pragma => SPARK_Pragma (Body_Id),
20192 Entity_Pragma => SPARK_Pragma (Spec_Id),
20193 Entity => Spec_Id);
20195 -- The body acts as spec
20198 Check_Pragma_Conformance
20199 (Context_Pragma => SPARK_Pragma (Body_Id),
20200 Entity_Pragma => Empty,
20206 Set_SPARK_Pragma (Body_Id, N);
20207 Set_SPARK_Pragma_Inherited (Body_Id, False);
20209 -- The pragma does not apply to a legal construct, issue error
20217 --------------------------------
20218 -- Static_Elaboration_Desired --
20219 --------------------------------
20221 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20223 when Pragma_Static_Elaboration_Desired =>
20225 Check_At_Most_N_Arguments (1);
20227 if Is_Compilation_Unit (Current_Scope)
20228 and then Ekind (Current_Scope) = E_Package
20230 Set_Static_Elaboration_Desired (Current_Scope, True);
20232 Error_Pragma ("pragma% must apply to a library-level package");
20239 -- pragma Storage_Size (EXPRESSION);
20241 when Pragma_Storage_Size => Storage_Size : declare
20242 P : constant Node_Id := Parent (N);
20246 Check_No_Identifiers;
20247 Check_Arg_Count (1);
20249 -- The expression must be analyzed in the special manner described
20250 -- in "Handling of Default Expressions" in sem.ads.
20252 Arg := Get_Pragma_Arg (Arg1);
20253 Preanalyze_Spec_Expression (Arg, Any_Integer);
20255 if not Is_OK_Static_Expression (Arg) then
20256 Check_Restriction (Static_Storage_Size, Arg);
20259 if Nkind (P) /= N_Task_Definition then
20264 if Has_Storage_Size_Pragma (P) then
20265 Error_Pragma ("duplicate pragma% not allowed");
20267 Set_Has_Storage_Size_Pragma (P, True);
20270 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
20278 -- pragma Storage_Unit (NUMERIC_LITERAL);
20280 -- Only permitted argument is System'Storage_Unit value
20282 when Pragma_Storage_Unit =>
20283 Check_No_Identifiers;
20284 Check_Arg_Count (1);
20285 Check_Arg_Is_Integer_Literal (Arg1);
20287 if Intval (Get_Pragma_Arg (Arg1)) /=
20288 UI_From_Int (Ttypes.System_Storage_Unit)
20290 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
20292 ("the only allowed argument for pragma% is ^", Arg1);
20295 --------------------
20296 -- Stream_Convert --
20297 --------------------
20299 -- pragma Stream_Convert (
20300 -- [Entity =>] type_LOCAL_NAME,
20301 -- [Read =>] function_NAME,
20302 -- [Write =>] function NAME);
20304 when Pragma_Stream_Convert => Stream_Convert : declare
20306 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
20307 -- Check that the given argument is the name of a local function
20308 -- of one argument that is not overloaded earlier in the current
20309 -- local scope. A check is also made that the argument is a
20310 -- function with one parameter.
20312 --------------------------------------
20313 -- Check_OK_Stream_Convert_Function --
20314 --------------------------------------
20316 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
20320 Check_Arg_Is_Local_Name (Arg);
20321 Ent := Entity (Get_Pragma_Arg (Arg));
20323 if Has_Homonym (Ent) then
20325 ("argument for pragma% may not be overloaded", Arg);
20328 if Ekind (Ent) /= E_Function
20329 or else No (First_Formal (Ent))
20330 or else Present (Next_Formal (First_Formal (Ent)))
20333 ("argument for pragma% must be function of one argument",
20336 end Check_OK_Stream_Convert_Function;
20338 -- Start of processing for Stream_Convert
20342 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
20343 Check_Arg_Count (3);
20344 Check_Optional_Identifier (Arg1, Name_Entity);
20345 Check_Optional_Identifier (Arg2, Name_Read);
20346 Check_Optional_Identifier (Arg3, Name_Write);
20347 Check_Arg_Is_Local_Name (Arg1);
20348 Check_OK_Stream_Convert_Function (Arg2);
20349 Check_OK_Stream_Convert_Function (Arg3);
20352 Typ : constant Entity_Id :=
20353 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
20354 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
20355 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
20358 Check_First_Subtype (Arg1);
20360 -- Check for too early or too late. Note that we don't enforce
20361 -- the rule about primitive operations in this case, since, as
20362 -- is the case for explicit stream attributes themselves, these
20363 -- restrictions are not appropriate. Note that the chaining of
20364 -- the pragma by Rep_Item_Too_Late is actually the critical
20365 -- processing done for this pragma.
20367 if Rep_Item_Too_Early (Typ, N)
20369 Rep_Item_Too_Late (Typ, N, FOnly => True)
20374 -- Return if previous error
20376 if Etype (Typ) = Any_Type
20378 Etype (Read) = Any_Type
20380 Etype (Write) = Any_Type
20387 if Underlying_Type (Etype (Read)) /= Typ then
20389 ("incorrect return type for function&", Arg2);
20392 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
20394 ("incorrect parameter type for function&", Arg3);
20397 if Underlying_Type (Etype (First_Formal (Read))) /=
20398 Underlying_Type (Etype (Write))
20401 ("result type of & does not match Read parameter type",
20405 end Stream_Convert;
20411 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20413 -- This is processed by the parser since some of the style checks
20414 -- take place during source scanning and parsing. This means that
20415 -- we don't need to issue error messages here.
20417 when Pragma_Style_Checks => Style_Checks : declare
20418 A : constant Node_Id := Get_Pragma_Arg (Arg1);
20424 Check_No_Identifiers;
20426 -- Two argument form
20428 if Arg_Count = 2 then
20429 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20436 E_Id := Get_Pragma_Arg (Arg2);
20439 if not Is_Entity_Name (E_Id) then
20441 ("second argument of pragma% must be entity name",
20445 E := Entity (E_Id);
20447 if not Ignore_Style_Checks_Pragmas then
20452 Set_Suppress_Style_Checks
20453 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
20454 exit when No (Homonym (E));
20461 -- One argument form
20464 Check_Arg_Count (1);
20466 if Nkind (A) = N_String_Literal then
20470 Slen : constant Natural := Natural (String_Length (S));
20471 Options : String (1 .. Slen);
20477 C := Get_String_Char (S, Int (J));
20478 exit when not In_Character_Range (C);
20479 Options (J) := Get_Character (C);
20481 -- If at end of string, set options. As per discussion
20482 -- above, no need to check for errors, since we issued
20483 -- them in the parser.
20486 if not Ignore_Style_Checks_Pragmas then
20487 Set_Style_Check_Options (Options);
20497 elsif Nkind (A) = N_Identifier then
20498 if Chars (A) = Name_All_Checks then
20499 if not Ignore_Style_Checks_Pragmas then
20501 Set_GNAT_Style_Check_Options;
20503 Set_Default_Style_Check_Options;
20507 elsif Chars (A) = Name_On then
20508 if not Ignore_Style_Checks_Pragmas then
20509 Style_Check := True;
20512 elsif Chars (A) = Name_Off then
20513 if not Ignore_Style_Checks_Pragmas then
20514 Style_Check := False;
20525 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20527 when Pragma_Subtitle =>
20529 Check_Arg_Count (1);
20530 Check_Optional_Identifier (Arg1, Name_Subtitle);
20531 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20538 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20540 when Pragma_Suppress =>
20541 Process_Suppress_Unsuppress (Suppress_Case => True);
20547 -- pragma Suppress_All;
20549 -- The only check made here is that the pragma has no arguments.
20550 -- There are no placement rules, and the processing required (setting
20551 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20552 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20553 -- then creates and inserts a pragma Suppress (All_Checks).
20555 when Pragma_Suppress_All =>
20557 Check_Arg_Count (0);
20559 -------------------------
20560 -- Suppress_Debug_Info --
20561 -------------------------
20563 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20565 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
20566 Nam_Id : Entity_Id;
20570 Check_Arg_Count (1);
20571 Check_Optional_Identifier (Arg1, Name_Entity);
20572 Check_Arg_Is_Local_Name (Arg1);
20574 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
20576 -- A pragma that applies to a Ghost entity becomes Ghost for the
20577 -- purposes of legality checks and removal of ignored Ghost code.
20579 Mark_Pragma_As_Ghost (N, Nam_Id);
20580 Set_Debug_Info_Off (Nam_Id);
20581 end Suppress_Debug_Info;
20583 ----------------------------------
20584 -- Suppress_Exception_Locations --
20585 ----------------------------------
20587 -- pragma Suppress_Exception_Locations;
20589 when Pragma_Suppress_Exception_Locations =>
20591 Check_Arg_Count (0);
20592 Check_Valid_Configuration_Pragma;
20593 Exception_Locations_Suppressed := True;
20595 -----------------------------
20596 -- Suppress_Initialization --
20597 -----------------------------
20599 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20601 when Pragma_Suppress_Initialization => Suppress_Init : declare
20607 Check_Arg_Count (1);
20608 Check_Optional_Identifier (Arg1, Name_Entity);
20609 Check_Arg_Is_Local_Name (Arg1);
20611 E_Id := Get_Pragma_Arg (Arg1);
20613 if Etype (E_Id) = Any_Type then
20617 E := Entity (E_Id);
20619 -- A pragma that applies to a Ghost entity becomes Ghost for the
20620 -- purposes of legality checks and removal of ignored Ghost code.
20622 Mark_Pragma_As_Ghost (N, E);
20624 if not Is_Type (E) and then Ekind (E) /= E_Variable then
20626 ("pragma% requires variable, type or subtype", Arg1);
20629 if Rep_Item_Too_Early (E, N)
20631 Rep_Item_Too_Late (E, N, FOnly => True)
20636 -- For incomplete/private type, set flag on full view
20638 if Is_Incomplete_Or_Private_Type (E) then
20639 if No (Full_View (Base_Type (E))) then
20641 ("argument of pragma% cannot be an incomplete type", Arg1);
20643 Set_Suppress_Initialization (Full_View (Base_Type (E)));
20646 -- For first subtype, set flag on base type
20648 elsif Is_First_Subtype (E) then
20649 Set_Suppress_Initialization (Base_Type (E));
20651 -- For other than first subtype, set flag on subtype or variable
20654 Set_Suppress_Initialization (E);
20662 -- pragma System_Name (DIRECT_NAME);
20664 -- Syntax check: one argument, which must be the identifier GNAT or
20665 -- the identifier GCC, no other identifiers are acceptable.
20667 when Pragma_System_Name =>
20669 Check_No_Identifiers;
20670 Check_Arg_Count (1);
20671 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
20673 -----------------------------
20674 -- Task_Dispatching_Policy --
20675 -----------------------------
20677 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20679 when Pragma_Task_Dispatching_Policy => declare
20683 Check_Ada_83_Warning;
20684 Check_Arg_Count (1);
20685 Check_No_Identifiers;
20686 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
20687 Check_Valid_Configuration_Pragma;
20688 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20689 DP := Fold_Upper (Name_Buffer (1));
20691 if Task_Dispatching_Policy /= ' '
20692 and then Task_Dispatching_Policy /= DP
20694 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
20696 ("task dispatching policy incompatible with policy#");
20698 -- Set new policy, but always preserve System_Location since we
20699 -- like the error message with the run time name.
20702 Task_Dispatching_Policy := DP;
20704 if Task_Dispatching_Policy_Sloc /= System_Location then
20705 Task_Dispatching_Policy_Sloc := Loc;
20714 -- pragma Task_Info (EXPRESSION);
20716 when Pragma_Task_Info => Task_Info : declare
20717 P : constant Node_Id := Parent (N);
20723 if Warn_On_Obsolescent_Feature then
20725 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20726 & "instead?j?", N);
20729 if Nkind (P) /= N_Task_Definition then
20730 Error_Pragma ("pragma% must appear in task definition");
20733 Check_No_Identifiers;
20734 Check_Arg_Count (1);
20736 Analyze_And_Resolve
20737 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
20739 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
20743 Ent := Defining_Identifier (Parent (P));
20745 -- Check duplicate pragma before we chain the pragma in the Rep
20746 -- Item chain of Ent.
20749 (Ent, Name_Task_Info, Check_Parents => False)
20751 Error_Pragma ("duplicate pragma% not allowed");
20754 Record_Rep_Item (Ent, N);
20761 -- pragma Task_Name (string_EXPRESSION);
20763 when Pragma_Task_Name => Task_Name : declare
20764 P : constant Node_Id := Parent (N);
20769 Check_No_Identifiers;
20770 Check_Arg_Count (1);
20772 Arg := Get_Pragma_Arg (Arg1);
20774 -- The expression is used in the call to Create_Task, and must be
20775 -- expanded there, not in the context of the current spec. It must
20776 -- however be analyzed to capture global references, in case it
20777 -- appears in a generic context.
20779 Preanalyze_And_Resolve (Arg, Standard_String);
20781 if Nkind (P) /= N_Task_Definition then
20785 Ent := Defining_Identifier (Parent (P));
20787 -- Check duplicate pragma before we chain the pragma in the Rep
20788 -- Item chain of Ent.
20791 (Ent, Name_Task_Name, Check_Parents => False)
20793 Error_Pragma ("duplicate pragma% not allowed");
20796 Record_Rep_Item (Ent, N);
20803 -- pragma Task_Storage (
20804 -- [Task_Type =>] LOCAL_NAME,
20805 -- [Top_Guard =>] static_integer_EXPRESSION);
20807 when Pragma_Task_Storage => Task_Storage : declare
20808 Args : Args_List (1 .. 2);
20809 Names : constant Name_List (1 .. 2) := (
20813 Task_Type : Node_Id renames Args (1);
20814 Top_Guard : Node_Id renames Args (2);
20820 Gather_Associations (Names, Args);
20822 if No (Task_Type) then
20824 ("missing task_type argument for pragma%");
20827 Check_Arg_Is_Local_Name (Task_Type);
20829 Ent := Entity (Task_Type);
20831 if not Is_Task_Type (Ent) then
20833 ("argument for pragma% must be task type", Task_Type);
20836 if No (Top_Guard) then
20838 ("pragma% takes two arguments", Task_Type);
20840 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
20843 Check_First_Subtype (Task_Type);
20845 if Rep_Item_Too_Late (Ent, N) then
20854 -- pragma Test_Case
20855 -- ([Name =>] Static_String_EXPRESSION
20856 -- ,[Mode =>] MODE_TYPE
20857 -- [, Requires => Boolean_EXPRESSION]
20858 -- [, Ensures => Boolean_EXPRESSION]);
20860 -- MODE_TYPE ::= Nominal | Robustness
20862 -- Characteristics:
20864 -- * Analysis - The annotation undergoes initial checks to verify
20865 -- the legal placement and context. Secondary checks preanalyze the
20868 -- Analyze_Test_Case_In_Decl_Part
20870 -- * Expansion - None.
20872 -- * Template - The annotation utilizes the generic template of the
20873 -- related subprogram when it is:
20875 -- aspect on subprogram declaration
20877 -- The annotation must prepare its own template when it is:
20879 -- pragma on subprogram declaration
20881 -- * Globals - Capture of global references must occur after full
20884 -- * Instance - The annotation is instantiated automatically when
20885 -- the related generic subprogram is instantiated except for the
20886 -- "pragma on subprogram declaration" case. In that scenario the
20887 -- annotation must instantiate itself.
20889 when Pragma_Test_Case => Test_Case : declare
20890 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
20891 -- Ensure that the contract of subprogram Subp_Id does not contain
20892 -- another Test_Case pragma with the same Name as the current one.
20894 -------------------------
20895 -- Check_Distinct_Name --
20896 -------------------------
20898 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
20899 Items : constant Node_Id := Contract (Subp_Id);
20900 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
20904 -- Inspect all Test_Case pragma of the related subprogram
20905 -- looking for one with a duplicate "Name" argument.
20907 if Present (Items) then
20908 Prag := Contract_Test_Cases (Items);
20909 while Present (Prag) loop
20910 if Pragma_Name (Prag) = Name_Test_Case
20911 and then String_Equal
20912 (Name, Get_Name_From_CTC_Pragma (Prag))
20914 Error_Msg_Sloc := Sloc (Prag);
20915 Error_Pragma ("name for pragma % is already used #");
20918 Prag := Next_Pragma (Prag);
20921 end Check_Distinct_Name;
20925 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
20928 Subp_Decl : Node_Id;
20929 Subp_Id : Entity_Id;
20931 -- Start of processing for Test_Case
20935 Check_At_Least_N_Arguments (2);
20936 Check_At_Most_N_Arguments (4);
20938 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
20942 Check_Optional_Identifier (Arg1, Name_Name);
20943 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20947 Check_Optional_Identifier (Arg2, Name_Mode);
20948 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
20950 -- Arguments "Requires" and "Ensures"
20952 if Present (Arg3) then
20953 if Present (Arg4) then
20954 Check_Identifier (Arg3, Name_Requires);
20955 Check_Identifier (Arg4, Name_Ensures);
20957 Check_Identifier_Is_One_Of
20958 (Arg3, Name_Requires, Name_Ensures);
20962 -- Pragma Test_Case must be associated with a subprogram declared
20963 -- in a library-level package. First determine whether the current
20964 -- compilation unit is a legal context.
20966 if Nkind_In (Pack_Decl, N_Package_Declaration,
20967 N_Generic_Package_Declaration)
20971 -- Otherwise the placement is illegal
20978 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
20980 -- Find the enclosing context
20982 Context := Parent (Subp_Decl);
20984 if Present (Context) then
20985 Context := Parent (Context);
20988 -- Verify the placement of the pragma
20990 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
20992 ("pragma % cannot be applied to abstract subprogram");
20995 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
20996 Error_Pragma ("pragma % cannot be applied to entry");
20999 -- The context is a [generic] subprogram declared at the top level
21000 -- of the [generic] package unit.
21002 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
21003 N_Subprogram_Declaration)
21004 and then Present (Context)
21005 and then Nkind_In (Context, N_Generic_Package_Declaration,
21006 N_Package_Declaration)
21008 Subp_Id := Defining_Entity (Subp_Decl);
21010 -- Otherwise the placement is illegal
21017 -- A pragma that applies to a Ghost entity becomes Ghost for the
21018 -- purposes of legality checks and removal of ignored Ghost code.
21020 Mark_Pragma_As_Ghost (N, Subp_Id);
21022 -- Preanalyze the original aspect argument "Name" for ASIS or for
21023 -- a generic subprogram to properly capture global references.
21025 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
21026 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
21028 if Present (Asp_Arg) then
21030 -- The argument appears with an identifier in association
21033 if Nkind (Asp_Arg) = N_Component_Association then
21034 Asp_Arg := Expression (Asp_Arg);
21037 Check_Expr_Is_OK_Static_Expression
21038 (Asp_Arg, Standard_String);
21042 -- Ensure that the all Test_Case pragmas of the related subprogram
21043 -- have distinct names.
21045 Check_Distinct_Name (Subp_Id);
21047 -- Fully analyze the pragma when it appears inside a subprogram
21048 -- body because it cannot benefit from forward references.
21050 if Nkind_In (Subp_Decl, N_Subprogram_Body,
21051 N_Subprogram_Body_Stub)
21053 Analyze_Test_Case_In_Decl_Part (N);
21056 -- Chain the pragma on the contract for further processing by
21057 -- Analyze_Test_Case_In_Decl_Part.
21059 Add_Contract_Item (N, Subp_Id);
21062 --------------------------
21063 -- Thread_Local_Storage --
21064 --------------------------
21066 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21068 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
21074 Check_Arg_Count (1);
21075 Check_Optional_Identifier (Arg1, Name_Entity);
21076 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21078 Id := Get_Pragma_Arg (Arg1);
21081 if not Is_Entity_Name (Id)
21082 or else Ekind (Entity (Id)) /= E_Variable
21084 Error_Pragma_Arg ("local variable name required", Arg1);
21089 -- A pragma that applies to a Ghost entity becomes Ghost for the
21090 -- purposes of legality checks and removal of ignored Ghost code.
21092 Mark_Pragma_As_Ghost (N, E);
21094 if Rep_Item_Too_Early (E, N)
21096 Rep_Item_Too_Late (E, N)
21101 Set_Has_Pragma_Thread_Local_Storage (E);
21102 Set_Has_Gigi_Rep_Item (E);
21103 end Thread_Local_Storage;
21109 -- pragma Time_Slice (static_duration_EXPRESSION);
21111 when Pragma_Time_Slice => Time_Slice : declare
21117 Check_Arg_Count (1);
21118 Check_No_Identifiers;
21119 Check_In_Main_Program;
21120 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
21122 if not Error_Posted (Arg1) then
21124 while Present (Nod) loop
21125 if Nkind (Nod) = N_Pragma
21126 and then Pragma_Name (Nod) = Name_Time_Slice
21128 Error_Msg_Name_1 := Pname;
21129 Error_Msg_N ("duplicate pragma% not permitted", Nod);
21136 -- Process only if in main unit
21138 if Get_Source_Unit (Loc) = Main_Unit then
21139 Opt.Time_Slice_Set := True;
21140 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
21142 if Val <= Ureal_0 then
21143 Opt.Time_Slice_Value := 0;
21145 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
21146 Opt.Time_Slice_Value := 1_000_000_000;
21149 Opt.Time_Slice_Value :=
21150 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
21159 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
21161 -- TITLING_OPTION ::=
21162 -- [Title =>] STRING_LITERAL
21163 -- | [Subtitle =>] STRING_LITERAL
21165 when Pragma_Title => Title : declare
21166 Args : Args_List (1 .. 2);
21167 Names : constant Name_List (1 .. 2) := (
21173 Gather_Associations (Names, Args);
21176 for J in 1 .. 2 loop
21177 if Present (Args (J)) then
21178 Check_Arg_Is_OK_Static_Expression
21179 (Args (J), Standard_String);
21184 ----------------------------
21185 -- Type_Invariant[_Class] --
21186 ----------------------------
21188 -- pragma Type_Invariant[_Class]
21189 -- ([Entity =>] type_LOCAL_NAME,
21190 -- [Check =>] EXPRESSION);
21192 when Pragma_Type_Invariant |
21193 Pragma_Type_Invariant_Class =>
21194 Type_Invariant : declare
21195 I_Pragma : Node_Id;
21198 Check_Arg_Count (2);
21200 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
21201 -- setting Class_Present for the Type_Invariant_Class case.
21203 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
21204 I_Pragma := New_Copy (N);
21205 Set_Pragma_Identifier
21206 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
21207 Rewrite (N, I_Pragma);
21208 Set_Analyzed (N, False);
21210 end Type_Invariant;
21212 ---------------------
21213 -- Unchecked_Union --
21214 ---------------------
21216 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
21218 when Pragma_Unchecked_Union => Unchecked_Union : declare
21219 Assoc : constant Node_Id := Arg1;
21220 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
21230 Check_No_Identifiers;
21231 Check_Arg_Count (1);
21232 Check_Arg_Is_Local_Name (Arg1);
21234 Find_Type (Type_Id);
21236 Typ := Entity (Type_Id);
21238 -- A pragma that applies to a Ghost entity becomes Ghost for the
21239 -- purposes of legality checks and removal of ignored Ghost code.
21241 Mark_Pragma_As_Ghost (N, Typ);
21244 or else Rep_Item_Too_Early (Typ, N)
21248 Typ := Underlying_Type (Typ);
21251 if Rep_Item_Too_Late (Typ, N) then
21255 Check_First_Subtype (Arg1);
21257 -- Note remaining cases are references to a type in the current
21258 -- declarative part. If we find an error, we post the error on
21259 -- the relevant type declaration at an appropriate point.
21261 if not Is_Record_Type (Typ) then
21262 Error_Msg_N ("unchecked union must be record type", Typ);
21265 elsif Is_Tagged_Type (Typ) then
21266 Error_Msg_N ("unchecked union must not be tagged", Typ);
21269 elsif not Has_Discriminants (Typ) then
21271 ("unchecked union must have one discriminant", Typ);
21274 -- Note: in previous versions of GNAT we used to check for limited
21275 -- types and give an error, but in fact the standard does allow
21276 -- Unchecked_Union on limited types, so this check was removed.
21278 -- Similarly, GNAT used to require that all discriminants have
21279 -- default values, but this is not mandated by the RM.
21281 -- Proceed with basic error checks completed
21284 Tdef := Type_Definition (Declaration_Node (Typ));
21285 Clist := Component_List (Tdef);
21287 -- Check presence of component list and variant part
21289 if No (Clist) or else No (Variant_Part (Clist)) then
21291 ("unchecked union must have variant part", Tdef);
21295 -- Check components
21297 Comp := First (Component_Items (Clist));
21298 while Present (Comp) loop
21299 Check_Component (Comp, Typ);
21303 -- Check variant part
21305 Vpart := Variant_Part (Clist);
21307 Variant := First (Variants (Vpart));
21308 while Present (Variant) loop
21309 Check_Variant (Variant, Typ);
21314 Set_Is_Unchecked_Union (Typ);
21315 Set_Convention (Typ, Convention_C);
21316 Set_Has_Unchecked_Union (Base_Type (Typ));
21317 Set_Is_Unchecked_Union (Base_Type (Typ));
21318 end Unchecked_Union;
21320 ------------------------
21321 -- Unimplemented_Unit --
21322 ------------------------
21324 -- pragma Unimplemented_Unit;
21326 -- Note: this only gives an error if we are generating code, or if
21327 -- we are in a generic library unit (where the pragma appears in the
21328 -- body, not in the spec).
21330 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
21331 Cunitent : constant Entity_Id :=
21332 Cunit_Entity (Get_Source_Unit (Loc));
21333 Ent_Kind : constant Entity_Kind :=
21338 Check_Arg_Count (0);
21340 if Operating_Mode = Generate_Code
21341 or else Ent_Kind = E_Generic_Function
21342 or else Ent_Kind = E_Generic_Procedure
21343 or else Ent_Kind = E_Generic_Package
21345 Get_Name_String (Chars (Cunitent));
21346 Set_Casing (Mixed_Case);
21347 Write_Str (Name_Buffer (1 .. Name_Len));
21348 Write_Str (" is not supported in this configuration");
21350 raise Unrecoverable_Error;
21352 end Unimplemented_Unit;
21354 ------------------------
21355 -- Universal_Aliasing --
21356 ------------------------
21358 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
21360 when Pragma_Universal_Aliasing => Universal_Alias : declare
21365 Check_Arg_Count (1);
21366 Check_Optional_Identifier (Arg2, Name_Entity);
21367 Check_Arg_Is_Local_Name (Arg1);
21368 E_Id := Entity (Get_Pragma_Arg (Arg1));
21370 if E_Id = Any_Type then
21372 elsif No (E_Id) or else not Is_Type (E_Id) then
21373 Error_Pragma_Arg ("pragma% requires type", Arg1);
21376 -- A pragma that applies to a Ghost entity becomes Ghost for the
21377 -- purposes of legality checks and removal of ignored Ghost code.
21379 Mark_Pragma_As_Ghost (N, E_Id);
21380 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
21381 Record_Rep_Item (E_Id, N);
21382 end Universal_Alias;
21384 --------------------
21385 -- Universal_Data --
21386 --------------------
21388 -- pragma Universal_Data [(library_unit_NAME)];
21390 when Pragma_Universal_Data =>
21393 -- If this is a configuration pragma, then set the universal
21394 -- addressing option, otherwise confirm that the pragma satisfies
21395 -- the requirements of library unit pragma placement and leave it
21396 -- to the GNAAMP back end to detect the pragma (avoids transitive
21397 -- setting of the option due to withed units).
21399 if Is_Configuration_Pragma then
21400 Universal_Addressing_On_AAMP := True;
21402 Check_Valid_Library_Unit_Pragma;
21405 if not AAMP_On_Target then
21406 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
21413 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
21415 when Pragma_Unmodified => Unmodified : declare
21417 Arg_Expr : Node_Id;
21418 Arg_Id : Entity_Id;
21420 Ghost_Error_Posted : Boolean := False;
21421 -- Flag set when an error concerning the illegal mix of Ghost and
21422 -- non-Ghost variables is emitted.
21424 Ghost_Id : Entity_Id := Empty;
21425 -- The entity of the first Ghost variable encountered while
21426 -- processing the arguments of the pragma.
21430 Check_At_Least_N_Arguments (1);
21432 -- Loop through arguments
21435 while Present (Arg) loop
21436 Check_No_Identifier (Arg);
21438 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21439 -- in fact generate reference, so that the entity will have a
21440 -- reference, which will inhibit any warnings about it not
21441 -- being referenced, and also properly show up in the ali file
21442 -- as a reference. But this reference is recorded before the
21443 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21444 -- generated for this reference.
21446 Check_Arg_Is_Local_Name (Arg);
21447 Arg_Expr := Get_Pragma_Arg (Arg);
21449 if Is_Entity_Name (Arg_Expr) then
21450 Arg_Id := Entity (Arg_Expr);
21452 if Is_Assignable (Arg_Id) then
21453 Set_Has_Pragma_Unmodified (Arg_Id);
21455 -- A pragma that applies to a Ghost entity becomes Ghost
21456 -- for the purposes of legality checks and removal of
21457 -- ignored Ghost code.
21459 Mark_Pragma_As_Ghost (N, Arg_Id);
21461 -- Capture the entity of the first Ghost variable being
21462 -- processed for error detection purposes.
21464 if Is_Ghost_Entity (Arg_Id) then
21465 if No (Ghost_Id) then
21466 Ghost_Id := Arg_Id;
21469 -- Otherwise the variable is non-Ghost. It is illegal
21470 -- to mix references to Ghost and non-Ghost entities
21473 elsif Present (Ghost_Id)
21474 and then not Ghost_Error_Posted
21476 Ghost_Error_Posted := True;
21478 Error_Msg_Name_1 := Pname;
21480 ("pragma % cannot mention ghost and non-ghost "
21483 Error_Msg_Sloc := Sloc (Ghost_Id);
21484 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
21486 Error_Msg_Sloc := Sloc (Arg_Id);
21487 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
21490 -- Otherwise the pragma referenced an illegal entity
21494 ("pragma% can only be applied to a variable", Arg_Expr);
21506 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21508 -- or when used in a context clause:
21510 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21512 when Pragma_Unreferenced => Unreferenced : declare
21514 Arg_Expr : Node_Id;
21515 Arg_Id : Entity_Id;
21518 Ghost_Error_Posted : Boolean := False;
21519 -- Flag set when an error concerning the illegal mix of Ghost and
21520 -- non-Ghost names is emitted.
21522 Ghost_Id : Entity_Id := Empty;
21523 -- The entity of the first Ghost name encountered while processing
21524 -- the arguments of the pragma.
21528 Check_At_Least_N_Arguments (1);
21530 -- Check case of appearing within context clause
21532 if Is_In_Context_Clause then
21534 -- The arguments must all be units mentioned in a with clause
21535 -- in the same context clause. Note we already checked (in
21536 -- Par.Prag) that the arguments are either identifiers or
21537 -- selected components.
21540 while Present (Arg) loop
21541 Citem := First (List_Containing (N));
21542 while Citem /= N loop
21543 Arg_Expr := Get_Pragma_Arg (Arg);
21545 if Nkind (Citem) = N_With_Clause
21546 and then Same_Name (Name (Citem), Arg_Expr)
21548 Set_Has_Pragma_Unreferenced
21551 (Library_Unit (Citem))));
21552 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
21561 ("argument of pragma% is not withed unit", Arg);
21567 -- Case of not in list of context items
21571 while Present (Arg) loop
21572 Check_No_Identifier (Arg);
21574 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21575 -- will in fact generate reference, so that the entity will
21576 -- have a reference, which will inhibit any warnings about
21577 -- it not being referenced, and also properly show up in the
21578 -- ali file as a reference. But this reference is recorded
21579 -- before the Has_Pragma_Unreferenced flag is set, so that
21580 -- no warning is generated for this reference.
21582 Check_Arg_Is_Local_Name (Arg);
21583 Arg_Expr := Get_Pragma_Arg (Arg);
21585 if Is_Entity_Name (Arg_Expr) then
21586 Arg_Id := Entity (Arg_Expr);
21588 -- If the entity is overloaded, the pragma applies to the
21589 -- most recent overloading, as documented. In this case,
21590 -- name resolution does not generate a reference, so it
21591 -- must be done here explicitly.
21593 if Is_Overloaded (Arg_Expr) then
21594 Generate_Reference (Arg_Id, N);
21597 Set_Has_Pragma_Unreferenced (Arg_Id);
21599 -- A pragma that applies to a Ghost entity becomes Ghost
21600 -- for the purposes of legality checks and removal of
21601 -- ignored Ghost code.
21603 Mark_Pragma_As_Ghost (N, Arg_Id);
21605 -- Capture the entity of the first Ghost name being
21606 -- processed for error detection purposes.
21608 if Is_Ghost_Entity (Arg_Id) then
21609 if No (Ghost_Id) then
21610 Ghost_Id := Arg_Id;
21613 -- Otherwise the name is non-Ghost. It is illegal to mix
21614 -- references to Ghost and non-Ghost entities
21617 elsif Present (Ghost_Id)
21618 and then not Ghost_Error_Posted
21620 Ghost_Error_Posted := True;
21622 Error_Msg_Name_1 := Pname;
21624 ("pragma % cannot mention ghost and non-ghost names",
21627 Error_Msg_Sloc := Sloc (Ghost_Id);
21628 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
21630 Error_Msg_Sloc := Sloc (Arg_Id);
21631 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
21640 --------------------------
21641 -- Unreferenced_Objects --
21642 --------------------------
21644 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21646 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
21648 Arg_Expr : Node_Id;
21649 Arg_Id : Entity_Id;
21651 Ghost_Error_Posted : Boolean := False;
21652 -- Flag set when an error concerning the illegal mix of Ghost and
21653 -- non-Ghost types is emitted.
21655 Ghost_Id : Entity_Id := Empty;
21656 -- The entity of the first Ghost type encountered while processing
21657 -- the arguments of the pragma.
21661 Check_At_Least_N_Arguments (1);
21664 while Present (Arg) loop
21665 Check_No_Identifier (Arg);
21666 Check_Arg_Is_Local_Name (Arg);
21667 Arg_Expr := Get_Pragma_Arg (Arg);
21669 if Is_Entity_Name (Arg_Expr) then
21670 Arg_Id := Entity (Arg_Expr);
21672 if Is_Type (Arg_Id) then
21673 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
21675 -- A pragma that applies to a Ghost entity becomes Ghost
21676 -- for the purposes of legality checks and removal of
21677 -- ignored Ghost code.
21679 Mark_Pragma_As_Ghost (N, Arg_Id);
21681 -- Capture the entity of the first Ghost type being
21682 -- processed for error detection purposes.
21684 if Is_Ghost_Entity (Arg_Id) then
21685 if No (Ghost_Id) then
21686 Ghost_Id := Arg_Id;
21689 -- Otherwise the type is non-Ghost. It is illegal to mix
21690 -- references to Ghost and non-Ghost entities
21693 elsif Present (Ghost_Id)
21694 and then not Ghost_Error_Posted
21696 Ghost_Error_Posted := True;
21698 Error_Msg_Name_1 := Pname;
21700 ("pragma % cannot mention ghost and non-ghost types",
21703 Error_Msg_Sloc := Sloc (Ghost_Id);
21704 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
21706 Error_Msg_Sloc := Sloc (Arg_Id);
21707 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
21711 ("argument for pragma% must be type or subtype", Arg);
21715 ("argument for pragma% must be type or subtype", Arg);
21720 end Unreferenced_Objects;
21722 ------------------------------
21723 -- Unreserve_All_Interrupts --
21724 ------------------------------
21726 -- pragma Unreserve_All_Interrupts;
21728 when Pragma_Unreserve_All_Interrupts =>
21730 Check_Arg_Count (0);
21732 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
21733 Unreserve_All_Interrupts := True;
21740 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21742 when Pragma_Unsuppress =>
21744 Process_Suppress_Unsuppress (Suppress_Case => False);
21746 ----------------------------
21747 -- Unevaluated_Use_Of_Old --
21748 ----------------------------
21750 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21752 when Pragma_Unevaluated_Use_Of_Old =>
21754 Check_Arg_Count (1);
21755 Check_No_Identifiers;
21756 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
21758 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21759 -- a declarative part or a package spec.
21761 if not Is_Configuration_Pragma then
21762 Check_Is_In_Decl_Part_Or_Package_Spec;
21765 -- Store proper setting of Uneval_Old
21767 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21768 Uneval_Old := Fold_Upper (Name_Buffer (1));
21770 -------------------
21771 -- Use_VADS_Size --
21772 -------------------
21774 -- pragma Use_VADS_Size;
21776 when Pragma_Use_VADS_Size =>
21778 Check_Arg_Count (0);
21779 Check_Valid_Configuration_Pragma;
21780 Use_VADS_Size := True;
21782 ---------------------
21783 -- Validity_Checks --
21784 ---------------------
21786 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21788 when Pragma_Validity_Checks => Validity_Checks : declare
21789 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21795 Check_Arg_Count (1);
21796 Check_No_Identifiers;
21798 -- Pragma always active unless in CodePeer or GNATprove modes,
21799 -- which use a fixed configuration of validity checks.
21801 if not (CodePeer_Mode or GNATprove_Mode) then
21802 if Nkind (A) = N_String_Literal then
21806 Slen : constant Natural := Natural (String_Length (S));
21807 Options : String (1 .. Slen);
21811 -- Couldn't we use a for loop here over Options'Range???
21815 C := Get_String_Char (S, Int (J));
21817 -- This is a weird test, it skips setting validity
21818 -- checks entirely if any element of S is out of
21819 -- range of Character, what is that about ???
21821 exit when not In_Character_Range (C);
21822 Options (J) := Get_Character (C);
21825 Set_Validity_Check_Options (Options);
21833 elsif Nkind (A) = N_Identifier then
21834 if Chars (A) = Name_All_Checks then
21835 Set_Validity_Check_Options ("a");
21836 elsif Chars (A) = Name_On then
21837 Validity_Checks_On := True;
21838 elsif Chars (A) = Name_Off then
21839 Validity_Checks_On := False;
21843 end Validity_Checks;
21849 -- pragma Volatile (LOCAL_NAME);
21851 when Pragma_Volatile =>
21852 Process_Atomic_Independent_Shared_Volatile;
21854 --------------------------
21855 -- Volatile_Full_Access --
21856 --------------------------
21858 -- pragma Volatile_Full_Access (LOCAL_NAME);
21860 when Pragma_Volatile_Full_Access =>
21862 Process_Atomic_Independent_Shared_Volatile;
21864 -------------------------
21865 -- Volatile_Components --
21866 -------------------------
21868 -- pragma Volatile_Components (array_LOCAL_NAME);
21870 -- Volatile is handled by the same circuit as Atomic_Components
21872 ----------------------
21873 -- Warning_As_Error --
21874 ----------------------
21876 -- pragma Warning_As_Error (static_string_EXPRESSION);
21878 when Pragma_Warning_As_Error =>
21880 Check_Arg_Count (1);
21881 Check_No_Identifiers;
21882 Check_Valid_Configuration_Pragma;
21884 if not Is_Static_String_Expression (Arg1) then
21886 ("argument of pragma% must be static string expression",
21889 -- OK static string expression
21892 Acquire_Warning_Match_String (Arg1);
21893 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
21894 Warnings_As_Errors (Warnings_As_Errors_Count) :=
21895 new String'(Name_Buffer (1 .. Name_Len));
21902 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
21904 -- DETAILS ::= On | Off
21905 -- DETAILS ::= On | Off, local_NAME
21906 -- DETAILS ::= static_string_EXPRESSION
21907 -- DETAILS ::= On | Off, static_string_EXPRESSION
21909 -- TOOL_NAME ::= GNAT | GNATProve
21911 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21913 -- Note: If the first argument matches an allowed tool name, it is
21914 -- always considered to be a tool name, even if there is a string
21915 -- variable of that name.
21917 -- Note if the second argument of DETAILS is a local_NAME then the
21918 -- second form is always understood. If the intention is to use
21919 -- the fourth form, then you can write NAME & "" to force the
21920 -- intepretation as a static_string_EXPRESSION.
21922 when Pragma_Warnings => Warnings : declare
21923 Reason : String_Id;
21927 Check_At_Least_N_Arguments (1);
21929 -- See if last argument is labeled Reason. If so, make sure we
21930 -- have a string literal or a concatenation of string literals,
21931 -- and acquire the REASON string. Then remove the REASON argument
21932 -- by decreasing Num_Args by one; Remaining processing looks only
21933 -- at first Num_Args arguments).
21936 Last_Arg : constant Node_Id :=
21937 Last (Pragma_Argument_Associations (N));
21940 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21941 and then Chars (Last_Arg) = Name_Reason
21944 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21945 Reason := End_String;
21946 Arg_Count := Arg_Count - 1;
21948 -- Not allowed in compiler units (bootstrap issues)
21950 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21952 -- No REASON string, set null string as reason
21955 Reason := Null_String_Id;
21959 -- Now proceed with REASON taken care of and eliminated
21961 Check_No_Identifiers;
21963 -- If debug flag -gnatd.i is set, pragma is ignored
21965 if Debug_Flag_Dot_I then
21969 -- Process various forms of the pragma
21972 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21973 Shifted_Args : List_Id;
21976 -- See if first argument is a tool name, currently either
21977 -- GNAT or GNATprove. If so, either ignore the pragma if the
21978 -- tool used does not match, or continue as if no tool name
21979 -- was given otherwise, by shifting the arguments.
21981 if Nkind (Argx) = N_Identifier
21982 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21984 if Chars (Argx) = Name_Gnat then
21985 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21986 Rewrite (N, Make_Null_Statement (Loc));
21991 elsif Chars (Argx) = Name_Gnatprove then
21992 if not GNATprove_Mode then
21993 Rewrite (N, Make_Null_Statement (Loc));
21999 raise Program_Error;
22002 -- At this point, the pragma Warnings applies to the tool,
22003 -- so continue with shifted arguments.
22005 Arg_Count := Arg_Count - 1;
22007 if Arg_Count = 1 then
22008 Shifted_Args := New_List (New_Copy (Arg2));
22009 elsif Arg_Count = 2 then
22010 Shifted_Args := New_List (New_Copy (Arg2),
22012 elsif Arg_Count = 3 then
22013 Shifted_Args := New_List (New_Copy (Arg2),
22017 raise Program_Error;
22022 Chars => Name_Warnings,
22023 Pragma_Argument_Associations => Shifted_Args));
22028 -- One argument case
22030 if Arg_Count = 1 then
22032 -- On/Off one argument case was processed by parser
22034 if Nkind (Argx) = N_Identifier
22035 and then Nam_In (Chars (Argx), Name_On, Name_Off)
22039 -- One argument case must be ON/OFF or static string expr
22041 elsif not Is_Static_String_Expression (Arg1) then
22043 ("argument of pragma% must be On/Off or static string "
22044 & "expression", Arg1);
22046 -- One argument string expression case
22050 Lit : constant Node_Id := Expr_Value_S (Argx);
22051 Str : constant String_Id := Strval (Lit);
22052 Len : constant Nat := String_Length (Str);
22060 while J <= Len loop
22061 C := Get_String_Char (Str, J);
22062 OK := In_Character_Range (C);
22065 Chr := Get_Character (C);
22067 -- Dash case: only -Wxxx is accepted
22074 C := Get_String_Char (Str, J);
22075 Chr := Get_Character (C);
22076 exit when Chr = 'W';
22081 elsif J < Len and then Chr = '.' then
22083 C := Get_String_Char (Str, J);
22084 Chr := Get_Character (C);
22086 if not Set_Dot_Warning_Switch (Chr) then
22088 ("invalid warning switch character "
22089 & '.' & Chr, Arg1);
22095 OK := Set_Warning_Switch (Chr);
22101 ("invalid warning switch character " & Chr,
22110 -- Two or more arguments (must be two)
22113 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22114 Check_Arg_Count (2);
22122 E_Id := Get_Pragma_Arg (Arg2);
22125 -- In the expansion of an inlined body, a reference to
22126 -- the formal may be wrapped in a conversion if the
22127 -- actual is a conversion. Retrieve the real entity name.
22129 if (In_Instance_Body or In_Inlined_Body)
22130 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
22132 E_Id := Expression (E_Id);
22135 -- Entity name case
22137 if Is_Entity_Name (E_Id) then
22138 E := Entity (E_Id);
22145 (E, (Chars (Get_Pragma_Arg (Arg1)) =
22148 -- For OFF case, make entry in warnings off
22149 -- pragma table for later processing. But we do
22150 -- not do that within an instance, since these
22151 -- warnings are about what is needed in the
22152 -- template, not an instance of it.
22154 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
22155 and then Warn_On_Warnings_Off
22156 and then not In_Instance
22158 Warnings_Off_Pragmas.Append ((N, E, Reason));
22161 if Is_Enumeration_Type (E) then
22165 Lit := First_Literal (E);
22166 while Present (Lit) loop
22167 Set_Warnings_Off (Lit);
22168 Next_Literal (Lit);
22173 exit when No (Homonym (E));
22178 -- Error if not entity or static string expression case
22180 elsif not Is_Static_String_Expression (Arg2) then
22182 ("second argument of pragma% must be entity name "
22183 & "or static string expression", Arg2);
22185 -- Static string expression case
22188 Acquire_Warning_Match_String (Arg2);
22190 -- Note on configuration pragma case: If this is a
22191 -- configuration pragma, then for an OFF pragma, we
22192 -- just set Config True in the call, which is all
22193 -- that needs to be done. For the case of ON, this
22194 -- is normally an error, unless it is canceling the
22195 -- effect of a previous OFF pragma in the same file.
22196 -- In any other case, an error will be signalled (ON
22197 -- with no matching OFF).
22199 -- Note: We set Used if we are inside a generic to
22200 -- disable the test that the non-config case actually
22201 -- cancels a warning. That's because we can't be sure
22202 -- there isn't an instantiation in some other unit
22203 -- where a warning is suppressed.
22205 -- We could do a little better here by checking if the
22206 -- generic unit we are inside is public, but for now
22207 -- we don't bother with that refinement.
22209 if Chars (Argx) = Name_Off then
22210 Set_Specific_Warning_Off
22211 (Loc, Name_Buffer (1 .. Name_Len), Reason,
22212 Config => Is_Configuration_Pragma,
22213 Used => Inside_A_Generic or else In_Instance);
22215 elsif Chars (Argx) = Name_On then
22216 Set_Specific_Warning_On
22217 (Loc, Name_Buffer (1 .. Name_Len), Err);
22221 ("??pragma Warnings On with no matching "
22222 & "Warnings Off", Loc);
22231 -------------------
22232 -- Weak_External --
22233 -------------------
22235 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
22237 when Pragma_Weak_External => Weak_External : declare
22242 Check_Arg_Count (1);
22243 Check_Optional_Identifier (Arg1, Name_Entity);
22244 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22245 Ent := Entity (Get_Pragma_Arg (Arg1));
22247 if Rep_Item_Too_Early (Ent, N) then
22250 Ent := Underlying_Type (Ent);
22253 -- The only processing required is to link this item on to the
22254 -- list of rep items for the given entity. This is accomplished
22255 -- by the call to Rep_Item_Too_Late (when no error is detected
22256 -- and False is returned).
22258 if Rep_Item_Too_Late (Ent, N) then
22261 Set_Has_Gigi_Rep_Item (Ent);
22265 -----------------------------
22266 -- Wide_Character_Encoding --
22267 -----------------------------
22269 -- pragma Wide_Character_Encoding (IDENTIFIER);
22271 when Pragma_Wide_Character_Encoding =>
22274 -- Nothing to do, handled in parser. Note that we do not enforce
22275 -- configuration pragma placement, this pragma can appear at any
22276 -- place in the source, allowing mixed encodings within a single
22281 --------------------
22282 -- Unknown_Pragma --
22283 --------------------
22285 -- Should be impossible, since the case of an unknown pragma is
22286 -- separately processed before the case statement is entered.
22288 when Unknown_Pragma =>
22289 raise Program_Error;
22292 -- AI05-0144: detect dangerous order dependence. Disabled for now,
22293 -- until AI is formally approved.
22295 -- Check_Order_Dependence;
22298 when Pragma_Exit => null;
22299 end Analyze_Pragma;
22301 ---------------------------------------------
22302 -- Analyze_Pre_Post_Condition_In_Decl_Part --
22303 ---------------------------------------------
22305 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
22306 procedure Process_Class_Wide_Condition
22308 Spec_Id : Entity_Id;
22309 Subp_Decl : Node_Id);
22310 -- Replace the type of all references to the controlling formal of
22311 -- subprogram Spec_Id found in expression Expr with the corresponding
22312 -- class-wide type. Subp_Decl is the subprogram [body] declaration
22313 -- where the pragma resides.
22315 ----------------------------------
22316 -- Process_Class_Wide_Condition --
22317 ----------------------------------
22319 procedure Process_Class_Wide_Condition
22321 Spec_Id : Entity_Id;
22322 Subp_Decl : Node_Id)
22324 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
22326 ACW : Entity_Id := Empty;
22327 -- Access to Disp_Typ'Class, created if there is a controlling formal
22328 -- that is an access parameter.
22330 function Access_Class_Wide_Type return Entity_Id;
22331 -- If expression Expr contains a reference to a controlling access
22332 -- parameter, create an access to Disp_Typ'Class for the necessary
22333 -- conversions if one does not exist.
22335 function Replace_Type (N : Node_Id) return Traverse_Result;
22336 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
22337 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
22338 -- name that denotes a formal parameter of type Disp_Typ is treated
22339 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
22340 -- formal access parameter of type access-to-Disp_Typ is interpreted
22341 -- as with type access-to-Disp_Typ'Class. This ensures the expression
22342 -- is well defined for a primitive subprogram of a type descended
22345 ----------------------------
22346 -- Access_Class_Wide_Type --
22347 ----------------------------
22349 function Access_Class_Wide_Type return Entity_Id is
22350 Loc : constant Source_Ptr := Sloc (N);
22354 ACW := Make_Temporary (Loc, 'T');
22356 Insert_Before_And_Analyze (Subp_Decl,
22357 Make_Full_Type_Declaration (Loc,
22358 Defining_Identifier => ACW,
22360 Make_Access_To_Object_Definition (Loc,
22361 Subtype_Indication =>
22362 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
22363 All_Present => True)));
22365 Freeze_Before (Subp_Decl, ACW);
22369 end Access_Class_Wide_Type;
22375 function Replace_Type (N : Node_Id) return Traverse_Result is
22376 Context : constant Node_Id := Parent (N);
22377 Loc : constant Source_Ptr := Sloc (N);
22378 CW_Typ : Entity_Id := Empty;
22383 if Is_Entity_Name (N)
22384 and then Present (Entity (N))
22385 and then Is_Formal (Entity (N))
22388 Typ := Etype (Ent);
22390 -- Do not perform the type replacement for selector names in
22391 -- parameter associations. These carry an entity for reference
22392 -- purposes, but semantically they are just identifiers.
22394 if Nkind (Context) = N_Type_Conversion then
22397 elsif Nkind (Context) = N_Parameter_Association
22398 and then Selector_Name (Context) = N
22402 elsif Typ = Disp_Typ then
22403 CW_Typ := Class_Wide_Type (Typ);
22405 elsif Is_Access_Type (Typ)
22406 and then Designated_Type (Typ) = Disp_Typ
22408 CW_Typ := Access_Class_Wide_Type;
22411 if Present (CW_Typ) then
22413 Make_Type_Conversion (Loc,
22414 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
22415 Expression => New_Occurrence_Of (Ent, Loc)));
22416 Set_Etype (N, CW_Typ);
22423 procedure Replace_Types is new Traverse_Proc (Replace_Type);
22425 -- Start of processing for Process_Class_Wide_Condition
22428 -- The subprogram subject to Pre'Class/Post'Class does not have a
22429 -- dispatching type, therefore the aspect/pragma is illegal.
22431 if No (Disp_Typ) then
22432 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
22434 if From_Aspect_Specification (N) then
22436 ("aspect % can only be specified for a primitive operation "
22437 & "of a tagged type", Corresponding_Aspect (N));
22439 -- The pragma is a source construct
22443 ("pragma % can only be specified for a primitive operation "
22444 & "of a tagged type", N);
22448 Replace_Types (Expr);
22449 end Process_Class_Wide_Condition;
22453 GM : constant Ghost_Mode_Type := Ghost_Mode;
22454 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
22455 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
22456 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
22458 Restore_Scope : Boolean := False;
22460 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
22463 -- Set the Ghost mode in effect from the pragma. Due to the delayed
22464 -- analysis of the pragma, the Ghost mode at point of declaration and
22465 -- point of analysis may not necessarely be the same. Use the mode in
22466 -- effect at the point of declaration.
22468 Set_Ghost_Mode (N);
22470 -- Ensure that the subprogram and its formals are visible when analyzing
22471 -- the expression of the pragma.
22473 if not In_Open_Scopes (Spec_Id) then
22474 Restore_Scope := True;
22475 Push_Scope (Spec_Id);
22477 if Is_Generic_Subprogram (Spec_Id) then
22478 Install_Generic_Formals (Spec_Id);
22480 Install_Formals (Spec_Id);
22484 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
22486 -- For a class-wide condition, a reference to a controlling formal must
22487 -- be interpreted as having the class-wide type (or an access to such)
22488 -- so that the inherited condition can be properly applied to any
22489 -- overriding operation (see ARM12 6.6.1 (7)).
22491 if Class_Present (N) then
22492 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
22495 if Restore_Scope then
22499 -- Currently it is not possible to inline pre/postconditions on a
22500 -- subprogram subject to pragma Inline_Always.
22502 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22504 -- Restore the original Ghost mode once analysis and expansion have
22508 end Analyze_Pre_Post_Condition_In_Decl_Part;
22510 ------------------------------------------
22511 -- Analyze_Refined_Depends_In_Decl_Part --
22512 ------------------------------------------
22514 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
22515 Body_Inputs : Elist_Id := No_Elist;
22516 Body_Outputs : Elist_Id := No_Elist;
22517 -- The inputs and outputs of the subprogram body synthesized from pragma
22518 -- Refined_Depends.
22520 Dependencies : List_Id := No_List;
22522 -- The corresponding Depends pragma along with its clauses
22524 Matched_Items : Elist_Id := No_Elist;
22525 -- A list containing the entities of all successfully matched items
22526 -- found in pragma Depends.
22528 Refinements : List_Id := No_List;
22529 -- The clauses of pragma Refined_Depends
22531 Spec_Id : Entity_Id;
22532 -- The entity of the subprogram subject to pragma Refined_Depends
22534 Spec_Inputs : Elist_Id := No_Elist;
22535 Spec_Outputs : Elist_Id := No_Elist;
22536 -- The inputs and outputs of the subprogram spec synthesized from pragma
22539 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
22540 -- Try to match a single dependency clause Dep_Clause against one or
22541 -- more refinement clauses found in list Refinements. Each successful
22542 -- match eliminates at least one refinement clause from Refinements.
22544 procedure Check_Output_States;
22545 -- Determine whether pragma Depends contains an output state with a
22546 -- visible refinement and if so, ensure that pragma Refined_Depends
22547 -- mentions all its constituents as outputs.
22549 procedure Normalize_Clauses (Clauses : List_Id);
22550 -- Given a list of dependence or refinement clauses Clauses, normalize
22551 -- each clause by creating multiple dependencies with exactly one input
22554 procedure Report_Extra_Clauses;
22555 -- Emit an error for each extra clause found in list Refinements
22557 -----------------------------
22558 -- Check_Dependency_Clause --
22559 -----------------------------
22561 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
22562 Dep_Input : constant Node_Id := Expression (Dep_Clause);
22563 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
22565 function Is_In_Out_State_Clause return Boolean;
22566 -- Determine whether dependence clause Dep_Clause denotes an abstract
22567 -- state that depends on itself (State => State).
22569 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
22570 -- Determine whether item Item denotes an abstract state with visible
22571 -- null refinement.
22573 procedure Match_Items
22574 (Dep_Item : Node_Id;
22575 Ref_Item : Node_Id;
22576 Matched : out Boolean);
22577 -- Try to match dependence item Dep_Item against refinement item
22578 -- Ref_Item. To match against a possible null refinement (see 2, 7),
22579 -- set Ref_Item to Empty. Flag Matched is set to True when one of
22580 -- the following conformance scenarios is in effect:
22581 -- 1) Both items denote null
22582 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
22583 -- 3) Both items denote attribute 'Result
22584 -- 4) Both items denote the same formal parameter
22585 -- 5) Both items denote the same object
22586 -- 6) Dep_Item is an abstract state with visible null refinement
22587 -- and Ref_Item denotes null.
22588 -- 7) Dep_Item is an abstract state with visible null refinement
22589 -- and Ref_Item is Empty (special case).
22590 -- 8) Dep_Item is an abstract state with visible non-null
22591 -- refinement and Ref_Item denotes one of its constituents.
22592 -- 9) Dep_Item is an abstract state without a visible refinement
22593 -- and Ref_Item denotes the same state.
22594 -- When scenario 8 is in effect, the entity of the abstract state
22595 -- denoted by Dep_Item is added to list Refined_States.
22597 procedure Record_Item (Item_Id : Entity_Id);
22598 -- Store the entity of an item denoted by Item_Id in Matched_Items
22600 ----------------------------
22601 -- Is_In_Out_State_Clause --
22602 ----------------------------
22604 function Is_In_Out_State_Clause return Boolean is
22605 Dep_Input_Id : Entity_Id;
22606 Dep_Output_Id : Entity_Id;
22609 -- Detect the following clause:
22612 if Is_Entity_Name (Dep_Input)
22613 and then Is_Entity_Name (Dep_Output)
22615 -- Handle abstract views generated for limited with clauses
22617 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
22618 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
22621 Ekind (Dep_Input_Id) = E_Abstract_State
22622 and then Dep_Input_Id = Dep_Output_Id;
22626 end Is_In_Out_State_Clause;
22628 ---------------------------
22629 -- Is_Null_Refined_State --
22630 ---------------------------
22632 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
22633 Item_Id : Entity_Id;
22636 if Is_Entity_Name (Item) then
22638 -- Handle abstract views generated for limited with clauses
22640 Item_Id := Available_View (Entity_Of (Item));
22642 return Ekind (Item_Id) = E_Abstract_State
22643 and then Has_Null_Refinement (Item_Id);
22648 end Is_Null_Refined_State;
22654 procedure Match_Items
22655 (Dep_Item : Node_Id;
22656 Ref_Item : Node_Id;
22657 Matched : out Boolean)
22659 Dep_Item_Id : Entity_Id;
22660 Ref_Item_Id : Entity_Id;
22663 -- Assume that the two items do not match
22667 -- A null matches null or Empty (special case)
22669 if Nkind (Dep_Item) = N_Null
22670 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
22674 -- Attribute 'Result matches attribute 'Result
22676 elsif Is_Attribute_Result (Dep_Item)
22677 and then Is_Attribute_Result (Dep_Item)
22681 -- Abstract states, formal parameters and objects
22683 elsif Is_Entity_Name (Dep_Item) then
22685 -- Handle abstract views generated for limited with clauses
22687 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
22689 if Ekind (Dep_Item_Id) = E_Abstract_State then
22691 -- An abstract state with visible null refinement matches
22692 -- null or Empty (special case).
22694 if Has_Null_Refinement (Dep_Item_Id)
22695 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
22697 Record_Item (Dep_Item_Id);
22700 -- An abstract state with visible non-null refinement
22701 -- matches one of its constituents.
22703 elsif Has_Non_Null_Refinement (Dep_Item_Id) then
22704 if Is_Entity_Name (Ref_Item) then
22705 Ref_Item_Id := Entity_Of (Ref_Item);
22707 if Ekind_In (Ref_Item_Id, E_Abstract_State,
22710 and then Present (Encapsulating_State (Ref_Item_Id))
22711 and then Encapsulating_State (Ref_Item_Id) =
22714 Record_Item (Dep_Item_Id);
22719 -- An abstract state without a visible refinement matches
22722 elsif Is_Entity_Name (Ref_Item)
22723 and then Entity_Of (Ref_Item) = Dep_Item_Id
22725 Record_Item (Dep_Item_Id);
22729 -- A formal parameter or an object matches itself
22731 elsif Is_Entity_Name (Ref_Item)
22732 and then Entity_Of (Ref_Item) = Dep_Item_Id
22734 Record_Item (Dep_Item_Id);
22744 procedure Record_Item (Item_Id : Entity_Id) is
22746 if not Contains (Matched_Items, Item_Id) then
22747 Add_Item (Item_Id, Matched_Items);
22753 Clause_Matched : Boolean := False;
22754 Dummy : Boolean := False;
22755 Inputs_Match : Boolean;
22756 Next_Ref_Clause : Node_Id;
22757 Outputs_Match : Boolean;
22758 Ref_Clause : Node_Id;
22759 Ref_Input : Node_Id;
22760 Ref_Output : Node_Id;
22762 -- Start of processing for Check_Dependency_Clause
22765 -- Do not perform this check in an instance because it was already
22766 -- performed successfully in the generic template.
22768 if Is_Generic_Instance (Spec_Id) then
22772 -- Examine all refinement clauses and compare them against the
22773 -- dependence clause.
22775 Ref_Clause := First (Refinements);
22776 while Present (Ref_Clause) loop
22777 Next_Ref_Clause := Next (Ref_Clause);
22779 -- Obtain the attributes of the current refinement clause
22781 Ref_Input := Expression (Ref_Clause);
22782 Ref_Output := First (Choices (Ref_Clause));
22784 -- The current refinement clause matches the dependence clause
22785 -- when both outputs match and both inputs match. See routine
22786 -- Match_Items for all possible conformance scenarios.
22788 -- Depends Dep_Output => Dep_Input
22792 -- Refined_Depends Ref_Output => Ref_Input
22795 (Dep_Item => Dep_Input,
22796 Ref_Item => Ref_Input,
22797 Matched => Inputs_Match);
22800 (Dep_Item => Dep_Output,
22801 Ref_Item => Ref_Output,
22802 Matched => Outputs_Match);
22804 -- An In_Out state clause may be matched against a refinement with
22805 -- a null input or null output as long as the non-null side of the
22806 -- relation contains a valid constituent of the In_Out_State.
22808 if Is_In_Out_State_Clause then
22810 -- Depends => (State => State)
22811 -- Refined_Depends => (null => Constit) -- OK
22814 and then not Outputs_Match
22815 and then Nkind (Ref_Output) = N_Null
22817 Outputs_Match := True;
22820 -- Depends => (State => State)
22821 -- Refined_Depends => (Constit => null) -- OK
22823 if not Inputs_Match
22824 and then Outputs_Match
22825 and then Nkind (Ref_Input) = N_Null
22827 Inputs_Match := True;
22831 -- The current refinement clause is legally constructed following
22832 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22833 -- the pool of candidates. The seach continues because a single
22834 -- dependence clause may have multiple matching refinements.
22836 if Inputs_Match and then Outputs_Match then
22837 Clause_Matched := True;
22838 Remove (Ref_Clause);
22841 Ref_Clause := Next_Ref_Clause;
22844 -- Depending on the order or composition of refinement clauses, an
22845 -- In_Out state clause may not be directly refinable.
22847 -- Depends => ((Output, State) => (Input, State))
22848 -- Refined_State => (State => (Constit_1, Constit_2))
22849 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22851 -- Matching normalized clause (State => State) fails because there is
22852 -- no direct refinement capable of satisfying this relation. Another
22853 -- similar case arises when clauses (Constit_1 => Input) and (Output
22854 -- => Constit_2) are matched first, leaving no candidates for clause
22855 -- (State => State). Both scenarios are legal as long as one of the
22856 -- previous clauses mentioned a valid constituent of State.
22858 if not Clause_Matched
22859 and then Is_In_Out_State_Clause
22861 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
22863 Clause_Matched := True;
22866 -- A clause where the input is an abstract state with visible null
22867 -- refinement is implicitly matched when the output has already been
22868 -- matched in a previous clause.
22870 -- Depends => (Output => State) -- implicitly OK
22871 -- Refined_State => (State => null)
22872 -- Refined_Depends => (Output => ...)
22874 if not Clause_Matched
22875 and then Is_Null_Refined_State (Dep_Input)
22876 and then Is_Entity_Name (Dep_Output)
22878 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
22880 Clause_Matched := True;
22883 -- A clause where the output is an abstract state with visible null
22884 -- refinement is implicitly matched when the input has already been
22885 -- matched in a previous clause.
22887 -- Depends => (State => Input) -- implicitly OK
22888 -- Refined_State => (State => null)
22889 -- Refined_Depends => (... => Input)
22891 if not Clause_Matched
22892 and then Is_Null_Refined_State (Dep_Output)
22893 and then Is_Entity_Name (Dep_Input)
22895 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
22897 Clause_Matched := True;
22900 -- At this point either all refinement clauses have been examined or
22901 -- pragma Refined_Depends contains a solitary null. Only an abstract
22902 -- state with null refinement can possibly match these cases.
22904 -- Depends => (State => null)
22905 -- Refined_State => (State => null)
22906 -- Refined_Depends => null -- OK
22908 if not Clause_Matched then
22910 (Dep_Item => Dep_Input,
22912 Matched => Inputs_Match);
22915 (Dep_Item => Dep_Output,
22917 Matched => Outputs_Match);
22919 Clause_Matched := Inputs_Match and Outputs_Match;
22922 -- If the contents of Refined_Depends are legal, then the current
22923 -- dependence clause should be satisfied either by an explicit match
22924 -- or by one of the special cases.
22926 if not Clause_Matched then
22928 ("dependence clause of subprogram & has no matching refinement "
22929 & "in body", Dep_Clause, Spec_Id);
22931 end Check_Dependency_Clause;
22933 -------------------------
22934 -- Check_Output_States --
22935 -------------------------
22937 procedure Check_Output_States is
22938 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22939 -- Determine whether all constituents of state State_Id with visible
22940 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22941 -- error if this is not the case.
22943 -----------------------------
22944 -- Check_Constituent_Usage --
22945 -----------------------------
22947 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22948 Constit_Elmt : Elmt_Id;
22949 Constit_Id : Entity_Id;
22950 Posted : Boolean := False;
22953 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22954 while Present (Constit_Elmt) loop
22955 Constit_Id := Node (Constit_Elmt);
22957 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22959 if Present (Body_Inputs)
22960 and then Appears_In (Body_Inputs, Constit_Id)
22962 Error_Msg_Name_1 := Chars (State_Id);
22964 ("constituent & of state % must act as output in "
22965 & "dependence refinement", N, Constit_Id);
22967 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22969 elsif No (Body_Outputs)
22970 or else not Appears_In (Body_Outputs, Constit_Id)
22975 ("output state & must be replaced by all its "
22976 & "constituents in dependence refinement",
22981 ("\constituent & is missing in output list",
22985 Next_Elmt (Constit_Elmt);
22987 end Check_Constituent_Usage;
22992 Item_Elmt : Elmt_Id;
22993 Item_Id : Entity_Id;
22995 -- Start of processing for Check_Output_States
22998 -- Do not perform this check in an instance because it was already
22999 -- performed successfully in the generic template.
23001 if Is_Generic_Instance (Spec_Id) then
23004 -- Inspect the outputs of pragma Depends looking for a state with a
23005 -- visible refinement.
23007 elsif Present (Spec_Outputs) then
23008 Item_Elmt := First_Elmt (Spec_Outputs);
23009 while Present (Item_Elmt) loop
23010 Item := Node (Item_Elmt);
23012 -- Deal with the mixed nature of the input and output lists
23014 if Nkind (Item) = N_Defining_Identifier then
23017 Item_Id := Available_View (Entity_Of (Item));
23020 if Ekind (Item_Id) = E_Abstract_State then
23022 -- The state acts as an input-output, skip it
23024 if Present (Spec_Inputs)
23025 and then Appears_In (Spec_Inputs, Item_Id)
23029 -- Ensure that all of the constituents are utilized as
23030 -- outputs in pragma Refined_Depends.
23032 elsif Has_Non_Null_Refinement (Item_Id) then
23033 Check_Constituent_Usage (Item_Id);
23037 Next_Elmt (Item_Elmt);
23040 end Check_Output_States;
23042 -----------------------
23043 -- Normalize_Clauses --
23044 -----------------------
23046 procedure Normalize_Clauses (Clauses : List_Id) is
23047 procedure Normalize_Inputs (Clause : Node_Id);
23048 -- Normalize clause Clause by creating multiple clauses for each
23049 -- input item of Clause. It is assumed that Clause has exactly one
23050 -- output. The transformation is as follows:
23052 -- Output => (Input_1, Input_2) -- original
23054 -- Output => Input_1 -- normalizations
23055 -- Output => Input_2
23057 procedure Normalize_Outputs (Clause : Node_Id);
23058 -- Normalize clause Clause by creating multiple clause for each
23059 -- output item of Clause. The transformation is as follows:
23061 -- (Output_1, Output_2) => Input -- original
23063 -- Output_1 => Input -- normalization
23064 -- Output_2 => Input
23066 ----------------------
23067 -- Normalize_Inputs --
23068 ----------------------
23070 procedure Normalize_Inputs (Clause : Node_Id) is
23071 Inputs : constant Node_Id := Expression (Clause);
23072 Loc : constant Source_Ptr := Sloc (Clause);
23073 Output : constant List_Id := Choices (Clause);
23074 Last_Input : Node_Id;
23076 New_Clause : Node_Id;
23077 Next_Input : Node_Id;
23080 -- Normalization is performed only when the original clause has
23081 -- more than one input. Multiple inputs appear as an aggregate.
23083 if Nkind (Inputs) = N_Aggregate then
23084 Last_Input := Last (Expressions (Inputs));
23086 -- Create a new clause for each input
23088 Input := First (Expressions (Inputs));
23089 while Present (Input) loop
23090 Next_Input := Next (Input);
23092 -- Unhook the current input from the original input list
23093 -- because it will be relocated to a new clause.
23097 -- Special processing for the last input. At this point the
23098 -- original aggregate has been stripped down to one element.
23099 -- Replace the aggregate by the element itself.
23101 if Input = Last_Input then
23102 Rewrite (Inputs, Input);
23104 -- Generate a clause of the form:
23109 Make_Component_Association (Loc,
23110 Choices => New_Copy_List_Tree (Output),
23111 Expression => Input);
23113 -- The new clause contains replicated content that has
23114 -- already been analyzed, mark the clause as analyzed.
23116 Set_Analyzed (New_Clause);
23117 Insert_After (Clause, New_Clause);
23120 Input := Next_Input;
23123 end Normalize_Inputs;
23125 -----------------------
23126 -- Normalize_Outputs --
23127 -----------------------
23129 procedure Normalize_Outputs (Clause : Node_Id) is
23130 Inputs : constant Node_Id := Expression (Clause);
23131 Loc : constant Source_Ptr := Sloc (Clause);
23132 Outputs : constant Node_Id := First (Choices (Clause));
23133 Last_Output : Node_Id;
23134 New_Clause : Node_Id;
23135 Next_Output : Node_Id;
23139 -- Multiple outputs appear as an aggregate. Nothing to do when
23140 -- the clause has exactly one output.
23142 if Nkind (Outputs) = N_Aggregate then
23143 Last_Output := Last (Expressions (Outputs));
23145 -- Create a clause for each output. Note that each time a new
23146 -- clause is created, the original output list slowly shrinks
23147 -- until there is one item left.
23149 Output := First (Expressions (Outputs));
23150 while Present (Output) loop
23151 Next_Output := Next (Output);
23153 -- Unhook the output from the original output list as it
23154 -- will be relocated to a new clause.
23158 -- Special processing for the last output. At this point
23159 -- the original aggregate has been stripped down to one
23160 -- element. Replace the aggregate by the element itself.
23162 if Output = Last_Output then
23163 Rewrite (Outputs, Output);
23166 -- Generate a clause of the form:
23167 -- (Output => Inputs)
23170 Make_Component_Association (Loc,
23171 Choices => New_List (Output),
23172 Expression => New_Copy_Tree (Inputs));
23174 -- The new clause contains replicated content that has
23175 -- already been analyzed. There is not need to reanalyze
23178 Set_Analyzed (New_Clause);
23179 Insert_After (Clause, New_Clause);
23182 Output := Next_Output;
23185 end Normalize_Outputs;
23191 -- Start of processing for Normalize_Clauses
23194 Clause := First (Clauses);
23195 while Present (Clause) loop
23196 Normalize_Outputs (Clause);
23200 Clause := First (Clauses);
23201 while Present (Clause) loop
23202 Normalize_Inputs (Clause);
23205 end Normalize_Clauses;
23207 --------------------------
23208 -- Report_Extra_Clauses --
23209 --------------------------
23211 procedure Report_Extra_Clauses is
23215 -- Do not perform this check in an instance because it was already
23216 -- performed successfully in the generic template.
23218 if Is_Generic_Instance (Spec_Id) then
23221 elsif Present (Refinements) then
23222 Clause := First (Refinements);
23223 while Present (Clause) loop
23225 -- Do not complain about a null input refinement, since a null
23226 -- input legitimately matches anything.
23228 if Nkind (Clause) = N_Component_Association
23229 and then Nkind (Expression (Clause)) = N_Null
23235 ("unmatched or extra clause in dependence refinement",
23242 end Report_Extra_Clauses;
23246 Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
23247 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
23248 Errors : constant Nat := Serious_Errors_Detected;
23254 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
23257 if Nkind (Body_Decl) = N_Subprogram_Body_Stub then
23258 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
23260 Spec_Id := Corresponding_Spec (Body_Decl);
23263 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
23265 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
23266 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
23268 if No (Depends) then
23270 ("useless refinement, declaration of subprogram & lacks aspect or "
23271 & "pragma Depends", N, Spec_Id);
23275 Deps := Expression (Get_Argument (Depends, Spec_Id));
23277 -- A null dependency relation renders the refinement useless because it
23278 -- cannot possibly mention abstract states with visible refinement. Note
23279 -- that the inverse is not true as states may be refined to null
23280 -- (SPARK RM 7.2.5(2)).
23282 if Nkind (Deps) = N_Null then
23284 ("useless refinement, subprogram & does not depend on abstract "
23285 & "state with visible refinement", N, Spec_Id);
23289 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
23290 -- This ensures that the categorization of all refined dependency items
23291 -- is consistent with their role.
23293 Analyze_Depends_In_Decl_Part (N);
23295 -- Do not match dependencies against refinements if Refined_Depends is
23296 -- illegal to avoid emitting misleading error.
23298 if Serious_Errors_Detected = Errors then
23300 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
23301 -- the inputs and outputs of the subprogram spec and body to verify
23302 -- the use of states with visible refinement and their constituents.
23304 if No (Get_Pragma (Spec_Id, Pragma_Global))
23305 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
23307 Collect_Subprogram_Inputs_Outputs
23308 (Subp_Id => Spec_Id,
23309 Synthesize => True,
23310 Subp_Inputs => Spec_Inputs,
23311 Subp_Outputs => Spec_Outputs,
23312 Global_Seen => Dummy);
23314 Collect_Subprogram_Inputs_Outputs
23315 (Subp_Id => Body_Id,
23316 Synthesize => True,
23317 Subp_Inputs => Body_Inputs,
23318 Subp_Outputs => Body_Outputs,
23319 Global_Seen => Dummy);
23321 -- For an output state with a visible refinement, ensure that all
23322 -- constituents appear as outputs in the dependency refinement.
23324 Check_Output_States;
23327 -- Matching is disabled in ASIS because clauses are not normalized as
23328 -- this is a tree altering activity similar to expansion.
23334 -- Multiple dependency clauses appear as component associations of an
23335 -- aggregate. Note that the clauses are copied because the algorithm
23336 -- modifies them and this should not be visible in Depends.
23338 pragma Assert (Nkind (Deps) = N_Aggregate);
23339 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
23340 Normalize_Clauses (Dependencies);
23342 Refs := Expression (Get_Argument (N, Spec_Id));
23344 if Nkind (Refs) = N_Null then
23345 Refinements := No_List;
23347 -- Multiple dependency clauses appear as component associations of an
23348 -- aggregate. Note that the clauses are copied because the algorithm
23349 -- modifies them and this should not be visible in Refined_Depends.
23351 else pragma Assert (Nkind (Refs) = N_Aggregate);
23352 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
23353 Normalize_Clauses (Refinements);
23356 -- At this point the clauses of pragmas Depends and Refined_Depends
23357 -- have been normalized into simple dependencies between one output
23358 -- and one input. Examine all clauses of pragma Depends looking for
23359 -- matching clauses in pragma Refined_Depends.
23361 Clause := First (Dependencies);
23362 while Present (Clause) loop
23363 Check_Dependency_Clause (Clause);
23367 if Serious_Errors_Detected = Errors then
23368 Report_Extra_Clauses;
23371 end Analyze_Refined_Depends_In_Decl_Part;
23373 -----------------------------------------
23374 -- Analyze_Refined_Global_In_Decl_Part --
23375 -----------------------------------------
23377 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
23379 -- The corresponding Global pragma
23381 Has_In_State : Boolean := False;
23382 Has_In_Out_State : Boolean := False;
23383 Has_Out_State : Boolean := False;
23384 Has_Proof_In_State : Boolean := False;
23385 -- These flags are set when the corresponding Global pragma has a state
23386 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
23389 Has_Null_State : Boolean := False;
23390 -- This flag is set when the corresponding Global pragma has at least
23391 -- one state with a null refinement.
23393 In_Constits : Elist_Id := No_Elist;
23394 In_Out_Constits : Elist_Id := No_Elist;
23395 Out_Constits : Elist_Id := No_Elist;
23396 Proof_In_Constits : Elist_Id := No_Elist;
23397 -- These lists contain the entities of all Input, In_Out, Output and
23398 -- Proof_In constituents that appear in Refined_Global and participate
23399 -- in state refinement.
23401 In_Items : Elist_Id := No_Elist;
23402 In_Out_Items : Elist_Id := No_Elist;
23403 Out_Items : Elist_Id := No_Elist;
23404 Proof_In_Items : Elist_Id := No_Elist;
23405 -- These list contain the entities of all Input, In_Out, Output and
23406 -- Proof_In items defined in the corresponding Global pragma.
23408 Spec_Id : Entity_Id;
23409 -- The entity of the subprogram subject to pragma Refined_Global
23411 procedure Check_In_Out_States;
23412 -- Determine whether the corresponding Global pragma mentions In_Out
23413 -- states with visible refinement and if so, ensure that one of the
23414 -- following completions apply to the constituents of the state:
23415 -- 1) there is at least one constituent of mode In_Out
23416 -- 2) there is at least one Input and one Output constituent
23417 -- 3) not all constituents are present and one of them is of mode
23419 -- This routine may remove elements from In_Constits, In_Out_Constits,
23420 -- Out_Constits and Proof_In_Constits.
23422 procedure Check_Input_States;
23423 -- Determine whether the corresponding Global pragma mentions Input
23424 -- states with visible refinement and if so, ensure that at least one of
23425 -- its constituents appears as an Input item in Refined_Global.
23426 -- This routine may remove elements from In_Constits, In_Out_Constits,
23427 -- Out_Constits and Proof_In_Constits.
23429 procedure Check_Output_States;
23430 -- Determine whether the corresponding Global pragma mentions Output
23431 -- states with visible refinement and if so, ensure that all of its
23432 -- constituents appear as Output items in Refined_Global.
23433 -- This routine may remove elements from In_Constits, In_Out_Constits,
23434 -- Out_Constits and Proof_In_Constits.
23436 procedure Check_Proof_In_States;
23437 -- Determine whether the corresponding Global pragma mentions Proof_In
23438 -- states with visible refinement and if so, ensure that at least one of
23439 -- its constituents appears as a Proof_In item in Refined_Global.
23440 -- This routine may remove elements from In_Constits, In_Out_Constits,
23441 -- Out_Constits and Proof_In_Constits.
23443 procedure Check_Refined_Global_List
23445 Global_Mode : Name_Id := Name_Input);
23446 -- Verify the legality of a single global list declaration. Global_Mode
23447 -- denotes the current mode in effect.
23449 procedure Collect_Global_Items
23451 Mode : Name_Id := Name_Input);
23452 -- Gather all input, in out, output and Proof_In items from node List
23453 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
23454 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
23455 -- and Has_Proof_In_State are set when there is at least one abstract
23456 -- state with visible refinement available in the corresponding mode.
23457 -- Flag Has_Null_State is set when at least state has a null refinement.
23458 -- Mode enotes the current global mode in effect.
23460 function Present_Then_Remove
23462 Item : Entity_Id) return Boolean;
23463 -- Search List for a particular entity Item. If Item has been found,
23464 -- remove it from List. This routine is used to strip lists In_Constits,
23465 -- In_Out_Constits and Out_Constits of valid constituents.
23467 procedure Report_Extra_Constituents;
23468 -- Emit an error for each constituent found in lists In_Constits,
23469 -- In_Out_Constits and Out_Constits.
23471 -------------------------
23472 -- Check_In_Out_States --
23473 -------------------------
23475 procedure Check_In_Out_States is
23476 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23477 -- Determine whether one of the following coverage scenarios is in
23479 -- 1) there is at least one constituent of mode In_Out
23480 -- 2) there is at least one Input and one Output constituent
23481 -- 3) not all constituents are present and one of them is of mode
23483 -- If this is not the case, emit an error.
23485 -----------------------------
23486 -- Check_Constituent_Usage --
23487 -----------------------------
23489 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23490 Constit_Elmt : Elmt_Id;
23491 Constit_Id : Entity_Id;
23492 Has_Missing : Boolean := False;
23493 In_Out_Seen : Boolean := False;
23494 In_Seen : Boolean := False;
23495 Out_Seen : Boolean := False;
23498 -- Process all the constituents of the state and note their modes
23499 -- within the global refinement.
23501 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23502 while Present (Constit_Elmt) loop
23503 Constit_Id := Node (Constit_Elmt);
23505 if Present_Then_Remove (In_Constits, Constit_Id) then
23508 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
23509 In_Out_Seen := True;
23511 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
23514 -- A Proof_In constituent cannot participate in the completion
23515 -- of an Output state (SPARK RM 7.2.4(5)).
23517 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then
23518 Error_Msg_Name_1 := Chars (State_Id);
23520 ("constituent & of state % must have mode Input, In_Out "
23521 & "or Output in global refinement", N, Constit_Id);
23524 Has_Missing := True;
23527 Next_Elmt (Constit_Elmt);
23530 -- A single In_Out constituent is a valid completion
23532 if In_Out_Seen then
23535 -- A pair of one Input and one Output constituent is a valid
23538 elsif In_Seen and then Out_Seen then
23541 -- A single Output constituent is a valid completion only when
23542 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
23544 elsif Has_Missing and then Out_Seen then
23549 ("global refinement of state & redefines the mode of its "
23550 & "constituents", N, State_Id);
23552 end Check_Constituent_Usage;
23556 Item_Elmt : Elmt_Id;
23557 Item_Id : Entity_Id;
23559 -- Start of processing for Check_In_Out_States
23562 -- Do not perform this check in an instance because it was already
23563 -- performed successfully in the generic template.
23565 if Is_Generic_Instance (Spec_Id) then
23568 -- Inspect the In_Out items of the corresponding Global pragma
23569 -- looking for a state with a visible refinement.
23571 elsif Has_In_Out_State and then Present (In_Out_Items) then
23572 Item_Elmt := First_Elmt (In_Out_Items);
23573 while Present (Item_Elmt) loop
23574 Item_Id := Node (Item_Elmt);
23576 -- Ensure that one of the three coverage variants is satisfied
23578 if Ekind (Item_Id) = E_Abstract_State
23579 and then Has_Non_Null_Refinement (Item_Id)
23581 Check_Constituent_Usage (Item_Id);
23584 Next_Elmt (Item_Elmt);
23587 end Check_In_Out_States;
23589 ------------------------
23590 -- Check_Input_States --
23591 ------------------------
23593 procedure Check_Input_States is
23594 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23595 -- Determine whether at least one constituent of state State_Id with
23596 -- visible refinement is used and has mode Input. Ensure that the
23597 -- remaining constituents do not have In_Out, Output or Proof_In
23600 -----------------------------
23601 -- Check_Constituent_Usage --
23602 -----------------------------
23604 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23605 Constit_Elmt : Elmt_Id;
23606 Constit_Id : Entity_Id;
23607 In_Seen : Boolean := False;
23610 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23611 while Present (Constit_Elmt) loop
23612 Constit_Id := Node (Constit_Elmt);
23614 -- At least one of the constituents appears as an Input
23616 if Present_Then_Remove (In_Constits, Constit_Id) then
23619 -- The constituent appears in the global refinement, but has
23620 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
23622 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
23623 or else Present_Then_Remove (Out_Constits, Constit_Id)
23624 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
23626 Error_Msg_Name_1 := Chars (State_Id);
23628 ("constituent & of state % must have mode Input in global "
23629 & "refinement", N, Constit_Id);
23632 Next_Elmt (Constit_Elmt);
23635 -- Not one of the constituents appeared as Input
23637 if not In_Seen then
23639 ("global refinement of state & must include at least one "
23640 & "constituent of mode Input", N, State_Id);
23642 end Check_Constituent_Usage;
23646 Item_Elmt : Elmt_Id;
23647 Item_Id : Entity_Id;
23649 -- Start of processing for Check_Input_States
23652 -- Do not perform this check in an instance because it was already
23653 -- performed successfully in the generic template.
23655 if Is_Generic_Instance (Spec_Id) then
23658 -- Inspect the Input items of the corresponding Global pragma looking
23659 -- for a state with a visible refinement.
23661 elsif Has_In_State and then Present (In_Items) then
23662 Item_Elmt := First_Elmt (In_Items);
23663 while Present (Item_Elmt) loop
23664 Item_Id := Node (Item_Elmt);
23666 -- Ensure that at least one of the constituents is utilized and
23667 -- is of mode Input.
23669 if Ekind (Item_Id) = E_Abstract_State
23670 and then Has_Non_Null_Refinement (Item_Id)
23672 Check_Constituent_Usage (Item_Id);
23675 Next_Elmt (Item_Elmt);
23678 end Check_Input_States;
23680 -------------------------
23681 -- Check_Output_States --
23682 -------------------------
23684 procedure Check_Output_States is
23685 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23686 -- Determine whether all constituents of state State_Id with visible
23687 -- refinement are used and have mode Output. Emit an error if this is
23690 -----------------------------
23691 -- Check_Constituent_Usage --
23692 -----------------------------
23694 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23695 Constit_Elmt : Elmt_Id;
23696 Constit_Id : Entity_Id;
23697 Posted : Boolean := False;
23700 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23701 while Present (Constit_Elmt) loop
23702 Constit_Id := Node (Constit_Elmt);
23704 if Present_Then_Remove (Out_Constits, Constit_Id) then
23707 -- The constituent appears in the global refinement, but has
23708 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23710 elsif Present_Then_Remove (In_Constits, Constit_Id)
23711 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
23712 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
23714 Error_Msg_Name_1 := Chars (State_Id);
23716 ("constituent & of state % must have mode Output in "
23717 & "global refinement", N, Constit_Id);
23719 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23725 ("output state & must be replaced by all its "
23726 & "constituents in global refinement", N, State_Id);
23730 ("\constituent & is missing in output list",
23734 Next_Elmt (Constit_Elmt);
23736 end Check_Constituent_Usage;
23740 Item_Elmt : Elmt_Id;
23741 Item_Id : Entity_Id;
23743 -- Start of processing for Check_Output_States
23746 -- Do not perform this check in an instance because it was already
23747 -- performed successfully in the generic template.
23749 if Is_Generic_Instance (Spec_Id) then
23752 -- Inspect the Output items of the corresponding Global pragma
23753 -- looking for a state with a visible refinement.
23755 elsif Has_Out_State and then Present (Out_Items) then
23756 Item_Elmt := First_Elmt (Out_Items);
23757 while Present (Item_Elmt) loop
23758 Item_Id := Node (Item_Elmt);
23760 -- Ensure that all of the constituents are utilized and they
23761 -- have mode Output.
23763 if Ekind (Item_Id) = E_Abstract_State
23764 and then Has_Non_Null_Refinement (Item_Id)
23766 Check_Constituent_Usage (Item_Id);
23769 Next_Elmt (Item_Elmt);
23772 end Check_Output_States;
23774 ---------------------------
23775 -- Check_Proof_In_States --
23776 ---------------------------
23778 procedure Check_Proof_In_States is
23779 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23780 -- Determine whether at least one constituent of state State_Id with
23781 -- visible refinement is used and has mode Proof_In. Ensure that the
23782 -- remaining constituents do not have Input, In_Out or Output modes.
23784 -----------------------------
23785 -- Check_Constituent_Usage --
23786 -----------------------------
23788 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23789 Constit_Elmt : Elmt_Id;
23790 Constit_Id : Entity_Id;
23791 Proof_In_Seen : Boolean := False;
23794 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
23795 while Present (Constit_Elmt) loop
23796 Constit_Id := Node (Constit_Elmt);
23798 -- At least one of the constituents appears as Proof_In
23800 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
23801 Proof_In_Seen := True;
23803 -- The constituent appears in the global refinement, but has
23804 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23806 elsif Present_Then_Remove (In_Constits, Constit_Id)
23807 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
23808 or else Present_Then_Remove (Out_Constits, Constit_Id)
23810 Error_Msg_Name_1 := Chars (State_Id);
23812 ("constituent & of state % must have mode Proof_In in "
23813 & "global refinement", N, Constit_Id);
23816 Next_Elmt (Constit_Elmt);
23819 -- Not one of the constituents appeared as Proof_In
23821 if not Proof_In_Seen then
23823 ("global refinement of state & must include at least one "
23824 & "constituent of mode Proof_In", N, State_Id);
23826 end Check_Constituent_Usage;
23830 Item_Elmt : Elmt_Id;
23831 Item_Id : Entity_Id;
23833 -- Start of processing for Check_Proof_In_States
23836 -- Do not perform this check in an instance because it was already
23837 -- performed successfully in the generic template.
23839 if Is_Generic_Instance (Spec_Id) then
23842 -- Inspect the Proof_In items of the corresponding Global pragma
23843 -- looking for a state with a visible refinement.
23845 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
23846 Item_Elmt := First_Elmt (Proof_In_Items);
23847 while Present (Item_Elmt) loop
23848 Item_Id := Node (Item_Elmt);
23850 -- Ensure that at least one of the constituents is utilized and
23851 -- is of mode Proof_In
23853 if Ekind (Item_Id) = E_Abstract_State
23854 and then Has_Non_Null_Refinement (Item_Id)
23856 Check_Constituent_Usage (Item_Id);
23859 Next_Elmt (Item_Elmt);
23862 end Check_Proof_In_States;
23864 -------------------------------
23865 -- Check_Refined_Global_List --
23866 -------------------------------
23868 procedure Check_Refined_Global_List
23870 Global_Mode : Name_Id := Name_Input)
23872 procedure Check_Refined_Global_Item
23874 Global_Mode : Name_Id);
23875 -- Verify the legality of a single global item declaration. Parameter
23876 -- Global_Mode denotes the current mode in effect.
23878 -------------------------------
23879 -- Check_Refined_Global_Item --
23880 -------------------------------
23882 procedure Check_Refined_Global_Item
23884 Global_Mode : Name_Id)
23886 Item_Id : constant Entity_Id := Entity_Of (Item);
23888 procedure Inconsistent_Mode_Error (Expect : Name_Id);
23889 -- Issue a common error message for all mode mismatches. Expect
23890 -- denotes the expected mode.
23892 -----------------------------
23893 -- Inconsistent_Mode_Error --
23894 -----------------------------
23896 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
23899 ("global item & has inconsistent modes", Item, Item_Id);
23901 Error_Msg_Name_1 := Global_Mode;
23902 Error_Msg_Name_2 := Expect;
23903 SPARK_Msg_N ("\expected mode %, found mode %", Item);
23904 end Inconsistent_Mode_Error;
23906 -- Start of processing for Check_Refined_Global_Item
23909 -- When the state or object acts as a constituent of another
23910 -- state with a visible refinement, collect it for the state
23911 -- completeness checks performed later on.
23913 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
23914 and then Present (Encapsulating_State (Item_Id))
23915 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
23917 if Global_Mode = Name_Input then
23918 Add_Item (Item_Id, In_Constits);
23920 elsif Global_Mode = Name_In_Out then
23921 Add_Item (Item_Id, In_Out_Constits);
23923 elsif Global_Mode = Name_Output then
23924 Add_Item (Item_Id, Out_Constits);
23926 elsif Global_Mode = Name_Proof_In then
23927 Add_Item (Item_Id, Proof_In_Constits);
23930 -- When not a constituent, ensure that both occurrences of the
23931 -- item in pragmas Global and Refined_Global match.
23933 elsif Contains (In_Items, Item_Id) then
23934 if Global_Mode /= Name_Input then
23935 Inconsistent_Mode_Error (Name_Input);
23938 elsif Contains (In_Out_Items, Item_Id) then
23939 if Global_Mode /= Name_In_Out then
23940 Inconsistent_Mode_Error (Name_In_Out);
23943 elsif Contains (Out_Items, Item_Id) then
23944 if Global_Mode /= Name_Output then
23945 Inconsistent_Mode_Error (Name_Output);
23948 elsif Contains (Proof_In_Items, Item_Id) then
23951 -- The item does not appear in the corresponding Global pragma,
23952 -- it must be an extra (SPARK RM 7.2.4(3)).
23955 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
23957 end Check_Refined_Global_Item;
23963 -- Start of processing for Check_Refined_Global_List
23966 -- Do not perform this check in an instance because it was already
23967 -- performed successfully in the generic template.
23969 if Is_Generic_Instance (Spec_Id) then
23972 elsif Nkind (List) = N_Null then
23975 -- Single global item declaration
23977 elsif Nkind_In (List, N_Expanded_Name,
23979 N_Selected_Component)
23981 Check_Refined_Global_Item (List, Global_Mode);
23983 -- Simple global list or moded global list declaration
23985 elsif Nkind (List) = N_Aggregate then
23987 -- The declaration of a simple global list appear as a collection
23990 if Present (Expressions (List)) then
23991 Item := First (Expressions (List));
23992 while Present (Item) loop
23993 Check_Refined_Global_Item (Item, Global_Mode);
23997 -- The declaration of a moded global list appears as a collection
23998 -- of component associations where individual choices denote
24001 elsif Present (Component_Associations (List)) then
24002 Item := First (Component_Associations (List));
24003 while Present (Item) loop
24004 Check_Refined_Global_List
24005 (List => Expression (Item),
24006 Global_Mode => Chars (First (Choices (Item))));
24014 raise Program_Error;
24020 raise Program_Error;
24022 end Check_Refined_Global_List;
24024 --------------------------
24025 -- Collect_Global_Items --
24026 --------------------------
24028 procedure Collect_Global_Items
24030 Mode : Name_Id := Name_Input)
24032 procedure Collect_Global_Item
24034 Item_Mode : Name_Id);
24035 -- Add a single item to the appropriate list. Item_Mode denotes the
24036 -- current mode in effect.
24038 -------------------------
24039 -- Collect_Global_Item --
24040 -------------------------
24042 procedure Collect_Global_Item
24044 Item_Mode : Name_Id)
24046 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
24047 -- The above handles abstract views of variables and states built
24048 -- for limited with clauses.
24051 -- Signal that the global list contains at least one abstract
24052 -- state with a visible refinement. Note that the refinement may
24053 -- be null in which case there are no constituents.
24055 if Ekind (Item_Id) = E_Abstract_State then
24056 if Has_Null_Refinement (Item_Id) then
24057 Has_Null_State := True;
24059 elsif Has_Non_Null_Refinement (Item_Id) then
24060 if Item_Mode = Name_Input then
24061 Has_In_State := True;
24062 elsif Item_Mode = Name_In_Out then
24063 Has_In_Out_State := True;
24064 elsif Item_Mode = Name_Output then
24065 Has_Out_State := True;
24066 elsif Item_Mode = Name_Proof_In then
24067 Has_Proof_In_State := True;
24072 -- Add the item to the proper list
24074 if Item_Mode = Name_Input then
24075 Add_Item (Item_Id, In_Items);
24076 elsif Item_Mode = Name_In_Out then
24077 Add_Item (Item_Id, In_Out_Items);
24078 elsif Item_Mode = Name_Output then
24079 Add_Item (Item_Id, Out_Items);
24080 elsif Item_Mode = Name_Proof_In then
24081 Add_Item (Item_Id, Proof_In_Items);
24083 end Collect_Global_Item;
24089 -- Start of processing for Collect_Global_Items
24092 if Nkind (List) = N_Null then
24095 -- Single global item declaration
24097 elsif Nkind_In (List, N_Expanded_Name,
24099 N_Selected_Component)
24101 Collect_Global_Item (List, Mode);
24103 -- Single global list or moded global list declaration
24105 elsif Nkind (List) = N_Aggregate then
24107 -- The declaration of a simple global list appear as a collection
24110 if Present (Expressions (List)) then
24111 Item := First (Expressions (List));
24112 while Present (Item) loop
24113 Collect_Global_Item (Item, Mode);
24117 -- The declaration of a moded global list appears as a collection
24118 -- of component associations where individual choices denote mode.
24120 elsif Present (Component_Associations (List)) then
24121 Item := First (Component_Associations (List));
24122 while Present (Item) loop
24123 Collect_Global_Items
24124 (List => Expression (Item),
24125 Mode => Chars (First (Choices (Item))));
24133 raise Program_Error;
24136 -- To accomodate partial decoration of disabled SPARK features, this
24137 -- routine may be called with illegal input. If this is the case, do
24138 -- not raise Program_Error.
24143 end Collect_Global_Items;
24145 -------------------------
24146 -- Present_Then_Remove --
24147 -------------------------
24149 function Present_Then_Remove
24151 Item : Entity_Id) return Boolean
24156 if Present (List) then
24157 Elmt := First_Elmt (List);
24158 while Present (Elmt) loop
24159 if Node (Elmt) = Item then
24160 Remove_Elmt (List, Elmt);
24169 end Present_Then_Remove;
24171 -------------------------------
24172 -- Report_Extra_Constituents --
24173 -------------------------------
24175 procedure Report_Extra_Constituents is
24176 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
24177 -- Emit an error for every element of List
24179 ---------------------------------------
24180 -- Report_Extra_Constituents_In_List --
24181 ---------------------------------------
24183 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
24184 Constit_Elmt : Elmt_Id;
24187 if Present (List) then
24188 Constit_Elmt := First_Elmt (List);
24189 while Present (Constit_Elmt) loop
24190 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
24191 Next_Elmt (Constit_Elmt);
24194 end Report_Extra_Constituents_In_List;
24196 -- Start of processing for Report_Extra_Constituents
24199 -- Do not perform this check in an instance because it was already
24200 -- performed successfully in the generic template.
24202 if Is_Generic_Instance (Spec_Id) then
24206 Report_Extra_Constituents_In_List (In_Constits);
24207 Report_Extra_Constituents_In_List (In_Out_Constits);
24208 Report_Extra_Constituents_In_List (Out_Constits);
24209 Report_Extra_Constituents_In_List (Proof_In_Constits);
24211 end Report_Extra_Constituents;
24215 Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
24216 Errors : constant Nat := Serious_Errors_Detected;
24219 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
24222 if Nkind (Body_Decl) = N_Subprogram_Body_Stub then
24223 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
24225 Spec_Id := Corresponding_Spec (Body_Decl);
24228 Global := Get_Pragma (Spec_Id, Pragma_Global);
24229 Items := Expression (Get_Argument (N, Spec_Id));
24231 -- The subprogram declaration lacks pragma Global. This renders
24232 -- Refined_Global useless as there is nothing to refine.
24234 if No (Global) then
24236 ("useless refinement, declaration of subprogram & lacks aspect or "
24237 & "pragma Global", N, Spec_Id);
24241 -- Extract all relevant items from the corresponding Global pragma
24243 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
24245 -- Package and subprogram bodies are instantiated individually in
24246 -- a separate compiler pass. Due to this mode of instantiation, the
24247 -- refinement of a state may no longer be visible when a subprogram
24248 -- body contract is instantiated. Since the generic template is legal,
24249 -- do not perform this check in the instance to circumvent this oddity.
24251 if Is_Generic_Instance (Spec_Id) then
24254 -- Non-instance case
24257 -- The corresponding Global pragma must mention at least one state
24258 -- witha visible refinement at the point Refined_Global is processed.
24259 -- States with null refinements need Refined_Global pragma
24260 -- (SPARK RM 7.2.4(2)).
24262 if not Has_In_State
24263 and then not Has_In_Out_State
24264 and then not Has_Out_State
24265 and then not Has_Proof_In_State
24266 and then not Has_Null_State
24269 ("useless refinement, subprogram & does not depend on abstract "
24270 & "state with visible refinement", N, Spec_Id);
24273 -- The global refinement of inputs and outputs cannot be null when
24274 -- the corresponding Global pragma contains at least one item except
24275 -- in the case where we have states with null refinements.
24277 elsif Nkind (Items) = N_Null
24279 (Present (In_Items)
24280 or else Present (In_Out_Items)
24281 or else Present (Out_Items)
24282 or else Present (Proof_In_Items))
24283 and then not Has_Null_State
24286 ("refinement cannot be null, subprogram & has global items",
24292 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
24293 -- This ensures that the categorization of all refined global items is
24294 -- consistent with their role.
24296 Analyze_Global_In_Decl_Part (N);
24298 -- Perform all refinement checks with respect to completeness and mode
24301 if Serious_Errors_Detected = Errors then
24302 Check_Refined_Global_List (Items);
24305 -- For Input states with visible refinement, at least one constituent
24306 -- must be used as an Input in the global refinement.
24308 if Serious_Errors_Detected = Errors then
24309 Check_Input_States;
24312 -- Verify all possible completion variants for In_Out states with
24313 -- visible refinement.
24315 if Serious_Errors_Detected = Errors then
24316 Check_In_Out_States;
24319 -- For Output states with visible refinement, all constituents must be
24320 -- used as Outputs in the global refinement.
24322 if Serious_Errors_Detected = Errors then
24323 Check_Output_States;
24326 -- For Proof_In states with visible refinement, at least one constituent
24327 -- must be used as Proof_In in the global refinement.
24329 if Serious_Errors_Detected = Errors then
24330 Check_Proof_In_States;
24333 -- Emit errors for all constituents that belong to other states with
24334 -- visible refinement that do not appear in Global.
24336 if Serious_Errors_Detected = Errors then
24337 Report_Extra_Constituents;
24339 end Analyze_Refined_Global_In_Decl_Part;
24341 ----------------------------------------
24342 -- Analyze_Refined_State_In_Decl_Part --
24343 ----------------------------------------
24345 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
24346 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
24347 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24348 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
24350 Available_States : Elist_Id := No_Elist;
24351 -- A list of all abstract states defined in the package declaration that
24352 -- are available for refinement. The list is used to report unrefined
24355 Body_States : Elist_Id := No_Elist;
24356 -- A list of all hidden states that appear in the body of the related
24357 -- package. The list is used to report unused hidden states.
24359 Constituents_Seen : Elist_Id := No_Elist;
24360 -- A list that contains all constituents processed so far. The list is
24361 -- used to detect multiple uses of the same constituent.
24363 Refined_States_Seen : Elist_Id := No_Elist;
24364 -- A list that contains all refined states processed so far. The list is
24365 -- used to detect duplicate refinements.
24367 procedure Analyze_Refinement_Clause (Clause : Node_Id);
24368 -- Perform full analysis of a single refinement clause
24370 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id;
24371 -- Gather the entities of all abstract states and objects declared in
24372 -- the body state space of package Pack_Id.
24374 procedure Report_Unrefined_States (States : Elist_Id);
24375 -- Emit errors for all unrefined abstract states found in list States
24377 procedure Report_Unused_States (States : Elist_Id);
24378 -- Emit errors for all unused states found in list States
24380 -------------------------------
24381 -- Analyze_Refinement_Clause --
24382 -------------------------------
24384 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
24385 AR_Constit : Entity_Id := Empty;
24386 AW_Constit : Entity_Id := Empty;
24387 ER_Constit : Entity_Id := Empty;
24388 EW_Constit : Entity_Id := Empty;
24389 -- The entities of external constituents that contain one of the
24390 -- following enabled properties: Async_Readers, Async_Writers,
24391 -- Effective_Reads and Effective_Writes.
24393 External_Constit_Seen : Boolean := False;
24394 -- Flag used to mark when at least one external constituent is part
24395 -- of the state refinement.
24397 Non_Null_Seen : Boolean := False;
24398 Null_Seen : Boolean := False;
24399 -- Flags used to detect multiple uses of null in a single clause or a
24400 -- mixture of null and non-null constituents.
24402 Part_Of_Constits : Elist_Id := No_Elist;
24403 -- A list of all candidate constituents subject to indicator Part_Of
24404 -- where the encapsulating state is the current state.
24407 State_Id : Entity_Id;
24408 -- The current state being refined
24410 procedure Analyze_Constituent (Constit : Node_Id);
24411 -- Perform full analysis of a single constituent
24413 procedure Check_External_Property
24414 (Prop_Nam : Name_Id;
24416 Constit : Entity_Id);
24417 -- Determine whether a property denoted by name Prop_Nam is present
24418 -- in both the refined state and constituent Constit. Flag Enabled
24419 -- should be set when the property applies to the refined state. If
24420 -- this is not the case, emit an error message.
24422 procedure Check_Matching_State;
24423 -- Determine whether the state being refined appears in list
24424 -- Available_States. Emit an error when attempting to re-refine the
24425 -- state or when the state is not defined in the package declaration,
24426 -- otherwise remove the state from Available_States.
24428 procedure Report_Unused_Constituents (Constits : Elist_Id);
24429 -- Emit errors for all unused Part_Of constituents in list Constits
24431 -------------------------
24432 -- Analyze_Constituent --
24433 -------------------------
24435 procedure Analyze_Constituent (Constit : Node_Id) is
24436 procedure Check_Ghost_Constituent (Constit_Id : Entity_Id);
24437 -- Verify that the constituent Constit_Id is a Ghost entity if the
24438 -- abstract state being refined is also Ghost. If this is the case
24439 -- verify that the Ghost policy in effect at the point of state
24440 -- and constituent declaration is the same.
24442 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
24443 -- Determine whether constituent Constit denoted by its entity
24444 -- Constit_Id appears in Hidden_States. Emit an error when the
24445 -- constituent is not a valid hidden state of the related package
24446 -- or when it is used more than once. Otherwise remove the
24447 -- constituent from Hidden_States.
24449 --------------------------------
24450 -- Check_Matching_Constituent --
24451 --------------------------------
24453 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
24454 procedure Collect_Constituent;
24455 -- Add constituent Constit_Id to the refinements of State_Id
24457 -------------------------
24458 -- Collect_Constituent --
24459 -------------------------
24461 procedure Collect_Constituent is
24463 -- Add the constituent to the list of processed items to aid
24464 -- with the detection of duplicates.
24466 Add_Item (Constit_Id, Constituents_Seen);
24468 -- Collect the constituent in the list of refinement items
24469 -- and establish a relation between the refined state and
24472 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
24473 Set_Encapsulating_State (Constit_Id, State_Id);
24475 -- The state has at least one legal constituent, mark the
24476 -- start of the refinement region. The region ends when the
24477 -- body declarations end (see routine Analyze_Declarations).
24479 Set_Has_Visible_Refinement (State_Id);
24481 -- When the constituent is external, save its relevant
24482 -- property for further checks.
24484 if Async_Readers_Enabled (Constit_Id) then
24485 AR_Constit := Constit_Id;
24486 External_Constit_Seen := True;
24489 if Async_Writers_Enabled (Constit_Id) then
24490 AW_Constit := Constit_Id;
24491 External_Constit_Seen := True;
24494 if Effective_Reads_Enabled (Constit_Id) then
24495 ER_Constit := Constit_Id;
24496 External_Constit_Seen := True;
24499 if Effective_Writes_Enabled (Constit_Id) then
24500 EW_Constit := Constit_Id;
24501 External_Constit_Seen := True;
24503 end Collect_Constituent;
24507 State_Elmt : Elmt_Id;
24509 -- Start of processing for Check_Matching_Constituent
24512 -- Detect a duplicate use of a constituent
24514 if Contains (Constituents_Seen, Constit_Id) then
24516 ("duplicate use of constituent &", Constit, Constit_Id);
24520 -- The constituent is subject to a Part_Of indicator
24522 if Present (Encapsulating_State (Constit_Id)) then
24523 if Encapsulating_State (Constit_Id) = State_Id then
24524 Check_Ghost_Constituent (Constit_Id);
24525 Remove (Part_Of_Constits, Constit_Id);
24526 Collect_Constituent;
24528 -- The constituent is part of another state and is used
24529 -- incorrectly in the refinement of the current state.
24532 Error_Msg_Name_1 := Chars (State_Id);
24534 ("& cannot act as constituent of state %",
24535 Constit, Constit_Id);
24537 ("\Part_Of indicator specifies & as encapsulating "
24538 & "state", Constit, Encapsulating_State (Constit_Id));
24541 -- The only other source of legal constituents is the body
24542 -- state space of the related package.
24545 if Present (Body_States) then
24546 State_Elmt := First_Elmt (Body_States);
24547 while Present (State_Elmt) loop
24549 -- Consume a valid constituent to signal that it has
24550 -- been encountered.
24552 if Node (State_Elmt) = Constit_Id then
24553 Check_Ghost_Constituent (Constit_Id);
24554 Remove_Elmt (Body_States, State_Elmt);
24555 Collect_Constituent;
24559 Next_Elmt (State_Elmt);
24563 -- Constants are part of the hidden state of a package, but
24564 -- the compiler cannot determine whether they have variable
24565 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
24566 -- hidden state. Accept the constant quietly even if it is
24567 -- a visible state or lacks a Part_Of indicator.
24569 if Ekind (Constit_Id) = E_Constant then
24572 -- If we get here, then the constituent is not a hidden
24573 -- state of the related package and may not be used in a
24574 -- refinement (SPARK RM 7.2.2(9)).
24577 Error_Msg_Name_1 := Chars (Spec_Id);
24579 ("cannot use & in refinement, constituent is not a "
24580 & "hidden state of package %", Constit, Constit_Id);
24583 end Check_Matching_Constituent;
24585 -----------------------------
24586 -- Check_Ghost_Constituent --
24587 -----------------------------
24589 procedure Check_Ghost_Constituent (Constit_Id : Entity_Id) is
24591 if Is_Ghost_Entity (State_Id) then
24592 if Is_Ghost_Entity (Constit_Id) then
24594 -- The Ghost policy in effect at the point of abstract
24595 -- state declaration and constituent must match
24596 -- (SPARK RM 6.9(16)).
24598 if Is_Checked_Ghost_Entity (State_Id)
24599 and then Is_Ignored_Ghost_Entity (Constit_Id)
24601 Error_Msg_Sloc := Sloc (Constit);
24604 ("incompatible ghost policies in effect", State);
24606 ("\abstract state & declared with ghost policy "
24607 & "Check", State, State_Id);
24609 ("\constituent & declared # with ghost policy "
24610 & "Ignore", State, Constit_Id);
24612 elsif Is_Ignored_Ghost_Entity (State_Id)
24613 and then Is_Checked_Ghost_Entity (Constit_Id)
24615 Error_Msg_Sloc := Sloc (Constit);
24618 ("incompatible ghost policies in effect", State);
24620 ("\abstract state & declared with ghost policy "
24621 & "Ignore", State, State_Id);
24623 ("\constituent & declared # with ghost policy "
24624 & "Check", State, Constit_Id);
24627 -- A constituent of a Ghost abstract state must be a Ghost
24628 -- entity (SPARK RM 7.2.2(12)).
24632 ("constituent of ghost state & must be ghost",
24633 Constit, State_Id);
24636 end Check_Ghost_Constituent;
24640 Constit_Id : Entity_Id;
24642 -- Start of processing for Analyze_Constituent
24645 -- Detect multiple uses of null in a single refinement clause or a
24646 -- mixture of null and non-null constituents.
24648 if Nkind (Constit) = N_Null then
24651 ("multiple null constituents not allowed", Constit);
24653 elsif Non_Null_Seen then
24655 ("cannot mix null and non-null constituents", Constit);
24660 -- Collect the constituent in the list of refinement items
24662 Append_Elmt (Constit, Refinement_Constituents (State_Id));
24664 -- The state has at least one legal constituent, mark the
24665 -- start of the refinement region. The region ends when the
24666 -- body declarations end (see Analyze_Declarations).
24668 Set_Has_Visible_Refinement (State_Id);
24671 -- Non-null constituents
24674 Non_Null_Seen := True;
24678 ("cannot mix null and non-null constituents", Constit);
24682 Resolve_State (Constit);
24684 -- Ensure that the constituent denotes a valid state or a
24685 -- whole object (SPARK RM 7.2.2(5)).
24687 if Is_Entity_Name (Constit) then
24688 Constit_Id := Entity_Of (Constit);
24690 if Ekind_In (Constit_Id, E_Abstract_State,
24694 Check_Matching_Constituent (Constit_Id);
24698 ("constituent & must denote object or state",
24699 Constit, Constit_Id);
24702 -- The constituent is illegal
24705 SPARK_Msg_N ("malformed constituent", Constit);
24708 end Analyze_Constituent;
24710 -----------------------------
24711 -- Check_External_Property --
24712 -----------------------------
24714 procedure Check_External_Property
24715 (Prop_Nam : Name_Id;
24717 Constit : Entity_Id)
24720 Error_Msg_Name_1 := Prop_Nam;
24722 -- The property is enabled in the related Abstract_State pragma
24723 -- that defines the state (SPARK RM 7.2.8(3)).
24726 if No (Constit) then
24728 ("external state & requires at least one constituent with "
24729 & "property %", State, State_Id);
24732 -- The property is missing in the declaration of the state, but
24733 -- a constituent is introducing it in the state refinement
24734 -- (SPARK RM 7.2.8(3)).
24736 elsif Present (Constit) then
24737 Error_Msg_Name_2 := Chars (Constit);
24739 ("external state & lacks property % set by constituent %",
24742 end Check_External_Property;
24744 --------------------------
24745 -- Check_Matching_State --
24746 --------------------------
24748 procedure Check_Matching_State is
24749 State_Elmt : Elmt_Id;
24752 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24754 if Contains (Refined_States_Seen, State_Id) then
24756 ("duplicate refinement of state &", State, State_Id);
24760 -- Inspect the abstract states defined in the package declaration
24761 -- looking for a match.
24763 State_Elmt := First_Elmt (Available_States);
24764 while Present (State_Elmt) loop
24766 -- A valid abstract state is being refined in the body. Add
24767 -- the state to the list of processed refined states to aid
24768 -- with the detection of duplicate refinements. Remove the
24769 -- state from Available_States to signal that it has already
24772 if Node (State_Elmt) = State_Id then
24773 Add_Item (State_Id, Refined_States_Seen);
24774 Remove_Elmt (Available_States, State_Elmt);
24778 Next_Elmt (State_Elmt);
24781 -- If we get here, we are refining a state that is not defined in
24782 -- the package declaration.
24784 Error_Msg_Name_1 := Chars (Spec_Id);
24786 ("cannot refine state, & is not defined in package %",
24788 end Check_Matching_State;
24790 --------------------------------
24791 -- Report_Unused_Constituents --
24792 --------------------------------
24794 procedure Report_Unused_Constituents (Constits : Elist_Id) is
24795 Constit_Elmt : Elmt_Id;
24796 Constit_Id : Entity_Id;
24797 Posted : Boolean := False;
24800 if Present (Constits) then
24801 Constit_Elmt := First_Elmt (Constits);
24802 while Present (Constit_Elmt) loop
24803 Constit_Id := Node (Constit_Elmt);
24805 -- Generate an error message of the form:
24807 -- state ... has unused Part_Of constituents
24808 -- abstract state ... defined at ...
24809 -- constant ... defined at ...
24810 -- variable ... defined at ...
24815 ("state & has unused Part_Of constituents",
24819 Error_Msg_Sloc := Sloc (Constit_Id);
24821 if Ekind (Constit_Id) = E_Abstract_State then
24823 ("\abstract state & defined #", State, Constit_Id);
24825 elsif Ekind (Constit_Id) = E_Constant then
24827 ("\constant & defined #", State, Constit_Id);
24830 pragma Assert (Ekind (Constit_Id) = E_Variable);
24831 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
24834 Next_Elmt (Constit_Elmt);
24837 end Report_Unused_Constituents;
24839 -- Local declarations
24841 Body_Ref : Node_Id;
24842 Body_Ref_Elmt : Elmt_Id;
24844 Extra_State : Node_Id;
24846 -- Start of processing for Analyze_Refinement_Clause
24849 -- A refinement clause appears as a component association where the
24850 -- sole choice is the state and the expressions are the constituents.
24851 -- This is a syntax error, always report.
24853 if Nkind (Clause) /= N_Component_Association then
24854 Error_Msg_N ("malformed state refinement clause", Clause);
24858 -- Analyze the state name of a refinement clause
24860 State := First (Choices (Clause));
24863 Resolve_State (State);
24865 -- Ensure that the state name denotes a valid abstract state that is
24866 -- defined in the spec of the related package.
24868 if Is_Entity_Name (State) then
24869 State_Id := Entity_Of (State);
24871 -- Catch any attempts to re-refine a state or refine a state that
24872 -- is not defined in the package declaration.
24874 if Ekind (State_Id) = E_Abstract_State then
24875 Check_Matching_State;
24878 ("& must denote an abstract state", State, State_Id);
24882 -- References to a state with visible refinement are illegal.
24883 -- When nested packages are involved, detecting such references is
24884 -- tricky because pragma Refined_State is analyzed later than the
24885 -- offending pragma Depends or Global. References that occur in
24886 -- such nested context are stored in a list. Emit errors for all
24887 -- references found in Body_References (SPARK RM 6.1.4(8)).
24889 if Present (Body_References (State_Id)) then
24890 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
24891 while Present (Body_Ref_Elmt) loop
24892 Body_Ref := Node (Body_Ref_Elmt);
24894 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
24895 Error_Msg_Sloc := Sloc (State);
24896 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
24898 Next_Elmt (Body_Ref_Elmt);
24902 -- The state name is illegal. This is a syntax error, always report.
24905 Error_Msg_N ("malformed state name in refinement clause", State);
24909 -- A refinement clause may only refine one state at a time
24911 Extra_State := Next (State);
24913 if Present (Extra_State) then
24915 ("refinement clause cannot cover multiple states", Extra_State);
24918 -- Replicate the Part_Of constituents of the refined state because
24919 -- the algorithm will consume items.
24921 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
24923 -- Analyze all constituents of the refinement. Multiple constituents
24924 -- appear as an aggregate.
24926 Constit := Expression (Clause);
24928 if Nkind (Constit) = N_Aggregate then
24929 if Present (Component_Associations (Constit)) then
24931 ("constituents of refinement clause must appear in "
24932 & "positional form", Constit);
24934 else pragma Assert (Present (Expressions (Constit)));
24935 Constit := First (Expressions (Constit));
24936 while Present (Constit) loop
24937 Analyze_Constituent (Constit);
24942 -- Various forms of a single constituent. Note that these may include
24943 -- malformed constituents.
24946 Analyze_Constituent (Constit);
24949 -- A refined external state is subject to special rules with respect
24950 -- to its properties and constituents.
24952 if Is_External_State (State_Id) then
24954 -- The set of properties that all external constituents yield must
24955 -- match that of the refined state. There are two cases to detect:
24956 -- the refined state lacks a property or has an extra property.
24958 if External_Constit_Seen then
24959 Check_External_Property
24960 (Prop_Nam => Name_Async_Readers,
24961 Enabled => Async_Readers_Enabled (State_Id),
24962 Constit => AR_Constit);
24964 Check_External_Property
24965 (Prop_Nam => Name_Async_Writers,
24966 Enabled => Async_Writers_Enabled (State_Id),
24967 Constit => AW_Constit);
24969 Check_External_Property
24970 (Prop_Nam => Name_Effective_Reads,
24971 Enabled => Effective_Reads_Enabled (State_Id),
24972 Constit => ER_Constit);
24974 Check_External_Property
24975 (Prop_Nam => Name_Effective_Writes,
24976 Enabled => Effective_Writes_Enabled (State_Id),
24977 Constit => EW_Constit);
24979 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24981 elsif Null_Seen then
24984 -- The external state has constituents, but none of them are
24985 -- external (SPARK RM 7.2.8(2)).
24989 ("external state & requires at least one external "
24990 & "constituent or null refinement", State, State_Id);
24993 -- When a refined state is not external, it should not have external
24994 -- constituents (SPARK RM 7.2.8(1)).
24996 elsif External_Constit_Seen then
24998 ("non-external state & cannot contain external constituents in "
24999 & "refinement", State, State_Id);
25002 -- Ensure that all Part_Of candidate constituents have been mentioned
25003 -- in the refinement clause.
25005 Report_Unused_Constituents (Part_Of_Constits);
25006 end Analyze_Refinement_Clause;
25008 -------------------------
25009 -- Collect_Body_States --
25010 -------------------------
25012 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id is
25013 Result : Elist_Id := No_Elist;
25014 -- A list containing all body states of Pack_Id
25016 procedure Collect_Visible_States (Pack_Id : Entity_Id);
25017 -- Gather the entities of all abstract states and objects declared in
25018 -- the visible state space of package Pack_Id.
25020 ----------------------------
25021 -- Collect_Visible_States --
25022 ----------------------------
25024 procedure Collect_Visible_States (Pack_Id : Entity_Id) is
25025 Item_Id : Entity_Id;
25028 -- Traverse the entity chain of the package and inspect all
25031 Item_Id := First_Entity (Pack_Id);
25032 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
25034 -- Do not consider internally generated items as those cannot
25035 -- be named and participate in refinement.
25037 if not Comes_From_Source (Item_Id) then
25040 elsif Ekind (Item_Id) = E_Abstract_State then
25041 Add_Item (Item_Id, Result);
25043 -- Do not consider constants or variables that map generic
25044 -- formals to their actuals, as the formals cannot be named
25045 -- from the outside and participate in refinement.
25047 elsif Ekind_In (Item_Id, E_Constant, E_Variable)
25048 and then No (Corresponding_Generic_Association
25049 (Declaration_Node (Item_Id)))
25051 Add_Item (Item_Id, Result);
25053 -- Recursively gather the visible states of a nested package
25055 elsif Ekind (Item_Id) = E_Package then
25056 Collect_Visible_States (Item_Id);
25059 Next_Entity (Item_Id);
25061 end Collect_Visible_States;
25065 Pack_Body : constant Node_Id :=
25066 Declaration_Node (Body_Entity (Pack_Id));
25068 Item_Id : Entity_Id;
25070 -- Start of processing for Collect_Body_States
25073 -- Inspect the declarations of the body looking for source objects,
25074 -- packages and package instantiations.
25076 Decl := First (Declarations (Pack_Body));
25077 while Present (Decl) loop
25079 -- Capture source objects as internally generated temporaries
25080 -- cannot be named and participate in refinement.
25082 if Nkind (Decl) = N_Object_Declaration then
25083 Item_Id := Defining_Entity (Decl);
25085 if Comes_From_Source (Item_Id) then
25086 Add_Item (Item_Id, Result);
25089 -- Capture the visible abstract states and objects of a source
25090 -- package [instantiation].
25092 elsif Nkind (Decl) = N_Package_Declaration then
25093 Item_Id := Defining_Entity (Decl);
25095 if Comes_From_Source (Item_Id) then
25096 Collect_Visible_States (Item_Id);
25104 end Collect_Body_States;
25106 -----------------------------
25107 -- Report_Unrefined_States --
25108 -----------------------------
25110 procedure Report_Unrefined_States (States : Elist_Id) is
25111 State_Elmt : Elmt_Id;
25114 if Present (States) then
25115 State_Elmt := First_Elmt (States);
25116 while Present (State_Elmt) loop
25118 ("abstract state & must be refined", Node (State_Elmt));
25120 Next_Elmt (State_Elmt);
25123 end Report_Unrefined_States;
25125 --------------------------
25126 -- Report_Unused_States --
25127 --------------------------
25129 procedure Report_Unused_States (States : Elist_Id) is
25130 Posted : Boolean := False;
25131 State_Elmt : Elmt_Id;
25132 State_Id : Entity_Id;
25135 if Present (States) then
25136 State_Elmt := First_Elmt (States);
25137 while Present (State_Elmt) loop
25138 State_Id := Node (State_Elmt);
25140 -- Constants are part of the hidden state of a package, but the
25141 -- compiler cannot determine whether they have variable input
25142 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
25143 -- hidden state. Do not emit an error when a constant does not
25144 -- participate in a state refinement, even though it acts as a
25147 if Ekind (State_Id) = E_Constant then
25150 -- Generate an error message of the form:
25152 -- body of package ... has unused hidden states
25153 -- abstract state ... defined at ...
25154 -- variable ... defined at ...
25160 ("body of package & has unused hidden states", Body_Id);
25163 Error_Msg_Sloc := Sloc (State_Id);
25165 if Ekind (State_Id) = E_Abstract_State then
25167 ("\abstract state & defined #", Body_Id, State_Id);
25170 pragma Assert (Ekind (State_Id) = E_Variable);
25171 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
25175 Next_Elmt (State_Elmt);
25178 end Report_Unused_States;
25180 -- Local declarations
25182 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25185 -- Start of processing for Analyze_Refined_State_In_Decl_Part
25190 -- Replicate the abstract states declared by the package because the
25191 -- matching algorithm will consume states.
25193 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
25195 -- Gather all abstract states and objects declared in the visible
25196 -- state space of the package body. These items must be utilized as
25197 -- constituents in a state refinement.
25199 Body_States := Collect_Body_States (Spec_Id);
25201 -- Multiple non-null state refinements appear as an aggregate
25203 if Nkind (Clauses) = N_Aggregate then
25204 if Present (Expressions (Clauses)) then
25206 ("state refinements must appear as component associations",
25209 else pragma Assert (Present (Component_Associations (Clauses)));
25210 Clause := First (Component_Associations (Clauses));
25211 while Present (Clause) loop
25212 Analyze_Refinement_Clause (Clause);
25217 -- Various forms of a single state refinement. Note that these may
25218 -- include malformed refinements.
25221 Analyze_Refinement_Clause (Clauses);
25224 -- List all abstract states that were left unrefined
25226 Report_Unrefined_States (Available_States);
25228 -- Ensure that all abstract states and objects declared in the body
25229 -- state space of the related package are utilized as constituents.
25231 Report_Unused_States (Body_States);
25232 end Analyze_Refined_State_In_Decl_Part;
25234 ------------------------------------
25235 -- Analyze_Test_Case_In_Decl_Part --
25236 ------------------------------------
25238 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
25239 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
25240 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
25242 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
25243 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
25244 -- denoted by Arg_Nam.
25246 ------------------------------
25247 -- Preanalyze_Test_Case_Arg --
25248 ------------------------------
25250 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
25254 -- Preanalyze the original aspect argument for ASIS or for a generic
25255 -- subprogram to properly capture global references.
25257 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
25261 Arg_Nam => Arg_Nam,
25262 From_Aspect => True);
25264 if Present (Arg) then
25265 Preanalyze_Assert_Expression
25266 (Expression (Arg), Standard_Boolean);
25270 Arg := Test_Case_Arg (N, Arg_Nam);
25272 if Present (Arg) then
25273 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
25275 end Preanalyze_Test_Case_Arg;
25279 Restore_Scope : Boolean := False;
25281 -- Start of processing for Analyze_Test_Case_In_Decl_Part
25284 -- Ensure that the formal parameters are visible when analyzing all
25285 -- clauses. This falls out of the general rule of aspects pertaining
25286 -- to subprogram declarations.
25288 if not In_Open_Scopes (Spec_Id) then
25289 Restore_Scope := True;
25290 Push_Scope (Spec_Id);
25292 if Is_Generic_Subprogram (Spec_Id) then
25293 Install_Generic_Formals (Spec_Id);
25295 Install_Formals (Spec_Id);
25299 Preanalyze_Test_Case_Arg (Name_Requires);
25300 Preanalyze_Test_Case_Arg (Name_Ensures);
25302 if Restore_Scope then
25306 -- Currently it is not possible to inline pre/postconditions on a
25307 -- subprogram subject to pragma Inline_Always.
25309 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25310 end Analyze_Test_Case_In_Decl_Part;
25316 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
25321 if Present (List) then
25322 Elmt := First_Elmt (List);
25323 while Present (Elmt) loop
25324 if Nkind (Node (Elmt)) = N_Defining_Identifier then
25327 Id := Entity_Of (Node (Elmt));
25330 if Id = Item_Id then
25341 -----------------------------
25342 -- Check_Applicable_Policy --
25343 -----------------------------
25345 procedure Check_Applicable_Policy (N : Node_Id) is
25349 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
25352 -- No effect if not valid assertion kind name
25354 if not Is_Valid_Assertion_Kind (Ename) then
25358 -- Loop through entries in check policy list
25360 PP := Opt.Check_Policy_List;
25361 while Present (PP) loop
25363 PPA : constant List_Id := Pragma_Argument_Associations (PP);
25364 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
25368 or else Pnm = Name_Assertion
25369 or else (Pnm = Name_Statement_Assertions
25370 and then Nam_In (Ename, Name_Assert,
25371 Name_Assert_And_Cut,
25373 Name_Loop_Invariant,
25374 Name_Loop_Variant))
25376 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
25379 when Name_Off | Name_Ignore =>
25380 Set_Is_Ignored (N, True);
25381 Set_Is_Checked (N, False);
25383 when Name_On | Name_Check =>
25384 Set_Is_Checked (N, True);
25385 Set_Is_Ignored (N, False);
25387 when Name_Disable =>
25388 Set_Is_Ignored (N, True);
25389 Set_Is_Checked (N, False);
25390 Set_Is_Disabled (N, True);
25392 -- That should be exhaustive, the null here is a defence
25393 -- against a malformed tree from previous errors.
25402 PP := Next_Pragma (PP);
25406 -- If there are no specific entries that matched, then we let the
25407 -- setting of assertions govern. Note that this provides the needed
25408 -- compatibility with the RM for the cases of assertion, invariant,
25409 -- precondition, predicate, and postcondition.
25411 if Assertions_Enabled then
25412 Set_Is_Checked (N, True);
25413 Set_Is_Ignored (N, False);
25415 Set_Is_Checked (N, False);
25416 Set_Is_Ignored (N, True);
25418 end Check_Applicable_Policy;
25420 -------------------------------
25421 -- Check_External_Properties --
25422 -------------------------------
25424 procedure Check_External_Properties
25432 -- All properties enabled
25434 if AR and AW and ER and EW then
25437 -- Async_Readers + Effective_Writes
25438 -- Async_Readers + Async_Writers + Effective_Writes
25440 elsif AR and EW and not ER then
25443 -- Async_Writers + Effective_Reads
25444 -- Async_Readers + Async_Writers + Effective_Reads
25446 elsif AW and ER and not EW then
25449 -- Async_Readers + Async_Writers
25451 elsif AR and AW and not ER and not EW then
25456 elsif AR and not AW and not ER and not EW then
25461 elsif AW and not AR and not ER and not EW then
25466 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
25469 end Check_External_Properties;
25475 function Check_Kind (Nam : Name_Id) return Name_Id is
25479 -- Loop through entries in check policy list
25481 PP := Opt.Check_Policy_List;
25482 while Present (PP) loop
25484 PPA : constant List_Id := Pragma_Argument_Associations (PP);
25485 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
25489 or else (Pnm = Name_Assertion
25490 and then Is_Valid_Assertion_Kind (Nam))
25491 or else (Pnm = Name_Statement_Assertions
25492 and then Nam_In (Nam, Name_Assert,
25493 Name_Assert_And_Cut,
25495 Name_Loop_Invariant,
25496 Name_Loop_Variant))
25498 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
25499 when Name_On | Name_Check =>
25501 when Name_Off | Name_Ignore =>
25502 return Name_Ignore;
25503 when Name_Disable =>
25504 return Name_Disable;
25506 raise Program_Error;
25510 PP := Next_Pragma (PP);
25515 -- If there are no specific entries that matched, then we let the
25516 -- setting of assertions govern. Note that this provides the needed
25517 -- compatibility with the RM for the cases of assertion, invariant,
25518 -- precondition, predicate, and postcondition.
25520 if Assertions_Enabled then
25523 return Name_Ignore;
25527 ---------------------------
25528 -- Check_Missing_Part_Of --
25529 ---------------------------
25531 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
25532 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
25533 -- Determine whether a package denoted by Pack_Id declares at least one
25536 -----------------------
25537 -- Has_Visible_State --
25538 -----------------------
25540 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
25541 Item_Id : Entity_Id;
25544 -- Traverse the entity chain of the package trying to find at least
25545 -- one visible abstract state, variable or a package [instantiation]
25546 -- that declares a visible state.
25548 Item_Id := First_Entity (Pack_Id);
25549 while Present (Item_Id)
25550 and then not In_Private_Part (Item_Id)
25552 -- Do not consider internally generated items
25554 if not Comes_From_Source (Item_Id) then
25557 -- A visible state has been found
25559 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
25562 -- Recursively peek into nested packages and instantiations
25564 elsif Ekind (Item_Id) = E_Package
25565 and then Has_Visible_State (Item_Id)
25570 Next_Entity (Item_Id);
25574 end Has_Visible_State;
25578 Pack_Id : Entity_Id;
25579 Placement : State_Space_Kind;
25581 -- Start of processing for Check_Missing_Part_Of
25584 -- Do not consider abstract states, variables or package instantiations
25585 -- coming from an instance as those always inherit the Part_Of indicator
25586 -- of the instance itself.
25588 if In_Instance then
25591 -- Do not consider internally generated entities as these can never
25592 -- have a Part_Of indicator.
25594 elsif not Comes_From_Source (Item_Id) then
25597 -- Perform these checks only when SPARK_Mode is enabled as they will
25598 -- interfere with standard Ada rules and produce false positives.
25600 elsif SPARK_Mode /= On then
25603 -- Do not consider constants, because the compiler cannot accurately
25604 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
25605 -- act as a hidden state of a package.
25607 elsif Ekind (Item_Id) = E_Constant then
25611 -- Find where the abstract state, variable or package instantiation
25612 -- lives with respect to the state space.
25614 Find_Placement_In_State_Space
25615 (Item_Id => Item_Id,
25616 Placement => Placement,
25617 Pack_Id => Pack_Id);
25619 -- Items that appear in a non-package construct (subprogram, block, etc)
25620 -- do not require a Part_Of indicator because they can never act as a
25623 if Placement = Not_In_Package then
25626 -- An item declared in the body state space of a package always act as a
25627 -- constituent and does not need explicit Part_Of indicator.
25629 elsif Placement = Body_State_Space then
25632 -- In general an item declared in the visible state space of a package
25633 -- does not require a Part_Of indicator. The only exception is when the
25634 -- related package is a private child unit in which case Part_Of must
25635 -- denote a state in the parent unit or in one of its descendants.
25637 elsif Placement = Visible_State_Space then
25638 if Is_Child_Unit (Pack_Id)
25639 and then Is_Private_Descendant (Pack_Id)
25641 -- A package instantiation does not need a Part_Of indicator when
25642 -- the related generic template has no visible state.
25644 if Ekind (Item_Id) = E_Package
25645 and then Is_Generic_Instance (Item_Id)
25646 and then not Has_Visible_State (Item_Id)
25650 -- All other cases require Part_Of
25654 ("indicator Part_Of is required in this context "
25655 & "(SPARK RM 7.2.6(3))", Item_Id);
25656 Error_Msg_Name_1 := Chars (Pack_Id);
25658 ("\& is declared in the visible part of private child "
25659 & "unit %", Item_Id);
25663 -- When the item appears in the private state space of a packge, it must
25664 -- be a part of some state declared by the said package.
25666 else pragma Assert (Placement = Private_State_Space);
25668 -- The related package does not declare a state, the item cannot act
25669 -- as a Part_Of constituent.
25671 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
25674 -- A package instantiation does not need a Part_Of indicator when the
25675 -- related generic template has no visible state.
25677 elsif Ekind (Pack_Id) = E_Package
25678 and then Is_Generic_Instance (Pack_Id)
25679 and then not Has_Visible_State (Pack_Id)
25683 -- All other cases require Part_Of
25687 ("indicator Part_Of is required in this context "
25688 & "(SPARK RM 7.2.6(2))", Item_Id);
25689 Error_Msg_Name_1 := Chars (Pack_Id);
25691 ("\& is declared in the private part of package %", Item_Id);
25694 end Check_Missing_Part_Of;
25696 ---------------------------------------------------
25697 -- Check_Postcondition_Use_In_Inlined_Subprogram --
25698 ---------------------------------------------------
25700 procedure Check_Postcondition_Use_In_Inlined_Subprogram
25702 Spec_Id : Entity_Id)
25705 if Warn_On_Redundant_Constructs
25706 and then Has_Pragma_Inline_Always (Spec_Id)
25708 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
25710 if From_Aspect_Specification (Prag) then
25712 ("aspect % not enforced on inlined subprogram &?r?",
25713 Corresponding_Aspect (Prag), Spec_Id);
25716 ("pragma % not enforced on inlined subprogram &?r?",
25720 end Check_Postcondition_Use_In_Inlined_Subprogram;
25722 -------------------------------------
25723 -- Check_State_And_Constituent_Use --
25724 -------------------------------------
25726 procedure Check_State_And_Constituent_Use
25727 (States : Elist_Id;
25728 Constits : Elist_Id;
25731 function Find_Encapsulating_State
25732 (Constit_Id : Entity_Id) return Entity_Id;
25733 -- Given the entity of a constituent, try to find a corresponding
25734 -- encapsulating state that appears in the same context. The routine
25735 -- returns Empty is no such state is found.
25737 ------------------------------
25738 -- Find_Encapsulating_State --
25739 ------------------------------
25741 function Find_Encapsulating_State
25742 (Constit_Id : Entity_Id) return Entity_Id
25744 State_Id : Entity_Id;
25747 -- Since a constituent may be part of a larger constituent set, climb
25748 -- the encapsulated state chain looking for a state that appears in
25749 -- the same context.
25751 State_Id := Encapsulating_State (Constit_Id);
25752 while Present (State_Id) loop
25753 if Contains (States, State_Id) then
25757 State_Id := Encapsulating_State (State_Id);
25761 end Find_Encapsulating_State;
25765 Constit_Elmt : Elmt_Id;
25766 Constit_Id : Entity_Id;
25767 State_Id : Entity_Id;
25769 -- Start of processing for Check_State_And_Constituent_Use
25772 -- Nothing to do if there are no states or constituents
25774 if No (States) or else No (Constits) then
25778 -- Inspect the list of constituents and try to determine whether its
25779 -- encapsulating state is in list States.
25781 Constit_Elmt := First_Elmt (Constits);
25782 while Present (Constit_Elmt) loop
25783 Constit_Id := Node (Constit_Elmt);
25785 -- Determine whether the constituent is part of an encapsulating
25786 -- state that appears in the same context and if this is the case,
25787 -- emit an error (SPARK RM 7.2.6(7)).
25789 State_Id := Find_Encapsulating_State (Constit_Id);
25791 if Present (State_Id) then
25792 Error_Msg_Name_1 := Chars (Constit_Id);
25794 ("cannot mention state & and its constituent % in the same "
25795 & "context", Context, State_Id);
25799 Next_Elmt (Constit_Elmt);
25801 end Check_State_And_Constituent_Use;
25803 ---------------------------------------
25804 -- Collect_Subprogram_Inputs_Outputs --
25805 ---------------------------------------
25807 procedure Collect_Subprogram_Inputs_Outputs
25808 (Subp_Id : Entity_Id;
25809 Synthesize : Boolean := False;
25810 Subp_Inputs : in out Elist_Id;
25811 Subp_Outputs : in out Elist_Id;
25812 Global_Seen : out Boolean)
25814 procedure Collect_Dependency_Clause (Clause : Node_Id);
25815 -- Collect all relevant items from a dependency clause
25817 procedure Collect_Global_List
25819 Mode : Name_Id := Name_Input);
25820 -- Collect all relevant items from a global list
25822 -------------------------------
25823 -- Collect_Dependency_Clause --
25824 -------------------------------
25826 procedure Collect_Dependency_Clause (Clause : Node_Id) is
25827 procedure Collect_Dependency_Item
25829 Is_Input : Boolean);
25830 -- Add an item to the proper subprogram input or output collection
25832 -----------------------------
25833 -- Collect_Dependency_Item --
25834 -----------------------------
25836 procedure Collect_Dependency_Item
25838 Is_Input : Boolean)
25843 -- Nothing to collect when the item is null
25845 if Nkind (Item) = N_Null then
25848 -- Ditto for attribute 'Result
25850 elsif Is_Attribute_Result (Item) then
25853 -- Multiple items appear as an aggregate
25855 elsif Nkind (Item) = N_Aggregate then
25856 Extra := First (Expressions (Item));
25857 while Present (Extra) loop
25858 Collect_Dependency_Item (Extra, Is_Input);
25862 -- Otherwise this is a solitary item
25866 Add_Item (Item, Subp_Inputs);
25868 Add_Item (Item, Subp_Outputs);
25871 end Collect_Dependency_Item;
25873 -- Start of processing for Collect_Dependency_Clause
25876 if Nkind (Clause) = N_Null then
25879 -- A dependency cause appears as component association
25881 elsif Nkind (Clause) = N_Component_Association then
25882 Collect_Dependency_Item
25883 (Item => Expression (Clause),
25886 Collect_Dependency_Item
25887 (Item => First (Choices (Clause)),
25888 Is_Input => False);
25890 -- To accomodate partial decoration of disabled SPARK features, this
25891 -- routine may be called with illegal input. If this is the case, do
25892 -- not raise Program_Error.
25897 end Collect_Dependency_Clause;
25899 -------------------------
25900 -- Collect_Global_List --
25901 -------------------------
25903 procedure Collect_Global_List
25905 Mode : Name_Id := Name_Input)
25907 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
25908 -- Add an item to the proper subprogram input or output collection
25910 -------------------------
25911 -- Collect_Global_Item --
25912 -------------------------
25914 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
25916 if Nam_In (Mode, Name_In_Out, Name_Input) then
25917 Add_Item (Item, Subp_Inputs);
25920 if Nam_In (Mode, Name_In_Out, Name_Output) then
25921 Add_Item (Item, Subp_Outputs);
25923 end Collect_Global_Item;
25930 -- Start of processing for Collect_Global_List
25933 if Nkind (List) = N_Null then
25936 -- Single global item declaration
25938 elsif Nkind_In (List, N_Expanded_Name,
25940 N_Selected_Component)
25942 Collect_Global_Item (List, Mode);
25944 -- Simple global list or moded global list declaration
25946 elsif Nkind (List) = N_Aggregate then
25947 if Present (Expressions (List)) then
25948 Item := First (Expressions (List));
25949 while Present (Item) loop
25950 Collect_Global_Item (Item, Mode);
25955 Assoc := First (Component_Associations (List));
25956 while Present (Assoc) loop
25957 Collect_Global_List
25958 (List => Expression (Assoc),
25959 Mode => Chars (First (Choices (Assoc))));
25964 -- To accomodate partial decoration of disabled SPARK features, this
25965 -- routine may be called with illegal input. If this is the case, do
25966 -- not raise Program_Error.
25971 end Collect_Global_List;
25975 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
25976 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
25980 Formal : Entity_Id;
25984 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25987 Global_Seen := False;
25989 -- Process all [generic] formal parameters
25991 Formal := First_Entity (Spec_Id);
25992 while Present (Formal) loop
25993 if Ekind_In (Formal, E_Generic_In_Parameter,
25994 E_In_Out_Parameter,
25997 Add_Item (Formal, Subp_Inputs);
26000 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
26001 E_In_Out_Parameter,
26004 Add_Item (Formal, Subp_Outputs);
26006 -- Out parameters can act as inputs when the related type is
26007 -- tagged, unconstrained array, unconstrained record or record
26008 -- with unconstrained components.
26010 if Ekind (Formal) = E_Out_Parameter
26011 and then Is_Unconstrained_Or_Tagged_Item (Formal)
26013 Add_Item (Formal, Subp_Inputs);
26017 Next_Entity (Formal);
26020 -- When processing a subprogram body, look for pragmas Refined_Depends
26021 -- and Refined_Global as they specify the inputs and outputs.
26023 if Ekind (Subp_Id) = E_Subprogram_Body then
26024 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
26025 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
26027 -- Subprogram declaration or stand alone body case, look for pragmas
26028 -- Depends and Global
26031 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26032 Global := Get_Pragma (Spec_Id, Pragma_Global);
26035 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
26036 -- because it provides finer granularity of inputs and outputs.
26038 if Present (Global) then
26039 Global_Seen := True;
26040 List := Expression (Get_Argument (Global, Spec_Id));
26042 -- The pragma may not have been analyzed because of the arbitrary
26043 -- declaration order of aspects. Make sure that it is analyzed for
26044 -- the purposes of item extraction.
26046 if not Analyzed (List) then
26047 if Pragma_Name (Global) = Name_Refined_Global then
26048 Analyze_Refined_Global_In_Decl_Part (Global);
26050 Analyze_Global_In_Decl_Part (Global);
26054 Collect_Global_List (List);
26056 -- When the related subprogram lacks pragma [Refined_]Global, fall back
26057 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
26058 -- the inputs and outputs from [Refined_]Depends.
26060 elsif Synthesize and then Present (Depends) then
26061 Clauses := Expression (Get_Argument (Depends, Spec_Id));
26063 -- Multiple dependency clauses appear as an aggregate
26065 if Nkind (Clauses) = N_Aggregate then
26066 Clause := First (Component_Associations (Clauses));
26067 while Present (Clause) loop
26068 Collect_Dependency_Clause (Clause);
26072 -- Otherwise this is a single dependency clause
26075 Collect_Dependency_Clause (Clauses);
26078 end Collect_Subprogram_Inputs_Outputs;
26080 ---------------------------------
26081 -- Delay_Config_Pragma_Analyze --
26082 ---------------------------------
26084 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
26086 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
26087 Name_Priority_Specific_Dispatching);
26088 end Delay_Config_Pragma_Analyze;
26090 -----------------------
26091 -- Duplication_Error --
26092 -----------------------
26094 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
26095 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
26096 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
26099 Error_Msg_Sloc := Sloc (Prev);
26100 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
26102 -- Emit a precise message to distinguish between source pragmas and
26103 -- pragmas generated from aspects. The ordering of the two pragmas is
26107 -- Prag -- duplicate
26109 -- No error is emitted when both pragmas come from aspects because this
26110 -- is already detected by the general aspect analysis mechanism.
26112 if Prag_From_Asp and Prev_From_Asp then
26114 elsif Prag_From_Asp then
26115 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
26116 elsif Prev_From_Asp then
26117 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
26119 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
26121 end Duplication_Error;
26123 ----------------------------------
26124 -- Find_Related_Package_Or_Body --
26125 ----------------------------------
26127 function Find_Related_Package_Or_Body
26129 Do_Checks : Boolean := False) return Node_Id
26131 Context : constant Node_Id := Parent (Prag);
26132 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26136 Stmt := Prev (Prag);
26137 while Present (Stmt) loop
26139 -- Skip prior pragmas, but check for duplicates
26141 if Nkind (Stmt) = N_Pragma then
26142 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
26148 -- Skip internally generated code
26150 elsif not Comes_From_Source (Stmt) then
26151 if Nkind (Stmt) = N_Subprogram_Declaration then
26153 -- The subprogram declaration is an internally generated spec
26154 -- for an expression function.
26156 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
26159 -- The subprogram is actually an instance housed within an
26160 -- anonymous wrapper package.
26162 elsif Present (Generic_Parent (Specification (Stmt))) then
26167 -- Return the current source construct which is illegal
26176 -- If we fall through, then the pragma was either the first declaration
26177 -- or it was preceded by other pragmas and no source constructs.
26179 -- The pragma is associated with a package. The immediate context in
26180 -- this case is the specification of the package.
26182 if Nkind (Context) = N_Package_Specification then
26183 return Parent (Context);
26185 -- The pragma appears in the declarations of a package body
26187 elsif Nkind (Context) = N_Package_Body then
26190 -- The pragma appears in the statements of a package body
26192 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
26193 and then Nkind (Parent (Context)) = N_Package_Body
26195 return Parent (Context);
26197 -- The pragma is a byproduct of aspect expansion, return the related
26198 -- context of the original aspect. This case has a lower priority as
26199 -- the above circuitry pinpoints precisely the related context.
26201 elsif Present (Corresponding_Aspect (Prag)) then
26202 return Parent (Corresponding_Aspect (Prag));
26204 -- No candidate packge [body] found
26209 end Find_Related_Package_Or_Body;
26211 -------------------------------------
26212 -- Find_Related_Subprogram_Or_Body --
26213 -------------------------------------
26215 function Find_Related_Subprogram_Or_Body
26217 Do_Checks : Boolean := False) return Node_Id
26219 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
26221 procedure Expression_Function_Error;
26222 -- Emit an error concerning pragma Prag that illegaly applies to an
26223 -- expression function.
26225 -------------------------------
26226 -- Expression_Function_Error --
26227 -------------------------------
26229 procedure Expression_Function_Error is
26231 Error_Msg_Name_1 := Prag_Nam;
26233 -- Emit a precise message to distinguish between source pragmas and
26234 -- pragmas generated from aspects.
26236 if From_Aspect_Specification (Prag) then
26238 ("aspect % cannot apply to a stand alone expression function",
26242 ("pragma % cannot apply to a stand alone expression function",
26245 end Expression_Function_Error;
26249 Context : constant Node_Id := Parent (Prag);
26252 Look_For_Body : constant Boolean :=
26253 Nam_In (Prag_Nam, Name_Refined_Depends,
26254 Name_Refined_Global,
26255 Name_Refined_Post);
26256 -- Refinement pragmas must be associated with a subprogram body [stub]
26258 -- Start of processing for Find_Related_Subprogram_Or_Body
26261 Stmt := Prev (Prag);
26262 while Present (Stmt) loop
26264 -- Skip prior pragmas, but check for duplicates. Pragmas produced
26265 -- by splitting a complex pre/postcondition are not considered to
26268 if Nkind (Stmt) = N_Pragma then
26270 and then not Split_PPC (Stmt)
26271 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
26278 -- Emit an error when a refinement pragma appears on an expression
26279 -- function without a completion.
26282 and then Look_For_Body
26283 and then Nkind (Stmt) = N_Subprogram_Declaration
26284 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
26285 and then not Has_Completion (Defining_Entity (Stmt))
26287 Expression_Function_Error;
26290 -- The refinement pragma applies to a subprogram body stub
26292 elsif Look_For_Body
26293 and then Nkind (Stmt) = N_Subprogram_Body_Stub
26297 -- Skip internally generated code
26299 elsif not Comes_From_Source (Stmt) then
26300 if Nkind (Stmt) = N_Subprogram_Declaration then
26302 -- The subprogram declaration is an internally generated spec
26303 -- for an expression function.
26305 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
26308 -- The subprogram is actually an instance housed within an
26309 -- anonymous wrapper package.
26311 elsif Present (Generic_Parent (Specification (Stmt))) then
26316 -- Return the current construct which is either a subprogram body,
26317 -- a subprogram declaration or is illegal.
26326 -- If we fall through, then the pragma was either the first declaration
26327 -- or it was preceded by other pragmas and no source constructs.
26329 -- The pragma is associated with a library-level subprogram
26331 if Nkind (Context) = N_Compilation_Unit_Aux then
26332 return Unit (Parent (Context));
26334 -- The pragma appears inside the statements of a subprogram body. This
26335 -- placement is the result of subprogram contract expansion.
26337 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
26338 return Parent (Context);
26340 -- The pragma appears inside the declarative part of a subprogram body
26342 elsif Nkind (Context) = N_Subprogram_Body then
26345 -- The pragma is a byproduct of aspect expansion, return the related
26346 -- context of the original aspect. This case has a lower priority as
26347 -- the above circuitry pinpoints precisely the related context.
26349 elsif Present (Corresponding_Aspect (Prag)) then
26350 return Parent (Corresponding_Aspect (Prag));
26352 -- No candidate subprogram [body] found
26357 end Find_Related_Subprogram_Or_Body;
26363 function Get_Argument
26365 Context_Id : Entity_Id := Empty) return Node_Id
26367 Args : constant List_Id := Pragma_Argument_Associations (Prag);
26370 -- Use the expression of the original aspect when compiling for ASIS or
26371 -- when analyzing the template of a generic unit. In both cases the
26372 -- aspect's tree must be decorated to allow for ASIS queries or to save
26373 -- the global references in the generic context.
26375 if From_Aspect_Specification (Prag)
26376 and then (ASIS_Mode or else (Present (Context_Id)
26377 and then Is_Generic_Unit (Context_Id)))
26379 return Corresponding_Aspect (Prag);
26381 -- Otherwise use the expression of the pragma
26383 elsif Present (Args) then
26384 return First (Args);
26391 -------------------------
26392 -- Get_Base_Subprogram --
26393 -------------------------
26395 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
26396 Result : Entity_Id;
26399 -- Follow subprogram renaming chain
26403 if Is_Subprogram (Result)
26405 Nkind (Parent (Declaration_Node (Result))) =
26406 N_Subprogram_Renaming_Declaration
26407 and then Present (Alias (Result))
26409 Result := Alias (Result);
26413 end Get_Base_Subprogram;
26415 -----------------------
26416 -- Get_SPARK_Mode_Type --
26417 -----------------------
26419 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
26421 if N = Name_On then
26423 elsif N = Name_Off then
26426 -- Any other argument is illegal
26429 raise Program_Error;
26431 end Get_SPARK_Mode_Type;
26433 --------------------------------
26434 -- Get_SPARK_Mode_From_Pragma --
26435 --------------------------------
26437 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is
26442 pragma Assert (Nkind (N) = N_Pragma);
26443 Args := Pragma_Argument_Associations (N);
26445 -- Extract the mode from the argument list
26447 if Present (Args) then
26448 Mode := First (Pragma_Argument_Associations (N));
26449 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode)));
26451 -- If SPARK_Mode pragma has no argument, default is ON
26456 end Get_SPARK_Mode_From_Pragma;
26458 ---------------------------
26459 -- Has_Extra_Parentheses --
26460 ---------------------------
26462 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
26466 -- The aggregate should not have an expression list because a clause
26467 -- is always interpreted as a component association. The only way an
26468 -- expression list can sneak in is by adding extra parentheses around
26469 -- the individual clauses:
26471 -- Depends (Output => Input) -- proper form
26472 -- Depends ((Output => Input)) -- extra parentheses
26474 -- Since the extra parentheses are not allowed by the syntax of the
26475 -- pragma, flag them now to avoid emitting misleading errors down the
26478 if Nkind (Clause) = N_Aggregate
26479 and then Present (Expressions (Clause))
26481 Expr := First (Expressions (Clause));
26482 while Present (Expr) loop
26484 -- A dependency clause surrounded by extra parentheses appears
26485 -- as an aggregate of component associations with an optional
26486 -- Paren_Count set.
26488 if Nkind (Expr) = N_Aggregate
26489 and then Present (Component_Associations (Expr))
26492 ("dependency clause contains extra parentheses", Expr);
26494 -- Otherwise the expression is a malformed construct
26497 SPARK_Msg_N ("malformed dependency clause", Expr);
26507 end Has_Extra_Parentheses;
26513 procedure Initialize is
26524 Dummy := Dummy + 1;
26527 -----------------------------
26528 -- Is_Config_Static_String --
26529 -----------------------------
26531 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
26533 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
26534 -- This is an internal recursive function that is just like the outer
26535 -- function except that it adds the string to the name buffer rather
26536 -- than placing the string in the name buffer.
26538 ------------------------------
26539 -- Add_Config_Static_String --
26540 ------------------------------
26542 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
26549 if Nkind (N) = N_Op_Concat then
26550 if Add_Config_Static_String (Left_Opnd (N)) then
26551 N := Right_Opnd (N);
26557 if Nkind (N) /= N_String_Literal then
26558 Error_Msg_N ("string literal expected for pragma argument", N);
26562 for J in 1 .. String_Length (Strval (N)) loop
26563 C := Get_String_Char (Strval (N), J);
26565 if not In_Character_Range (C) then
26567 ("string literal contains invalid wide character",
26568 Sloc (N) + 1 + Source_Ptr (J));
26572 Add_Char_To_Name_Buffer (Get_Character (C));
26577 end Add_Config_Static_String;
26579 -- Start of processing for Is_Config_Static_String
26584 return Add_Config_Static_String (Arg);
26585 end Is_Config_Static_String;
26587 -------------------------------
26588 -- Is_Elaboration_SPARK_Mode --
26589 -------------------------------
26591 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
26594 (Nkind (N) = N_Pragma
26595 and then Pragma_Name (N) = Name_SPARK_Mode
26596 and then Is_List_Member (N));
26598 -- Pragma SPARK_Mode affects the elaboration of a package body when it
26599 -- appears in the statement part of the body.
26602 Present (Parent (N))
26603 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
26604 and then List_Containing (N) = Statements (Parent (N))
26605 and then Present (Parent (Parent (N)))
26606 and then Nkind (Parent (Parent (N))) = N_Package_Body;
26607 end Is_Elaboration_SPARK_Mode;
26609 -----------------------------------------
26610 -- Is_Non_Significant_Pragma_Reference --
26611 -----------------------------------------
26613 -- This function makes use of the following static table which indicates
26614 -- whether appearance of some name in a given pragma is to be considered
26615 -- as a reference for the purposes of warnings about unreferenced objects.
26617 -- -1 indicates that appearence in any argument is significant
26618 -- 0 indicates that appearance in any argument is not significant
26619 -- +n indicates that appearance as argument n is significant, but all
26620 -- other arguments are not significant
26621 -- 9n arguments from n on are significant, before n inisignificant
26623 Sig_Flags : constant array (Pragma_Id) of Int :=
26624 (Pragma_Abort_Defer => -1,
26625 Pragma_Abstract_State => -1,
26626 Pragma_Ada_83 => -1,
26627 Pragma_Ada_95 => -1,
26628 Pragma_Ada_05 => -1,
26629 Pragma_Ada_2005 => -1,
26630 Pragma_Ada_12 => -1,
26631 Pragma_Ada_2012 => -1,
26632 Pragma_All_Calls_Remote => -1,
26633 Pragma_Allow_Integer_Address => -1,
26634 Pragma_Annotate => 93,
26635 Pragma_Assert => -1,
26636 Pragma_Assert_And_Cut => -1,
26637 Pragma_Assertion_Policy => 0,
26638 Pragma_Assume => -1,
26639 Pragma_Assume_No_Invalid_Values => 0,
26640 Pragma_Async_Readers => 0,
26641 Pragma_Async_Writers => 0,
26642 Pragma_Asynchronous => 0,
26643 Pragma_Atomic => 0,
26644 Pragma_Atomic_Components => 0,
26645 Pragma_Attach_Handler => -1,
26646 Pragma_Attribute_Definition => 92,
26647 Pragma_Check => -1,
26648 Pragma_Check_Float_Overflow => 0,
26649 Pragma_Check_Name => 0,
26650 Pragma_Check_Policy => 0,
26651 Pragma_CIL_Constructor => 0,
26652 Pragma_CPP_Class => 0,
26653 Pragma_CPP_Constructor => 0,
26654 Pragma_CPP_Virtual => 0,
26655 Pragma_CPP_Vtable => 0,
26657 Pragma_C_Pass_By_Copy => 0,
26658 Pragma_Comment => -1,
26659 Pragma_Common_Object => 0,
26660 Pragma_Compile_Time_Error => -1,
26661 Pragma_Compile_Time_Warning => -1,
26662 Pragma_Compiler_Unit => -1,
26663 Pragma_Compiler_Unit_Warning => -1,
26664 Pragma_Complete_Representation => 0,
26665 Pragma_Complex_Representation => 0,
26666 Pragma_Component_Alignment => 0,
26667 Pragma_Contract_Cases => -1,
26668 Pragma_Controlled => 0,
26669 Pragma_Convention => 0,
26670 Pragma_Convention_Identifier => 0,
26671 Pragma_Debug => -1,
26672 Pragma_Debug_Policy => 0,
26673 Pragma_Detect_Blocking => 0,
26674 Pragma_Default_Initial_Condition => -1,
26675 Pragma_Default_Scalar_Storage_Order => 0,
26676 Pragma_Default_Storage_Pool => 0,
26677 Pragma_Depends => -1,
26678 Pragma_Disable_Atomic_Synchronization => 0,
26679 Pragma_Discard_Names => 0,
26680 Pragma_Dispatching_Domain => -1,
26681 Pragma_Effective_Reads => 0,
26682 Pragma_Effective_Writes => 0,
26683 Pragma_Elaborate => 0,
26684 Pragma_Elaborate_All => 0,
26685 Pragma_Elaborate_Body => 0,
26686 Pragma_Elaboration_Checks => 0,
26687 Pragma_Eliminate => 0,
26688 Pragma_Enable_Atomic_Synchronization => 0,
26689 Pragma_Export => -1,
26690 Pragma_Export_Function => -1,
26691 Pragma_Export_Object => -1,
26692 Pragma_Export_Procedure => -1,
26693 Pragma_Export_Value => -1,
26694 Pragma_Export_Valued_Procedure => -1,
26695 Pragma_Extend_System => -1,
26696 Pragma_Extensions_Allowed => 0,
26697 Pragma_Extensions_Visible => 0,
26698 Pragma_External => -1,
26699 Pragma_Favor_Top_Level => 0,
26700 Pragma_External_Name_Casing => 0,
26701 Pragma_Fast_Math => 0,
26702 Pragma_Finalize_Storage_Only => 0,
26704 Pragma_Global => -1,
26705 Pragma_Ident => -1,
26706 Pragma_Ignore_Pragma => 0,
26707 Pragma_Implementation_Defined => -1,
26708 Pragma_Implemented => -1,
26709 Pragma_Implicit_Packing => 0,
26710 Pragma_Import => 93,
26711 Pragma_Import_Function => 0,
26712 Pragma_Import_Object => 0,
26713 Pragma_Import_Procedure => 0,
26714 Pragma_Import_Valued_Procedure => 0,
26715 Pragma_Independent => 0,
26716 Pragma_Independent_Components => 0,
26717 Pragma_Initial_Condition => -1,
26718 Pragma_Initialize_Scalars => 0,
26719 Pragma_Initializes => -1,
26720 Pragma_Inline => 0,
26721 Pragma_Inline_Always => 0,
26722 Pragma_Inline_Generic => 0,
26723 Pragma_Inspection_Point => -1,
26724 Pragma_Interface => 92,
26725 Pragma_Interface_Name => 0,
26726 Pragma_Interrupt_Handler => -1,
26727 Pragma_Interrupt_Priority => -1,
26728 Pragma_Interrupt_State => -1,
26729 Pragma_Invariant => -1,
26730 Pragma_Java_Constructor => -1,
26731 Pragma_Java_Interface => -1,
26732 Pragma_Keep_Names => 0,
26733 Pragma_License => 0,
26734 Pragma_Link_With => -1,
26735 Pragma_Linker_Alias => -1,
26736 Pragma_Linker_Constructor => -1,
26737 Pragma_Linker_Destructor => -1,
26738 Pragma_Linker_Options => -1,
26739 Pragma_Linker_Section => 0,
26741 Pragma_Lock_Free => 0,
26742 Pragma_Locking_Policy => 0,
26743 Pragma_Loop_Invariant => -1,
26744 Pragma_Loop_Optimize => 0,
26745 Pragma_Loop_Variant => -1,
26746 Pragma_Machine_Attribute => -1,
26748 Pragma_Main_Storage => -1,
26749 Pragma_Memory_Size => 0,
26750 Pragma_No_Return => 0,
26751 Pragma_No_Body => 0,
26752 Pragma_No_Elaboration_Code_All => 0,
26753 Pragma_No_Inline => 0,
26754 Pragma_No_Run_Time => -1,
26755 Pragma_No_Strict_Aliasing => -1,
26756 Pragma_No_Tagged_Streams => 0,
26757 Pragma_Normalize_Scalars => 0,
26758 Pragma_Obsolescent => 0,
26759 Pragma_Optimize => 0,
26760 Pragma_Optimize_Alignment => 0,
26761 Pragma_Overflow_Mode => 0,
26762 Pragma_Overriding_Renamings => 0,
26763 Pragma_Ordered => 0,
26766 Pragma_Part_Of => 0,
26767 Pragma_Partition_Elaboration_Policy => 0,
26768 Pragma_Passive => 0,
26769 Pragma_Persistent_BSS => 0,
26770 Pragma_Polling => 0,
26771 Pragma_Prefix_Exception_Messages => 0,
26773 Pragma_Postcondition => -1,
26774 Pragma_Post_Class => -1,
26776 Pragma_Precondition => -1,
26777 Pragma_Predicate => -1,
26778 Pragma_Preelaborable_Initialization => -1,
26779 Pragma_Preelaborate => 0,
26780 Pragma_Pre_Class => -1,
26781 Pragma_Priority => -1,
26782 Pragma_Priority_Specific_Dispatching => 0,
26783 Pragma_Profile => 0,
26784 Pragma_Profile_Warnings => 0,
26785 Pragma_Propagate_Exceptions => 0,
26786 Pragma_Provide_Shift_Operators => 0,
26787 Pragma_Psect_Object => 0,
26789 Pragma_Pure_Function => 0,
26790 Pragma_Queuing_Policy => 0,
26791 Pragma_Rational => 0,
26792 Pragma_Ravenscar => 0,
26793 Pragma_Refined_Depends => -1,
26794 Pragma_Refined_Global => -1,
26795 Pragma_Refined_Post => -1,
26796 Pragma_Refined_State => -1,
26797 Pragma_Relative_Deadline => 0,
26798 Pragma_Remote_Access_Type => -1,
26799 Pragma_Remote_Call_Interface => -1,
26800 Pragma_Remote_Types => -1,
26801 Pragma_Restricted_Run_Time => 0,
26802 Pragma_Restriction_Warnings => 0,
26803 Pragma_Restrictions => 0,
26804 Pragma_Reviewable => -1,
26805 Pragma_Short_Circuit_And_Or => 0,
26806 Pragma_Share_Generic => 0,
26807 Pragma_Shared => 0,
26808 Pragma_Shared_Passive => 0,
26809 Pragma_Short_Descriptors => 0,
26810 Pragma_Simple_Storage_Pool_Type => 0,
26811 Pragma_Source_File_Name => 0,
26812 Pragma_Source_File_Name_Project => 0,
26813 Pragma_Source_Reference => 0,
26814 Pragma_SPARK_Mode => 0,
26815 Pragma_Storage_Size => -1,
26816 Pragma_Storage_Unit => 0,
26817 Pragma_Static_Elaboration_Desired => 0,
26818 Pragma_Stream_Convert => 0,
26819 Pragma_Style_Checks => 0,
26820 Pragma_Subtitle => 0,
26821 Pragma_Suppress => 0,
26822 Pragma_Suppress_Exception_Locations => 0,
26823 Pragma_Suppress_All => 0,
26824 Pragma_Suppress_Debug_Info => 0,
26825 Pragma_Suppress_Initialization => 0,
26826 Pragma_System_Name => 0,
26827 Pragma_Task_Dispatching_Policy => 0,
26828 Pragma_Task_Info => -1,
26829 Pragma_Task_Name => -1,
26830 Pragma_Task_Storage => -1,
26831 Pragma_Test_Case => -1,
26832 Pragma_Thread_Local_Storage => -1,
26833 Pragma_Time_Slice => -1,
26835 Pragma_Type_Invariant => -1,
26836 Pragma_Type_Invariant_Class => -1,
26837 Pragma_Unchecked_Union => 0,
26838 Pragma_Unimplemented_Unit => 0,
26839 Pragma_Universal_Aliasing => 0,
26840 Pragma_Universal_Data => 0,
26841 Pragma_Unmodified => 0,
26842 Pragma_Unreferenced => 0,
26843 Pragma_Unreferenced_Objects => 0,
26844 Pragma_Unreserve_All_Interrupts => 0,
26845 Pragma_Unsuppress => 0,
26846 Pragma_Unevaluated_Use_Of_Old => 0,
26847 Pragma_Use_VADS_Size => 0,
26848 Pragma_Validity_Checks => 0,
26849 Pragma_Volatile => 0,
26850 Pragma_Volatile_Components => 0,
26851 Pragma_Volatile_Full_Access => 0,
26852 Pragma_Warning_As_Error => 0,
26853 Pragma_Warnings => 0,
26854 Pragma_Weak_External => 0,
26855 Pragma_Wide_Character_Encoding => 0,
26856 Unknown_Pragma => 0);
26858 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
26864 function Arg_No return Nat;
26865 -- Returns an integer showing what argument we are in. A value of
26866 -- zero means we are not in any of the arguments.
26872 function Arg_No return Nat is
26877 A := First (Pragma_Argument_Associations (Parent (P)));
26891 -- Start of processing for Non_Significant_Pragma_Reference
26896 if Nkind (P) /= N_Pragma_Argument_Association then
26900 Id := Get_Pragma_Id (Parent (P));
26901 C := Sig_Flags (Id);
26916 return AN < (C - 90);
26922 end Is_Non_Significant_Pragma_Reference;
26924 ------------------------------
26925 -- Is_Pragma_String_Literal --
26926 ------------------------------
26928 -- This function returns true if the corresponding pragma argument is a
26929 -- static string expression. These are the only cases in which string
26930 -- literals can appear as pragma arguments. We also allow a string literal
26931 -- as the first argument to pragma Assert (although it will of course
26932 -- always generate a type error).
26934 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
26935 Pragn : constant Node_Id := Parent (Par);
26936 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
26937 Pname : constant Name_Id := Pragma_Name (Pragn);
26943 N := First (Assoc);
26950 if Pname = Name_Assert then
26953 elsif Pname = Name_Export then
26956 elsif Pname = Name_Ident then
26959 elsif Pname = Name_Import then
26962 elsif Pname = Name_Interface_Name then
26965 elsif Pname = Name_Linker_Alias then
26968 elsif Pname = Name_Linker_Section then
26971 elsif Pname = Name_Machine_Attribute then
26974 elsif Pname = Name_Source_File_Name then
26977 elsif Pname = Name_Source_Reference then
26980 elsif Pname = Name_Title then
26983 elsif Pname = Name_Subtitle then
26989 end Is_Pragma_String_Literal;
26991 ---------------------------
26992 -- Is_Private_SPARK_Mode --
26993 ---------------------------
26995 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
26998 (Nkind (N) = N_Pragma
26999 and then Pragma_Name (N) = Name_SPARK_Mode
27000 and then Is_List_Member (N));
27002 -- For pragma SPARK_Mode to be private, it has to appear in the private
27003 -- declarations of a package.
27006 Present (Parent (N))
27007 and then Nkind (Parent (N)) = N_Package_Specification
27008 and then List_Containing (N) = Private_Declarations (Parent (N));
27009 end Is_Private_SPARK_Mode;
27011 -------------------------------------
27012 -- Is_Unconstrained_Or_Tagged_Item --
27013 -------------------------------------
27015 function Is_Unconstrained_Or_Tagged_Item
27016 (Item : Entity_Id) return Boolean
27018 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
27019 -- Determine whether record type Typ has at least one unconstrained
27022 ---------------------------------
27023 -- Has_Unconstrained_Component --
27024 ---------------------------------
27026 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
27030 Comp := First_Component (Typ);
27031 while Present (Comp) loop
27032 if Is_Unconstrained_Or_Tagged_Item (Comp) then
27036 Next_Component (Comp);
27040 end Has_Unconstrained_Component;
27044 Typ : constant Entity_Id := Etype (Item);
27046 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
27049 if Is_Tagged_Type (Typ) then
27052 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
27055 elsif Is_Record_Type (Typ) then
27056 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
27059 return Has_Unconstrained_Component (Typ);
27062 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
27068 end Is_Unconstrained_Or_Tagged_Item;
27070 -----------------------------
27071 -- Is_Valid_Assertion_Kind --
27072 -----------------------------
27074 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
27081 Name_Static_Predicate |
27082 Name_Dynamic_Predicate |
27087 Name_Type_Invariant |
27088 Name_uType_Invariant |
27092 Name_Assert_And_Cut |
27094 Name_Contract_Cases |
27096 Name_Default_Initial_Condition |
27098 Name_Initial_Condition |
27101 Name_Loop_Invariant |
27102 Name_Loop_Variant |
27103 Name_Postcondition |
27104 Name_Precondition |
27106 Name_Refined_Post |
27107 Name_Statement_Assertions => return True;
27109 when others => return False;
27111 end Is_Valid_Assertion_Kind;
27113 --------------------------------------
27114 -- Process_Compilation_Unit_Pragmas --
27115 --------------------------------------
27117 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
27119 -- A special check for pragma Suppress_All, a very strange DEC pragma,
27120 -- strange because it comes at the end of the unit. Rational has the
27121 -- same name for a pragma, but treats it as a program unit pragma, In
27122 -- GNAT we just decide to allow it anywhere at all. If it appeared then
27123 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
27124 -- node, and we insert a pragma Suppress (All_Checks) at the start of
27125 -- the context clause to ensure the correct processing.
27127 if Has_Pragma_Suppress_All (N) then
27128 Prepend_To (Context_Items (N),
27129 Make_Pragma (Sloc (N),
27130 Chars => Name_Suppress,
27131 Pragma_Argument_Associations => New_List (
27132 Make_Pragma_Argument_Association (Sloc (N),
27133 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
27136 -- Nothing else to do at the current time
27138 end Process_Compilation_Unit_Pragmas;
27140 ------------------------------------
27141 -- Record_Possible_Body_Reference --
27142 ------------------------------------
27144 procedure Record_Possible_Body_Reference
27145 (State_Id : Entity_Id;
27149 Spec_Id : Entity_Id;
27152 -- Ensure that we are dealing with a reference to a state
27154 pragma Assert (Ekind (State_Id) = E_Abstract_State);
27156 -- Climb the tree starting from the reference looking for a package body
27157 -- whose spec declares the referenced state. This criteria automatically
27158 -- excludes references in package specs which are legal. Note that it is
27159 -- not wise to emit an error now as the package body may lack pragma
27160 -- Refined_State or the referenced state may not be mentioned in the
27161 -- refinement. This approach avoids the generation of misleading errors.
27164 while Present (Context) loop
27165 if Nkind (Context) = N_Package_Body then
27166 Spec_Id := Corresponding_Spec (Context);
27168 if Present (Abstract_States (Spec_Id))
27169 and then Contains (Abstract_States (Spec_Id), State_Id)
27171 if No (Body_References (State_Id)) then
27172 Set_Body_References (State_Id, New_Elmt_List);
27175 Append_Elmt (Ref, To => Body_References (State_Id));
27180 Context := Parent (Context);
27182 end Record_Possible_Body_Reference;
27184 ------------------------------
27185 -- Relocate_Pragmas_To_Body --
27186 ------------------------------
27188 procedure Relocate_Pragmas_To_Body
27189 (Subp_Body : Node_Id;
27190 Target_Body : Node_Id := Empty)
27192 procedure Relocate_Pragma (Prag : Node_Id);
27193 -- Remove a single pragma from its current list and add it to the
27194 -- declarations of the proper body (either Subp_Body or Target_Body).
27196 ---------------------
27197 -- Relocate_Pragma --
27198 ---------------------
27200 procedure Relocate_Pragma (Prag : Node_Id) is
27205 -- When subprogram stubs or expression functions are involves, the
27206 -- destination declaration list belongs to the proper body.
27208 if Present (Target_Body) then
27209 Target := Target_Body;
27211 Target := Subp_Body;
27214 Decls := Declarations (Target);
27218 Set_Declarations (Target, Decls);
27221 -- Unhook the pragma from its current list
27224 Prepend (Prag, Decls);
27225 end Relocate_Pragma;
27229 Body_Id : constant Entity_Id :=
27230 Defining_Unit_Name (Specification (Subp_Body));
27231 Next_Stmt : Node_Id;
27234 -- Start of processing for Relocate_Pragmas_To_Body
27237 -- Do not process a body that comes from a separate unit as no construct
27238 -- can possibly follow it.
27240 if not Is_List_Member (Subp_Body) then
27243 -- Do not relocate pragmas that follow a stub if the stub does not have
27246 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
27247 and then No (Target_Body)
27251 -- Do not process internally generated routine _Postconditions
27253 elsif Ekind (Body_Id) = E_Procedure
27254 and then Chars (Body_Id) = Name_uPostconditions
27259 -- Look at what is following the body. We are interested in certain kind
27260 -- of pragmas (either from source or byproducts of expansion) that can
27261 -- apply to a body [stub].
27263 Stmt := Next (Subp_Body);
27264 while Present (Stmt) loop
27266 -- Preserve the following statement for iteration purposes due to a
27267 -- possible relocation of a pragma.
27269 Next_Stmt := Next (Stmt);
27271 -- Move a candidate pragma following the body to the declarations of
27274 if Nkind (Stmt) = N_Pragma
27275 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
27277 Relocate_Pragma (Stmt);
27279 -- Skip internally generated code
27281 elsif not Comes_From_Source (Stmt) then
27284 -- No candidate pragmas are available for relocation
27292 end Relocate_Pragmas_To_Body;
27294 -------------------
27295 -- Resolve_State --
27296 -------------------
27298 procedure Resolve_State (N : Node_Id) is
27303 if Is_Entity_Name (N) and then Present (Entity (N)) then
27304 Func := Entity (N);
27306 -- Handle overloading of state names by functions. Traverse the
27307 -- homonym chain looking for an abstract state.
27309 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
27310 State := Homonym (Func);
27311 while Present (State) loop
27313 -- Resolve the overloading by setting the proper entity of the
27314 -- reference to that of the state.
27316 if Ekind (State) = E_Abstract_State then
27317 Set_Etype (N, Standard_Void_Type);
27318 Set_Entity (N, State);
27319 Set_Associated_Node (N, State);
27323 State := Homonym (State);
27326 -- A function can never act as a state. If the homonym chain does
27327 -- not contain a corresponding state, then something went wrong in
27328 -- the overloading mechanism.
27330 raise Program_Error;
27335 ----------------------------
27336 -- Rewrite_Assertion_Kind --
27337 ----------------------------
27339 procedure Rewrite_Assertion_Kind (N : Node_Id) is
27343 if Nkind (N) = N_Attribute_Reference
27344 and then Attribute_Name (N) = Name_Class
27345 and then Nkind (Prefix (N)) = N_Identifier
27347 case Chars (Prefix (N)) is
27352 when Name_Type_Invariant =>
27353 Nam := Name_uType_Invariant;
27354 when Name_Invariant =>
27355 Nam := Name_uInvariant;
27360 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
27362 end Rewrite_Assertion_Kind;
27370 Dummy := Dummy + 1;
27373 --------------------------------
27374 -- Set_Encoded_Interface_Name --
27375 --------------------------------
27377 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
27378 Str : constant String_Id := Strval (S);
27379 Len : constant Int := String_Length (Str);
27384 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
27387 -- Stores encoded value of character code CC. The encoding we use an
27388 -- underscore followed by four lower case hex digits.
27394 procedure Encode is
27396 Store_String_Char (Get_Char_Code ('_'));
27398 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
27400 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
27402 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
27404 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
27407 -- Start of processing for Set_Encoded_Interface_Name
27410 -- If first character is asterisk, this is a link name, and we leave it
27411 -- completely unmodified. We also ignore null strings (the latter case
27412 -- happens only in error cases) and no encoding should occur for Java or
27413 -- AAMP interface names.
27416 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
27417 or else VM_Target /= No_VM
27418 or else AAMP_On_Target
27420 Set_Interface_Name (E, S);
27425 CC := Get_String_Char (Str, J);
27427 exit when not In_Character_Range (CC);
27429 C := Get_Character (CC);
27431 exit when C /= '_' and then C /= '$'
27432 and then C not in '0' .. '9'
27433 and then C not in 'a' .. 'z'
27434 and then C not in 'A' .. 'Z';
27437 Set_Interface_Name (E, S);
27445 -- Here we need to encode. The encoding we use as follows:
27446 -- three underscores + four hex digits (lower case)
27450 for J in 1 .. String_Length (Str) loop
27451 CC := Get_String_Char (Str, J);
27453 if not In_Character_Range (CC) then
27456 C := Get_Character (CC);
27458 if C = '_' or else C = '$'
27459 or else C in '0' .. '9'
27460 or else C in 'a' .. 'z'
27461 or else C in 'A' .. 'Z'
27463 Store_String_Char (CC);
27470 Set_Interface_Name (E,
27471 Make_String_Literal (Sloc (S),
27472 Strval => End_String));
27474 end Set_Encoded_Interface_Name;
27476 ------------------------
27477 -- Set_Elab_Unit_Name --
27478 ------------------------
27480 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
27485 if Nkind (N) = N_Identifier
27486 and then Nkind (With_Item) = N_Identifier
27488 Set_Entity (N, Entity (With_Item));
27490 elsif Nkind (N) = N_Selected_Component then
27491 Change_Selected_Component_To_Expanded_Name (N);
27492 Set_Entity (N, Entity (With_Item));
27493 Set_Entity (Selector_Name (N), Entity (N));
27495 Pref := Prefix (N);
27496 Scop := Scope (Entity (N));
27497 while Nkind (Pref) = N_Selected_Component loop
27498 Change_Selected_Component_To_Expanded_Name (Pref);
27499 Set_Entity (Selector_Name (Pref), Scop);
27500 Set_Entity (Pref, Scop);
27501 Pref := Prefix (Pref);
27502 Scop := Scope (Scop);
27505 Set_Entity (Pref, Scop);
27508 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
27509 end Set_Elab_Unit_Name;
27511 -------------------
27512 -- Test_Case_Arg --
27513 -------------------
27515 function Test_Case_Arg
27518 From_Aspect : Boolean := False) return Node_Id
27520 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
27525 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
27530 -- The caller requests the aspect argument
27532 if From_Aspect then
27533 if Present (Aspect)
27534 and then Nkind (Expression (Aspect)) = N_Aggregate
27536 Args := Expression (Aspect);
27538 -- "Name" and "Mode" may appear without an identifier as a
27539 -- positional association.
27541 if Present (Expressions (Args)) then
27542 Arg := First (Expressions (Args));
27544 if Present (Arg) and then Arg_Nam = Name_Name then
27552 if Present (Arg) and then Arg_Nam = Name_Mode then
27557 -- Some or all arguments may appear as component associatons
27559 if Present (Component_Associations (Args)) then
27560 Arg := First (Component_Associations (Args));
27561 while Present (Arg) loop
27562 if Chars (First (Choices (Arg))) = Arg_Nam then
27571 -- Otherwise retrieve the argument directly from the pragma
27574 Arg := First (Pragma_Argument_Associations (Prag));
27576 if Present (Arg) and then Arg_Nam = Name_Name then
27580 -- Skip argument "Name"
27584 if Present (Arg) and then Arg_Nam = Name_Mode then
27588 -- Skip argument "Mode"
27592 -- Arguments "Requires" and "Ensures" are optional and may not be
27595 while Present (Arg) loop
27596 if Chars (Arg) = Arg_Nam then