1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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;
45 with Lib.Writ; use Lib.Writ;
46 with Lib.Xref; use Lib.Xref;
47 with Namet.Sp; use Namet.Sp;
48 with Nlists; use Nlists;
49 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_VFpt; use Sem_VFpt;
73 with Sem_Warn; use Sem_Warn;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput; use Sinput;
78 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
81 with Targparm; use Targparm;
82 with Tbuild; use Tbuild;
84 with Uintp; use Uintp;
85 with Uname; use Uname;
86 with Urealp; use Urealp;
87 with Validsw; use Validsw;
88 with Warnsw; use Warnsw;
90 package body Sem_Prag is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all upper case letters for OpenVMS versions of GNAT, and to all
130 -- lower case letters for all other versions
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
171 -- Subsidiary routine to the analysis of pragmas Depends, Global and
172 -- Refined_State. Append an entity to a list. If the list is empty, create
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
184 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
185 -- whether a particular item appears in a mixed list of nodes and entities.
186 -- It is assumed that all nodes in the list have entities.
188 function Check_Kind (Nam : Name_Id) return Name_Id;
189 -- This function is used in connection with pragmas Assert, Check,
190 -- and assertion aspects and pragmas, to determine if Check pragmas
191 -- (or corresponding assertion aspects or pragmas) are currently active
192 -- as determined by the presence of -gnata on the command line (which
193 -- sets the default), and the appearance of pragmas Check_Policy and
194 -- Assertion_Policy as configuration pragmas either in a configuration
195 -- pragma file, or at the start of the current unit, or locally given
196 -- Check_Policy and Assertion_Policy pragmas that are currently active.
198 -- The value returned is one of the names Check, Ignore, Disable (On
199 -- returns Check, and Off returns Ignore).
201 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
202 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
203 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
204 -- _Post, _Invariant, or _Type_Invariant, which are special names used
205 -- in identifiers to represent these attribute references.
207 procedure Collect_Global_Items
209 In_Items : in out Elist_Id;
210 In_Out_Items : in out Elist_Id;
211 Out_Items : in out Elist_Id;
212 Has_In_State : out Boolean;
213 Has_In_Out_State : out Boolean;
214 Has_Out_State : out Boolean;
215 Has_Null_State : out Boolean);
216 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
217 -- Prag denotes pragma [Refined_]Global. Gather all input, in out and
218 -- output items of Prag in lists In_Items, In_Out_Items and Out_Items.
219 -- Flags Has_In_State, Has_In_Out_State and Has_Out_State are set when
220 -- there is at least one abstract state with visible refinement available
221 -- in the corresponding mode. Flag Has_Null_State is set when at least
222 -- state has a null refinement.
224 procedure Collect_Subprogram_Inputs_Outputs
225 (Subp_Id : Entity_Id;
226 Subp_Inputs : in out Elist_Id;
227 Subp_Outputs : in out Elist_Id;
228 Global_Seen : out Boolean);
229 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends
230 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id
231 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram
232 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen
233 -- is set when the related subprogram has pragma [Refined_]Global.
235 function Find_Related_Subprogram_Or_Body
237 Do_Checks : Boolean := False) return Node_Id;
238 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
239 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
240 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
241 -- Do_Checks is set, the routine reports duplicate pragmas and detects
242 -- improper use of refinement pragmas in stand alone expression functions.
243 -- The returned value depends on the related pragma as follows:
244 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
245 -- N_Subprogram_Declaration node or if the pragma applies to a stand
246 -- alone body, the N_Subprogram_Body node or Empty if illegal.
247 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
248 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type
263 Ancestor : Entity_Id) return Boolean;
264 -- Subsidiary to the processing of pragma Refined_Depends and pragma
265 -- Refined_Global. Determine whether abstract state State is part of an
266 -- ancestor abstract state Ancestor. For this relationship to hold, State
267 -- must have option Part_Of in its Abstract_State definition.
269 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
276 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
277 -- of a Test_Case pragma if present (possibly Empty). We treat these as
278 -- spec expressions (i.e. similar to a default expression).
280 procedure Record_Possible_Body_Reference
282 Item_Id : Entity_Id);
283 -- Given an entity reference (Item) and the corresponding Entity (Item_Id),
284 -- determines if we have a body reference to an abstract state, which may
285 -- be illegal if the state is refined within the body.
287 procedure Rewrite_Assertion_Kind (N : Node_Id);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
291 -- Check, Check_Policy.
293 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
294 -- Place semantic information on the argument of an Elaborate/Elaborate_All
295 -- pragma. Entity name for unit and its parents is taken from item in
296 -- previous with_clause that mentions the unit.
299 -- This is a dummy function called by the processing for pragma Reviewable.
300 -- It is there for assisting front end debugging. By placing a Reviewable
301 -- pragma in the source program, a breakpoint on rv catches this place in
302 -- the source, allowing convenient stepping to the point of interest.
308 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
311 To_List := New_Elmt_List;
314 Append_Elmt (Item, To_List);
317 -------------------------------
318 -- Adjust_External_Name_Case --
319 -------------------------------
321 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
325 -- Adjust case of literal if required
327 if Opt.External_Name_Exp_Casing = As_Is then
331 -- Copy existing string
337 for J in 1 .. String_Length (Strval (N)) loop
338 CC := Get_String_Char (Strval (N), J);
340 if Opt.External_Name_Exp_Casing = Uppercase
341 and then CC >= Get_Char_Code ('a')
342 and then CC <= Get_Char_Code ('z')
344 Store_String_Char (CC - 32);
346 elsif Opt.External_Name_Exp_Casing = Lowercase
347 and then CC >= Get_Char_Code ('A')
348 and then CC <= Get_Char_Code ('Z')
350 Store_String_Char (CC + 32);
353 Store_String_Char (CC);
358 Make_String_Literal (Sloc (N),
359 Strval => End_String);
361 end Adjust_External_Name_Case;
363 -----------------------------------------
364 -- Analyze_Contract_Cases_In_Decl_Part --
365 -----------------------------------------
367 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
368 Others_Seen : Boolean := False;
370 procedure Analyze_Contract_Case (CCase : Node_Id);
371 -- Verify the legality of a single contract case
373 ---------------------------
374 -- Analyze_Contract_Case --
375 ---------------------------
377 procedure Analyze_Contract_Case (CCase : Node_Id) is
378 Case_Guard : Node_Id;
380 Extra_Guard : Node_Id;
383 if Nkind (CCase) = N_Component_Association then
384 Case_Guard := First (Choices (CCase));
385 Conseq := Expression (CCase);
387 -- Each contract case must have exactly one case guard
389 Extra_Guard := Next (Case_Guard);
391 if Present (Extra_Guard) then
393 ("contract case may have only one case guard", Extra_Guard);
396 -- Check the placement of "others" (if available)
398 if Nkind (Case_Guard) = N_Others_Choice then
401 ("only one others choice allowed in aspect Contract_Cases",
407 elsif Others_Seen then
409 ("others must be the last choice in aspect Contract_Cases",
413 -- Preanalyze the case guard and consequence
415 if Nkind (Case_Guard) /= N_Others_Choice then
416 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
419 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
421 -- The contract case is malformed
424 Error_Msg_N ("wrong syntax in contract case", CCase);
426 end Analyze_Contract_Case;
435 Restore_Scope : Boolean := False;
436 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
438 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
443 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
444 Subp_Id := Defining_Entity (Subp_Decl);
445 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
447 -- Multiple contract cases appear in aggregate form
449 if Nkind (All_Cases) = N_Aggregate then
450 if No (Component_Associations (All_Cases)) then
451 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
453 -- Individual contract cases appear as component associations
456 -- Ensure that the formal parameters are visible when analyzing
457 -- all clauses. This falls out of the general rule of aspects
458 -- pertaining to subprogram declarations. Skip the installation
459 -- for subprogram bodies because the formals are already visible.
461 if not In_Open_Scopes (Subp_Id) then
462 Restore_Scope := True;
463 Push_Scope (Subp_Id);
464 Install_Formals (Subp_Id);
467 CCase := First (Component_Associations (All_Cases));
468 while Present (CCase) loop
469 Analyze_Contract_Case (CCase);
473 if Restore_Scope then
479 Error_Msg_N ("wrong syntax for aspect Contract_Cases", N);
481 end Analyze_Contract_Cases_In_Decl_Part;
483 ----------------------------------
484 -- Analyze_Depends_In_Decl_Part --
485 ----------------------------------
487 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
488 Loc : constant Source_Ptr := Sloc (N);
490 All_Inputs_Seen : Elist_Id := No_Elist;
491 -- A list containing the entities of all the inputs processed so far.
492 -- The list is populated with unique entities because the same input
493 -- may appear in multiple input lists.
495 All_Outputs_Seen : Elist_Id := No_Elist;
496 -- A list containing the entities of all the outputs processed so far.
497 -- The list is populated with unique entities because output items are
498 -- unique in a dependence relation.
500 Global_Seen : Boolean := False;
501 -- A flag set when pragma Global has been processed
503 Null_Output_Seen : Boolean := False;
504 -- A flag used to track the legality of a null output
506 Result_Seen : Boolean := False;
507 -- A flag set when Subp_Id'Result is processed
510 -- The entity of the subprogram subject to pragma [Refined_]Depends
513 -- The entity of the subprogram [body or stub] subject to pragma
514 -- [Refined_]Depends.
516 Subp_Inputs : Elist_Id := No_Elist;
517 Subp_Outputs : Elist_Id := No_Elist;
518 -- Two lists containing the full set of inputs and output of the related
519 -- subprograms. Note that these lists contain both nodes and entities.
521 procedure Analyze_Dependency_Clause
524 -- Verify the legality of a single dependency clause. Flag Is_Last
525 -- denotes whether Clause is the last clause in the relation.
527 procedure Check_Function_Return;
528 -- Verify that Funtion'Result appears as one of the outputs
535 -- Ensure that an item has a proper IN, IN OUT, or OUT mode depending
536 -- on its function. If this is not the case, emit an error. Item and
537 -- Item_Id denote the attributes of an item. Flag Is_Input should be set
538 -- when item comes from an input list. Flag Self_Ref should be set when
539 -- the item is an output and the dependency clause has operator "+".
541 procedure Check_Usage
542 (Subp_Items : Elist_Id;
543 Used_Items : Elist_Id;
545 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
546 -- error if this is not the case.
548 procedure Normalize_Clause (Clause : Node_Id);
549 -- Remove a self-dependency "+" from the input list of a clause. Split
550 -- a clause with multiple outputs into multiple clauses with a single
553 -------------------------------
554 -- Analyze_Dependency_Clause --
555 -------------------------------
557 procedure Analyze_Dependency_Clause
561 procedure Analyze_Input_List (Inputs : Node_Id);
562 -- Verify the legality of a single input list
564 procedure Analyze_Input_Output
569 Seen : in out Elist_Id;
570 Null_Seen : in out Boolean;
571 Non_Null_Seen : in out Boolean);
572 -- Verify the legality of a single input or output item. Flag
573 -- Is_Input should be set whenever Item is an input, False when it
574 -- denotes an output. Flag Self_Ref should be set when the item is an
575 -- output and the dependency clause has a "+". Flag Top_Level should
576 -- be set whenever Item appears immediately within an input or output
577 -- list. Seen is a collection of all abstract states, variables and
578 -- formals processed so far. Flag Null_Seen denotes whether a null
579 -- input or output has been encountered. Flag Non_Null_Seen denotes
580 -- whether a non-null input or output has been encountered.
582 ------------------------
583 -- Analyze_Input_List --
584 ------------------------
586 procedure Analyze_Input_List (Inputs : Node_Id) is
587 Inputs_Seen : Elist_Id := No_Elist;
588 -- A list containing the entities of all inputs that appear in the
589 -- current input list.
591 Non_Null_Input_Seen : Boolean := False;
592 Null_Input_Seen : Boolean := False;
593 -- Flags used to check the legality of an input list
598 -- Multiple inputs appear as an aggregate
600 if Nkind (Inputs) = N_Aggregate then
601 if Present (Component_Associations (Inputs)) then
603 ("nested dependency relations not allowed", Inputs);
605 elsif Present (Expressions (Inputs)) then
606 Input := First (Expressions (Inputs));
607 while Present (Input) loop
614 Null_Seen => Null_Input_Seen,
615 Non_Null_Seen => Non_Null_Input_Seen);
621 Error_Msg_N ("malformed input dependency list", Inputs);
624 -- Process a solitary input
633 Null_Seen => Null_Input_Seen,
634 Non_Null_Seen => Non_Null_Input_Seen);
637 -- Detect an illegal dependency clause of the form
641 if Null_Output_Seen and then Null_Input_Seen then
643 ("null dependency clause cannot have a null input list",
646 end Analyze_Input_List;
648 --------------------------
649 -- Analyze_Input_Output --
650 --------------------------
652 procedure Analyze_Input_Output
657 Seen : in out Elist_Id;
658 Null_Seen : in out Boolean;
659 Non_Null_Seen : in out Boolean)
661 Is_Output : constant Boolean := not Is_Input;
666 -- Multiple input or output items appear as an aggregate
668 if Nkind (Item) = N_Aggregate then
669 if not Top_Level then
670 Error_Msg_N ("nested grouping of items not allowed", Item);
672 elsif Present (Component_Associations (Item)) then
674 ("nested dependency relations not allowed", Item);
676 -- Recursively analyze the grouped items
678 elsif Present (Expressions (Item)) then
679 Grouped := First (Expressions (Item));
680 while Present (Grouped) loop
683 Is_Input => Is_Input,
684 Self_Ref => Self_Ref,
687 Null_Seen => Null_Seen,
688 Non_Null_Seen => Non_Null_Seen);
694 Error_Msg_N ("malformed dependency list", Item);
697 -- Process Function'Result in the context of a dependency clause
699 elsif Is_Attribute_Result (Item) then
700 Non_Null_Seen := True;
702 -- It is sufficent to analyze the prefix of 'Result in order to
703 -- establish legality of the attribute.
705 Analyze (Prefix (Item));
707 -- The prefix of 'Result must denote the function for which
708 -- pragma Depends applies.
710 if not Is_Entity_Name (Prefix (Item))
711 or else Ekind (Spec_Id) /= E_Function
712 or else Entity (Prefix (Item)) /= Spec_Id
714 Error_Msg_Name_1 := Name_Result;
716 ("prefix of attribute % must denote the enclosing "
719 -- Function'Result is allowed to appear on the output side of a
720 -- dependency clause.
723 Error_Msg_N ("function result cannot act as input", Item);
727 ("cannot mix null and non-null dependency items", Item);
733 -- Detect multiple uses of null in a single dependency list or
734 -- throughout the whole relation. Verify the placement of a null
735 -- output list relative to the other clauses.
737 elsif Nkind (Item) = N_Null then
740 ("multiple null dependency relations not allowed", Item);
742 elsif Non_Null_Seen then
744 ("cannot mix null and non-null dependency items", Item);
752 ("null output list must be the last clause in a "
753 & "dependency relation", Item);
755 -- Catch a useless dependence of the form:
760 ("useless dependence, null depends on itself", Item);
768 Non_Null_Seen := True;
771 Error_Msg_N ("cannot mix null and non-null items", Item);
776 -- Find the entity of the item. If this is a renaming, climb
777 -- the renaming chain to reach the root object. Renamings of
778 -- non-entire objects do not yield an entity (Empty).
780 Item_Id := Entity_Of (Item);
782 Record_Possible_Body_Reference (Item, Item_Id);
784 if Present (Item_Id) then
785 if Ekind_In (Item_Id, E_Abstract_State,
791 -- Ensure that the item is of the correct mode depending
794 Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
796 -- Detect multiple uses of the same state, variable or
797 -- formal parameter. If this is not the case, add the
798 -- item to the list of processed relations.
800 if Contains (Seen, Item_Id) then
801 Error_Msg_N ("duplicate use of item", Item);
803 Add_Item (Item_Id, Seen);
806 -- Detect illegal use of an input related to a null
807 -- output. Such input items cannot appear in other
811 and then Null_Output_Seen
812 and then Contains (All_Inputs_Seen, Item_Id)
815 ("input of a null output list appears in multiple "
816 & "input lists", Item);
819 -- Add an input or a self-referential output to the list
820 -- of all processed inputs.
822 if Is_Input or else Self_Ref then
823 Add_Item (Item_Id, All_Inputs_Seen);
826 if Ekind (Item_Id) = E_Abstract_State then
828 -- The state acts as a constituent of some other
829 -- state. Ensure that the other state is a proper
830 -- ancestor of the item.
832 if Present (Refined_State (Item_Id)) then
834 (Item_Id, Refined_State (Item_Id))
837 Chars (Refined_State (Item_Id));
839 ("state & is not a valid constituent of "
840 & "ancestor state %", Item, Item_Id);
844 -- An abstract state with visible refinement cannot
845 -- appear in pragma [Refined_]Global as its place must
846 -- be taken by some of its constituents.
848 elsif Has_Visible_Refinement (Item_Id) then
850 ("cannot mention state & in global refinement, "
851 & "use its constituents instead", Item, Item_Id);
856 -- When the item renames an entire object, replace the
857 -- item with a reference to the object.
859 if Present (Renamed_Object (Entity (Item))) then
861 New_Reference_To (Item_Id, Sloc (Item)));
865 -- All other input/output items are illegal
869 ("item must denote variable, state or formal "
870 & "parameter", Item);
873 -- All other input/output items are illegal
877 ("item must denote variable, state or formal parameter",
881 end Analyze_Input_Output;
889 Non_Null_Output_Seen : Boolean := False;
890 -- Flag used to check the legality of an output list
892 -- Start of processing for Analyze_Dependency_Clause
895 Inputs := Expression (Clause);
898 -- An input list with a self-dependency appears as operator "+" where
899 -- the actuals inputs are the right operand.
901 if Nkind (Inputs) = N_Op_Plus then
902 Inputs := Right_Opnd (Inputs);
906 -- Process the output_list of a dependency_clause
908 Output := First (Choices (Clause));
909 while Present (Output) loop
913 Self_Ref => Self_Ref,
915 Seen => All_Outputs_Seen,
916 Null_Seen => Null_Output_Seen,
917 Non_Null_Seen => Non_Null_Output_Seen);
922 -- Process the input_list of a dependency_clause
924 Analyze_Input_List (Inputs);
925 end Analyze_Dependency_Clause;
927 ----------------------------
928 -- Check_Function_Return --
929 ----------------------------
931 procedure Check_Function_Return is
933 if Ekind (Spec_Id) = E_Function and then not Result_Seen then
935 ("result of & must appear in exactly one output list",
938 end Check_Function_Return;
955 -- IN and IN OUT parameters already have the proper mode to act
956 -- as input. OUT parameters are valid inputs only when their type
957 -- is unconstrained or tagged as their discriminants, array bouns
958 -- or tags can be read. In general, states and variables are
959 -- considered to have mode IN OUT unless they are classified by
960 -- pragma [Refined_]Global. In that case, the item must appear in
961 -- an input global list.
963 if (Ekind (Item_Id) = E_Out_Parameter
964 and then not Is_Unconstrained_Or_Tagged_Item (Item_Id))
966 (Global_Seen and then not Appears_In (Subp_Inputs, Item_Id))
969 ("item & must have mode IN or `IN OUT`", Item, Item_Id);
972 -- Self-referential output
976 -- In general, states and variables are considered to have mode
977 -- IN OUT unless they are explicitly moded by pragma [Refined_]
978 -- Global. If this is the case, then the item must appear in both
979 -- an input and output global list.
981 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
984 (Appears_In (Subp_Inputs, Item_Id)
986 Appears_In (Subp_Outputs, Item_Id))
989 ("item & must have mode `IN OUT`", Item, Item_Id);
992 -- A self-referential OUT parameter of an unconstrained or tagged
993 -- type acts as an input because the discriminants, array bounds
994 -- or the tag may be read. Note that the presence of [Refined_]
995 -- Global is not significant here because the item is a parameter.
997 elsif Ekind (Item_Id) = E_Out_Parameter
998 and then Is_Unconstrained_Or_Tagged_Item (Item_Id)
1002 -- The remaining cases are IN, IN OUT, and OUT parameters. To
1003 -- qualify as self-referential item, the parameter must be of
1006 elsif Ekind (Item_Id) /= E_In_Out_Parameter then
1007 Error_Msg_NE ("item & must have mode `IN OUT`", Item, Item_Id);
1012 -- IN OUT and OUT parameters already have the proper mode to act as
1013 -- output. In general, states and variables are considered to have
1014 -- mode IN OUT unless they are moded by pragma [Refined_]Global. In
1015 -- that case, the item must appear in an output global list.
1017 elsif Ekind (Item_Id) = E_In_Parameter
1019 (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id))
1022 ("item & must have mode OUT or `IN OUT`", Item, Item_Id);
1030 procedure Check_Usage
1031 (Subp_Items : Elist_Id;
1032 Used_Items : Elist_Id;
1035 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
1036 -- Emit an error concerning the erroneous usage of an item
1042 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1046 ("item & must appear in at least one input list of aspect "
1047 & "Depends", Item, Item_Id);
1050 ("item & must appear in exactly one output list of aspect "
1051 & "Depends", Item, Item_Id);
1059 Item_Id : Entity_Id;
1061 -- Start of processing for Check_Usage
1064 if No (Subp_Items) then
1068 -- Each input or output of the subprogram must appear in a dependency
1071 Elmt := First_Elmt (Subp_Items);
1072 while Present (Elmt) loop
1073 Item := Node (Elmt);
1075 if Nkind (Item) = N_Defining_Identifier then
1078 Item_Id := Entity (Item);
1081 -- The item does not appear in a dependency
1083 if not Contains (Used_Items, Item_Id) then
1084 if Is_Formal (Item_Id) then
1085 Usage_Error (Item, Item_Id);
1087 -- States and global variables are not used properly only when
1088 -- the subprogram is subject to pragma Global.
1090 elsif Global_Seen then
1091 Usage_Error (Item, Item_Id);
1099 ----------------------
1100 -- Normalize_Clause --
1101 ----------------------
1103 procedure Normalize_Clause (Clause : Node_Id) is
1104 procedure Create_Or_Modify_Clause
1110 Multiple : Boolean);
1111 -- Create a brand new clause to represent the self-reference or
1112 -- modify the input and/or output lists of an existing clause. Output
1113 -- denotes a self-referencial output. Outputs is the output list of a
1114 -- clause. Inputs is the input list of a clause. After denotes the
1115 -- clause after which the new clause is to be inserted. Flag In_Place
1116 -- should be set when normalizing the last output of an output list.
1117 -- Flag Multiple should be set when Output comes from a list with
1120 procedure Split_Multiple_Outputs;
1121 -- If Clause contains more than one output, split the clause into
1122 -- multiple clauses with a single output. All new clauses are added
1125 -----------------------------
1126 -- Create_Or_Modify_Clause --
1127 -----------------------------
1129 procedure Create_Or_Modify_Clause
1137 procedure Propagate_Output
1140 -- Handle the various cases of output propagation to the input
1141 -- list. Output denotes a self-referencial output item. Inputs is
1142 -- the input list of a clause.
1144 ----------------------
1145 -- Propagate_Output --
1146 ----------------------
1148 procedure Propagate_Output
1152 function In_Input_List
1154 Inputs : List_Id) return Boolean;
1155 -- Determine whether a particulat item appears in the input
1156 -- list of a clause.
1162 function In_Input_List
1164 Inputs : List_Id) return Boolean
1169 Elmt := First (Inputs);
1170 while Present (Elmt) loop
1171 if Entity_Of (Elmt) = Item then
1183 Output_Id : constant Entity_Id := Entity_Of (Output);
1186 -- Start of processing for Propagate_Output
1189 -- The clause is of the form:
1191 -- (Output =>+ null)
1193 -- Remove the null input and replace it with a copy of the
1196 -- (Output => Output)
1198 if Nkind (Inputs) = N_Null then
1199 Rewrite (Inputs, New_Copy_Tree (Output));
1201 -- The clause is of the form:
1203 -- (Output =>+ (Input1, ..., InputN))
1205 -- Determine whether the output is not already mentioned in the
1206 -- input list and if not, add it to the list of inputs:
1208 -- (Output => (Output, Input1, ..., InputN))
1210 elsif Nkind (Inputs) = N_Aggregate then
1211 Grouped := Expressions (Inputs);
1213 if not In_Input_List
1217 Prepend_To (Grouped, New_Copy_Tree (Output));
1220 -- The clause is of the form:
1222 -- (Output =>+ Input)
1224 -- If the input does not mention the output, group the two
1227 -- (Output => (Output, Input))
1229 elsif Entity_Of (Inputs) /= Output_Id then
1231 Make_Aggregate (Loc,
1232 Expressions => New_List (
1233 New_Copy_Tree (Output),
1234 New_Copy_Tree (Inputs))));
1236 end Propagate_Output;
1240 Loc : constant Source_Ptr := Sloc (Clause);
1241 New_Clause : Node_Id;
1243 -- Start of processing for Create_Or_Modify_Clause
1246 -- A null output depending on itself does not require any
1249 if Nkind (Output) = N_Null then
1252 -- A function result cannot depend on itself because it cannot
1253 -- appear in the input list of a relation.
1255 elsif Is_Attribute_Result (Output) then
1256 Error_Msg_N ("function result cannot depend on itself", Output);
1260 -- When performing the transformation in place, simply add the
1261 -- output to the list of inputs (if not already there). This case
1262 -- arises when dealing with the last output of an output list -
1263 -- we perform the normalization in place to avoid generating a
1267 Propagate_Output (Output, Inputs);
1269 -- A list with multiple outputs is slowly trimmed until only
1270 -- one element remains. When this happens, replace the
1271 -- aggregate with the element itself.
1275 Rewrite (Outputs, Output);
1281 -- Unchain the output from its output list as it will appear in
1282 -- a new clause. Note that we cannot simply rewrite the output
1283 -- as null because this will violate the semantics of pragma
1288 -- Generate a new clause of the form:
1289 -- (Output => Inputs)
1292 Make_Component_Association (Loc,
1293 Choices => New_List (Output),
1294 Expression => New_Copy_Tree (Inputs));
1296 -- The new clause contains replicated content that has already
1297 -- been analyzed. There is not need to reanalyze it or
1298 -- renormalize it again.
1300 Set_Analyzed (New_Clause);
1303 (Output => First (Choices (New_Clause)),
1304 Inputs => Expression (New_Clause));
1306 Insert_After (After, New_Clause);
1308 end Create_Or_Modify_Clause;
1310 ----------------------------
1311 -- Split_Multiple_Outputs --
1312 ----------------------------
1314 procedure Split_Multiple_Outputs is
1315 Inputs : constant Node_Id := Expression (Clause);
1316 Loc : constant Source_Ptr := Sloc (Clause);
1317 Outputs : constant Node_Id := First (Choices (Clause));
1318 Last_Output : Node_Id;
1319 Next_Output : Node_Id;
1323 -- Start of processing for Split_Multiple_Outputs
1326 -- Multiple outputs appear as an aggregate. Nothing to do when
1327 -- the clause has exactly one output.
1329 if Nkind (Outputs) = N_Aggregate then
1330 Last_Output := Last (Expressions (Outputs));
1332 -- Create a clause for each output. Note that each time a new
1333 -- clause is created, the original output list slowly shrinks
1334 -- until there is one item left.
1336 Output := First (Expressions (Outputs));
1337 while Present (Output) loop
1338 Next_Output := Next (Output);
1340 -- Unhook the output from the original output list as it
1341 -- will be relocated to a new clause.
1345 -- Special processing for the last output. At this point
1346 -- the original aggregate has been stripped down to one
1347 -- element. Replace the aggregate by the element itself.
1349 if Output = Last_Output then
1350 Rewrite (Outputs, Output);
1353 -- Generate a clause of the form:
1354 -- (Output => Inputs)
1357 Make_Component_Association (Loc,
1358 Choices => New_List (Output),
1359 Expression => New_Copy_Tree (Inputs));
1361 -- The new clause contains replicated content that has
1362 -- already been analyzed. There is not need to reanalyze
1365 Set_Analyzed (Split);
1366 Insert_After (Clause, Split);
1369 Output := Next_Output;
1372 end Split_Multiple_Outputs;
1376 Outputs : constant Node_Id := First (Choices (Clause));
1378 Last_Output : Node_Id;
1379 Next_Output : Node_Id;
1382 -- Start of processing for Normalize_Clause
1385 -- A self-dependency appears as operator "+". Remove the "+" from the
1386 -- tree by moving the real inputs to their proper place.
1388 if Nkind (Expression (Clause)) = N_Op_Plus then
1389 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1390 Inputs := Expression (Clause);
1392 -- Multiple outputs appear as an aggregate
1394 if Nkind (Outputs) = N_Aggregate then
1395 Last_Output := Last (Expressions (Outputs));
1397 Output := First (Expressions (Outputs));
1398 while Present (Output) loop
1400 -- Normalization may remove an output from its list,
1401 -- preserve the subsequent output now.
1403 Next_Output := Next (Output);
1405 Create_Or_Modify_Clause
1410 In_Place => Output = Last_Output,
1413 Output := Next_Output;
1419 Create_Or_Modify_Clause
1429 -- Split a clause with multiple outputs into multiple clauses with a
1432 Split_Multiple_Outputs;
1433 end Normalize_Clause;
1439 Last_Clause : Node_Id;
1440 Subp_Decl : Node_Id;
1442 Restore_Scope : Boolean := False;
1443 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1445 -- Start of processing for Analyze_Depends_In_Decl_Part
1450 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1451 Subp_Id := Defining_Entity (Subp_Decl);
1453 -- The logic in this routine is used to analyze both pragma Depends and
1454 -- pragma Refined_Depends since they have the same syntax and base
1455 -- semantics. Find the entity of the corresponding spec when analyzing
1458 if Nkind (Subp_Decl) = N_Subprogram_Body
1459 and then not Acts_As_Spec (Subp_Decl)
1461 Spec_Id := Corresponding_Spec (Subp_Decl);
1463 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1464 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1470 Clause := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1472 -- Empty dependency list
1474 if Nkind (Clause) = N_Null then
1476 -- Gather all states, variables and formal parameters that the
1477 -- subprogram may depend on. These items are obtained from the
1478 -- parameter profile or pragma [Refined_]Global (if available).
1480 Collect_Subprogram_Inputs_Outputs
1481 (Subp_Id => Subp_Id,
1482 Subp_Inputs => Subp_Inputs,
1483 Subp_Outputs => Subp_Outputs,
1484 Global_Seen => Global_Seen);
1486 -- Verify that every input or output of the subprogram appear in a
1489 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1490 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1491 Check_Function_Return;
1493 -- Dependency clauses appear as component associations of an aggregate
1495 elsif Nkind (Clause) = N_Aggregate
1496 and then Present (Component_Associations (Clause))
1498 Last_Clause := Last (Component_Associations (Clause));
1500 -- Gather all states, variables and formal parameters that the
1501 -- subprogram may depend on. These items are obtained from the
1502 -- parameter profile or pragma [Refined_]Global (if available).
1504 Collect_Subprogram_Inputs_Outputs
1505 (Subp_Id => Subp_Id,
1506 Subp_Inputs => Subp_Inputs,
1507 Subp_Outputs => Subp_Outputs,
1508 Global_Seen => Global_Seen);
1510 -- Ensure that the formal parameters are visible when analyzing all
1511 -- clauses. This falls out of the general rule of aspects pertaining
1512 -- to subprogram declarations. Skip the installation for subprogram
1513 -- bodies because the formals are already visible.
1515 if not In_Open_Scopes (Spec_Id) then
1516 Restore_Scope := True;
1517 Push_Scope (Spec_Id);
1518 Install_Formals (Spec_Id);
1521 Clause := First (Component_Associations (Clause));
1522 while Present (Clause) loop
1523 Errors := Serious_Errors_Detected;
1525 -- Normalization may create extra clauses that contain replicated
1526 -- input and output names. There is no need to reanalyze them.
1528 if not Analyzed (Clause) then
1529 Set_Analyzed (Clause);
1531 Analyze_Dependency_Clause
1533 Is_Last => Clause = Last_Clause);
1536 -- Do not normalize an erroneous clause because the inputs and/or
1537 -- outputs may denote illegal items.
1539 if Serious_Errors_Detected = Errors then
1540 Normalize_Clause (Clause);
1546 if Restore_Scope then
1550 -- Verify that every input or output of the subprogram appear in a
1553 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1554 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1555 Check_Function_Return;
1557 -- The top level dependency relation is malformed
1560 Error_Msg_N ("malformed dependency relation", Clause);
1562 end Analyze_Depends_In_Decl_Part;
1564 ---------------------------------
1565 -- Analyze_Global_In_Decl_Part --
1566 ---------------------------------
1568 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1569 Seen : Elist_Id := No_Elist;
1570 -- A list containing the entities of all the items processed so far. It
1571 -- plays a role in detecting distinct entities.
1573 Spec_Id : Entity_Id;
1574 -- The entity of the subprogram subject to pragma [Refined_]Global
1576 Subp_Id : Entity_Id;
1577 -- The entity of the subprogram [body or stub] subject to pragma
1578 -- [Refined_]Global.
1580 In_Out_Seen : Boolean := False;
1581 Input_Seen : Boolean := False;
1582 Output_Seen : Boolean := False;
1583 Proof_Seen : Boolean := False;
1584 -- Flags used to verify the consistency of modes
1586 procedure Analyze_Global_List
1588 Global_Mode : Name_Id := Name_Input);
1589 -- Verify the legality of a single global list declaration. Global_Mode
1590 -- denotes the current mode in effect.
1592 -------------------------
1593 -- Analyze_Global_List --
1594 -------------------------
1596 procedure Analyze_Global_List
1598 Global_Mode : Name_Id := Name_Input)
1600 procedure Analyze_Global_Item
1602 Global_Mode : Name_Id);
1603 -- Verify the legality of a single global item declaration.
1604 -- Global_Mode denotes the current mode in effect.
1606 procedure Check_Duplicate_Mode
1608 Status : in out Boolean);
1609 -- Flag Status denotes whether a particular mode has been seen while
1610 -- processing a global list. This routine verifies that Mode is not a
1611 -- duplicate mode and sets the flag Status.
1613 procedure Check_Mode_Restriction_In_Enclosing_Context
1615 Item_Id : Entity_Id);
1616 -- Verify that an item of mode In_Out or Output does not appear as an
1617 -- input in the Global aspect of an enclosing subprogram. If this is
1618 -- the case, emit an error. Item and Item_Id are respectively the
1619 -- item and its entity.
1621 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1622 -- Mode denotes either In_Out or Output. Depending on the kind of the
1623 -- related subprogram, emit an error if those two modes apply to a
1626 -------------------------
1627 -- Analyze_Global_Item --
1628 -------------------------
1630 procedure Analyze_Global_Item
1632 Global_Mode : Name_Id)
1634 Item_Id : Entity_Id;
1637 -- Detect one of the following cases
1639 -- with Global => (null, Name)
1640 -- with Global => (Name_1, null, Name_2)
1641 -- with Global => (Name, null)
1643 if Nkind (Item) = N_Null then
1644 Error_Msg_N ("cannot mix null and non-null global items", Item);
1650 -- Find the entity of the item. If this is a renaming, climb the
1651 -- renaming chain to reach the root object. Renamings of non-
1652 -- entire objects do not yield an entity (Empty).
1654 Item_Id := Entity_Of (Item);
1656 if Present (Item_Id) then
1657 Record_Possible_Body_Reference (Item, Item_Id);
1659 -- A global item may denote a formal parameter of an enclosing
1660 -- subprogram. Do this check first to provide a better error
1663 if Is_Formal (Item_Id) then
1664 if Scope (Item_Id) = Spec_Id then
1666 ("global item cannot reference formal parameter", Item);
1670 -- The only legal references are those to abstract states and
1673 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
1675 ("global item must denote variable or state", Item);
1679 if Ekind (Item_Id) = E_Abstract_State then
1681 -- The state acts as a constituent of some other state.
1682 -- Ensure that the other state is a proper ancestor of the
1685 if Present (Refined_State (Item_Id)) then
1686 if not Is_Part_Of (Item_Id, Refined_State (Item_Id)) then
1687 Error_Msg_Name_1 := Chars (Refined_State (Item_Id));
1689 ("state & is not a valid constituent of ancestor "
1690 & "state %", Item, Item_Id);
1694 -- An abstract state with visible refinement cannot appear
1695 -- in pragma [Refined_]Global as its place must be taken by
1696 -- some of its constituents.
1698 elsif Has_Visible_Refinement (Item_Id) then
1700 ("cannot mention state & in global refinement, use its "
1701 & "constituents instead", Item, Item_Id);
1706 -- When the item renames an entire object, replace the item
1707 -- with a reference to the object.
1709 if Present (Renamed_Object (Entity (Item))) then
1710 Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item)));
1714 -- Some form of illegal construct masquerading as a name
1717 Error_Msg_N ("global item must denote variable or state", Item);
1721 -- At this point we know that the global item is one of the two
1722 -- valid choices. Perform mode- and usage-specific checks.
1724 if Ekind (Item_Id) = E_Abstract_State
1725 and then Is_External_State (Item_Id)
1727 -- A global item of mode In_Out or Output cannot denote an
1728 -- external Input_Only state.
1730 if Is_Input_Only_State (Item_Id)
1731 and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
1734 ("global item of mode In_Out or Output cannot reference "
1735 & "External Input_Only state", Item);
1737 -- A global item of mode In_Out or Input cannot reference an
1738 -- external Output_Only state.
1740 elsif Is_Output_Only_State (Item_Id)
1741 and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
1744 ("global item of mode In_Out or Input cannot reference "
1745 & "External Output_Only state", Item);
1749 -- Verify that an output does not appear as an input in an
1750 -- enclosing subprogram.
1752 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
1753 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
1756 -- The same entity might be referenced through various way. Check
1757 -- the entity of the item rather than the item itself.
1759 if Contains (Seen, Item_Id) then
1760 Error_Msg_N ("duplicate global item", Item);
1762 -- Add the entity of the current item to the list of processed
1766 Add_Item (Item_Id, Seen);
1768 end Analyze_Global_Item;
1770 --------------------------
1771 -- Check_Duplicate_Mode --
1772 --------------------------
1774 procedure Check_Duplicate_Mode
1776 Status : in out Boolean)
1780 Error_Msg_N ("duplicate global mode", Mode);
1784 end Check_Duplicate_Mode;
1786 -------------------------------------------------
1787 -- Check_Mode_Restriction_In_Enclosing_Context --
1788 -------------------------------------------------
1790 procedure Check_Mode_Restriction_In_Enclosing_Context
1792 Item_Id : Entity_Id)
1794 Context : Entity_Id;
1796 Inputs : Elist_Id := No_Elist;
1797 Outputs : Elist_Id := No_Elist;
1800 -- Traverse the scope stack looking for enclosing subprograms
1801 -- subject to pragma [Refined_]Global.
1803 Context := Scope (Subp_Id);
1804 while Present (Context) and then Context /= Standard_Standard loop
1805 if Is_Subprogram (Context)
1806 and then Present (Get_Pragma (Context, Pragma_Global))
1808 Collect_Subprogram_Inputs_Outputs
1809 (Subp_Id => Context,
1810 Subp_Inputs => Inputs,
1811 Subp_Outputs => Outputs,
1812 Global_Seen => Dummy);
1814 -- The item is classified as In_Out or Output but appears as
1815 -- an Input in an enclosing subprogram.
1817 if Appears_In (Inputs, Item_Id)
1818 and then not Appears_In (Outputs, Item_Id)
1821 ("global item & cannot have mode In_Out or Output",
1824 ("\item already appears as input of subprogram &",
1827 -- Stop the traversal once an error has been detected
1833 Context := Scope (Context);
1835 end Check_Mode_Restriction_In_Enclosing_Context;
1837 ----------------------------------------
1838 -- Check_Mode_Restriction_In_Function --
1839 ----------------------------------------
1841 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
1843 if Ekind (Spec_Id) = E_Function then
1845 ("global mode & not applicable to functions", Mode);
1847 end Check_Mode_Restriction_In_Function;
1855 -- Start of processing for Analyze_Global_List
1858 if Nkind (List) = N_Null then
1859 Set_Analyzed (List);
1861 -- Single global item declaration
1863 elsif Nkind_In (List, N_Expanded_Name,
1865 N_Selected_Component)
1867 Analyze_Global_Item (List, Global_Mode);
1869 -- Simple global list or moded global list declaration
1871 elsif Nkind (List) = N_Aggregate then
1872 Set_Analyzed (List);
1874 -- The declaration of a simple global list appear as a collection
1877 if Present (Expressions (List)) then
1878 if Present (Component_Associations (List)) then
1880 ("cannot mix moded and non-moded global lists", List);
1883 Item := First (Expressions (List));
1884 while Present (Item) loop
1885 Analyze_Global_Item (Item, Global_Mode);
1890 -- The declaration of a moded global list appears as a collection
1891 -- of component associations where individual choices denote
1894 elsif Present (Component_Associations (List)) then
1895 if Present (Expressions (List)) then
1897 ("cannot mix moded and non-moded global lists", List);
1900 Assoc := First (Component_Associations (List));
1901 while Present (Assoc) loop
1902 Mode := First (Choices (Assoc));
1904 if Nkind (Mode) = N_Identifier then
1905 if Chars (Mode) = Name_In_Out then
1906 Check_Duplicate_Mode (Mode, In_Out_Seen);
1907 Check_Mode_Restriction_In_Function (Mode);
1909 elsif Chars (Mode) = Name_Input then
1910 Check_Duplicate_Mode (Mode, Input_Seen);
1912 elsif Chars (Mode) = Name_Output then
1913 Check_Duplicate_Mode (Mode, Output_Seen);
1914 Check_Mode_Restriction_In_Function (Mode);
1916 elsif Chars (Mode) = Name_Proof_In then
1917 Check_Duplicate_Mode (Mode, Proof_Seen);
1920 Error_Msg_N ("invalid mode selector", Mode);
1924 Error_Msg_N ("invalid mode selector", Mode);
1927 -- Items in a moded list appear as a collection of
1928 -- expressions. Reuse the existing machinery to analyze
1932 (List => Expression (Assoc),
1933 Global_Mode => Chars (Mode));
1941 raise Program_Error;
1944 -- Any other attempt to declare a global item is erroneous
1947 Error_Msg_N ("malformed global list declaration", List);
1949 end Analyze_Global_List;
1954 Subp_Decl : Node_Id;
1956 Restore_Scope : Boolean := False;
1957 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
1959 -- Start of processing for Analyze_Global_In_Decl_List
1964 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1965 Subp_Id := Defining_Entity (Subp_Decl);
1967 -- The logic in this routine is used to analyze both pragma Global and
1968 -- pragma Refined_Global since they have the same syntax and base
1969 -- semantics. Find the entity of the corresponding spec when analyzing
1972 if Nkind (Subp_Decl) = N_Subprogram_Body
1973 and then not Acts_As_Spec (Subp_Decl)
1975 Spec_Id := Corresponding_Spec (Subp_Decl);
1977 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
1978 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1984 Items := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
1986 -- There is nothing to be done for a null global list
1988 if Nkind (Items) = N_Null then
1989 Set_Analyzed (Items);
1991 -- Analyze the various forms of global lists and items. Note that some
1992 -- of these may be malformed in which case the analysis emits error
1996 -- Ensure that the formal parameters are visible when processing an
1997 -- item. This falls out of the general rule of aspects pertaining to
1998 -- subprogram declarations.
2000 if not In_Open_Scopes (Spec_Id) then
2001 Restore_Scope := True;
2002 Push_Scope (Spec_Id);
2003 Install_Formals (Spec_Id);
2006 Analyze_Global_List (Items);
2008 if Restore_Scope then
2012 end Analyze_Global_In_Decl_Part;
2014 --------------------------------------------
2015 -- Analyze_Initial_Condition_In_Decl_Part --
2016 --------------------------------------------
2018 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2019 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Parent (N)));
2020 Prag_Init : constant Node_Id :=
2021 Get_Pragma (Pack_Id, Pragma_Initializes);
2022 -- The related pragma Initializes
2024 Vars : Elist_Id := No_Elist;
2025 -- A list of all variables declared in pragma Initializes
2027 procedure Collect_Variables;
2028 -- Inspect the initialization list of pragma Initializes and collect the
2029 -- entities of all variables declared within the related package.
2031 function Match_Variable (N : Node_Id) return Traverse_Result;
2032 -- Determine whether arbitrary node N denotes a variable declared in the
2033 -- visible declarations of the related package.
2035 procedure Report_Unused_Variables;
2036 -- Emit errors for all variables found in list Vars
2038 -----------------------
2039 -- Collect_Variables --
2040 -----------------------
2042 procedure Collect_Variables is
2043 procedure Collect_Variable (Item : Node_Id);
2044 -- Determine whether Item denotes a variable that appears in the
2045 -- related package and if it does, add it to list Vars.
2047 ----------------------
2048 -- Collect_Variable --
2049 ----------------------
2051 procedure Collect_Variable (Item : Node_Id) is
2052 Item_Id : Entity_Id;
2055 if Is_Entity_Name (Item) and then Present (Entity (Item)) then
2056 Item_Id := Entity (Item);
2058 -- The item is a variable declared in the related package
2060 if Ekind (Item_Id) = E_Variable
2061 and then Scope (Item_Id) = Pack_Id
2063 Add_Item (Item_Id, Vars);
2066 end Collect_Variable;
2070 Inits : constant Node_Id :=
2072 (First (Pragma_Argument_Associations (Prag_Init)));
2075 -- Start of processing for Collect_Variables
2078 -- Multiple initialization items appear as an aggregate
2080 if Nkind (Inits) = N_Aggregate
2081 and then Present (Expressions (Inits))
2083 Init := First (Expressions (Inits));
2084 while Present (Init) loop
2085 Collect_Variable (Init);
2090 -- Single initialization item
2093 Collect_Variable (Inits);
2095 end Collect_Variables;
2097 --------------------
2098 -- Match_Variable --
2099 --------------------
2101 function Match_Variable (N : Node_Id) return Traverse_Result is
2105 -- Find a variable declared within the related package and try to
2106 -- remove it from the list of collected variables found in pragma
2109 if Is_Entity_Name (N)
2110 and then Present (Entity (N))
2112 Var_Id := Entity (N);
2114 if Ekind (Var_Id) = E_Variable
2115 and then Scope (Var_Id) = Pack_Id
2117 Remove (Vars, Var_Id);
2124 procedure Match_Variables is new Traverse_Proc (Match_Variable);
2126 -----------------------------
2127 -- Report_Unused_Variables --
2128 -----------------------------
2130 procedure Report_Unused_Variables is
2131 Posted : Boolean := False;
2136 if Present (Vars) then
2137 Var_Elmt := First_Elmt (Vars);
2138 while Present (Var_Elmt) loop
2139 Var_Id := Node (Var_Elmt);
2143 Error_Msg_Name_1 := Name_Initial_Condition;
2145 ("expression of % must mention the following variables",
2149 Error_Msg_Sloc := Sloc (Var_Id);
2150 Error_Msg_NE ("\ & declared #", N, Var_Id);
2152 Next_Elmt (Var_Elmt);
2155 end Report_Unused_Variables;
2157 Expr : constant Node_Id :=
2158 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2159 Errors : constant Nat := Serious_Errors_Detected;
2161 -- Start of processing for Analyze_Initial_Condition_In_Decl_Part
2166 -- Pragma Initial_Condition depends on the names enumerated in pragma
2167 -- Initializes. Without those, the analysis cannot take place.
2169 if No (Prag_Init) then
2170 Error_Msg_Name_1 := Name_Initial_Condition;
2171 Error_Msg_Name_2 := Name_Initializes;
2173 Error_Msg_N ("% requires the presence of aspect or pragma %", N);
2177 -- The expression is preanalyzed because it has not been moved to its
2178 -- final place yet. A direct analysis may generate sife effects and this
2179 -- is not desired at this point.
2181 Preanalyze_And_Resolve (Expr, Standard_Boolean);
2183 -- Perform variable matching only when the expression is legal
2185 if Serious_Errors_Detected = Errors then
2188 -- Verify that all variables mentioned in pragma Initializes are used
2189 -- in the expression of pragma Initial_Condition.
2191 Match_Variables (Expr);
2194 -- Emit errors for all variables that should participate in the
2195 -- expression of pragma Initial_Condition.
2197 if Serious_Errors_Detected = Errors then
2198 Report_Unused_Variables;
2200 end Analyze_Initial_Condition_In_Decl_Part;
2202 --------------------------------------
2203 -- Analyze_Initializes_In_Decl_Part --
2204 --------------------------------------
2206 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2207 Pack_Spec : constant Node_Id := Parent (N);
2208 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec));
2210 Items_Seen : Elist_Id := No_Elist;
2211 -- A list of all initialization items processed so far. This list is
2212 -- used to detect duplicate items.
2214 Non_Null_Seen : Boolean := False;
2215 Null_Seen : Boolean := False;
2216 -- Flags used to check the legality of a null initialization list
2218 States_And_Vars : Elist_Id := No_Elist;
2219 -- A list of all abstract states and variables declared in the visible
2220 -- declarations of the related package. This list is used to detect the
2221 -- legality of initialization items.
2223 procedure Analyze_Initialization_Item (Item : Node_Id);
2224 -- Verify the legality of a single initialization item
2226 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2227 -- Verify the legality of a single initialization item followed by a
2228 -- list of input items.
2230 procedure Collect_States_And_Variables;
2231 -- Inspect the visible declarations of the related package and gather
2232 -- the entities of all abstract states and variables in States_And_Vars.
2234 ---------------------------------
2235 -- Analyze_Initialization_Item --
2236 ---------------------------------
2238 procedure Analyze_Initialization_Item (Item : Node_Id) is
2239 Item_Id : Entity_Id;
2242 -- Null initialization list
2244 if Nkind (Item) = N_Null then
2246 Error_Msg_N ("multiple null initializations not allowed", Item);
2248 elsif Non_Null_Seen then
2250 ("cannot mix null and non-null initialization items", Item);
2255 -- Initialization item
2258 Non_Null_Seen := True;
2262 ("cannot mix null and non-null initialization items", Item);
2267 if Is_Entity_Name (Item) then
2268 Item_Id := Entity (Item);
2270 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2272 -- The state or variable must be declared in the visible
2273 -- declarations of the package.
2275 if not Contains (States_And_Vars, Item_Id) then
2276 Error_Msg_Name_1 := Chars (Pack_Id);
2278 ("initialization item & must appear in the visible "
2279 & "declarations of package %", Item, Item_Id);
2281 -- Detect a duplicate use of the same initialization item
2283 elsif Contains (Items_Seen, Item_Id) then
2284 Error_Msg_N ("duplicate initialization item", Item);
2286 -- The item is legal, add it to the list of processed states
2290 Add_Item (Item_Id, Items_Seen);
2293 -- The item references something that is not a state or a
2298 ("initialization item must denote variable or state",
2302 -- Some form of illegal construct masquerading as a name
2306 ("initialization item must denote variable or state", Item);
2309 end Analyze_Initialization_Item;
2311 ---------------------------------------------
2312 -- Analyze_Initialization_Item_With_Inputs --
2313 ---------------------------------------------
2315 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2316 Inputs_Seen : Elist_Id := No_Elist;
2317 -- A list of all inputs processed so far. This list is used to detect
2318 -- duplicate uses of an input.
2320 Non_Null_Seen : Boolean := False;
2321 Null_Seen : Boolean := False;
2322 -- Flags used to check the legality of an input list
2324 procedure Analyze_Input_Item (Input : Node_Id);
2325 -- Verify the legality of a single input item
2327 ------------------------
2328 -- Analyze_Input_Item --
2329 ------------------------
2331 procedure Analyze_Input_Item (Input : Node_Id) is
2332 Input_Id : Entity_Id;
2337 if Nkind (Input) = N_Null then
2340 ("multiple null initializations not allowed", Item);
2342 elsif Non_Null_Seen then
2344 ("cannot mix null and non-null initialization item", Item);
2352 Non_Null_Seen := True;
2356 ("cannot mix null and non-null initialization item", Item);
2361 if Is_Entity_Name (Input) then
2362 Input_Id := Entity (Input);
2364 if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then
2366 -- The input cannot denote states or variables declared
2367 -- within the related package.
2369 if In_Same_Code_Unit (Item, Input_Id) then
2370 Error_Msg_Name_1 := Chars (Pack_Id);
2372 ("input item & cannot denote a visible variable or "
2373 & "state of package %", Input, Input_Id);
2375 -- Detect a duplicate use of the same input item
2377 elsif Contains (Inputs_Seen, Input_Id) then
2378 Error_Msg_N ("duplicate input item", Input);
2380 -- Input is legal, add it to the list of processed inputs
2383 Add_Item (Input_Id, Inputs_Seen);
2386 -- The input references something that is not a state or a
2391 ("input item must denote variable or state", Input);
2394 -- Some form of illegal construct masquerading as a name
2398 ("input item must denote variable or state", Input);
2401 end Analyze_Input_Item;
2405 Inputs : constant Node_Id := Expression (Item);
2409 Name_Seen : Boolean := False;
2410 -- A flag used to detect multiple item names
2412 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2415 -- Inspect the name of an item with inputs
2417 Elmt := First (Choices (Item));
2418 while Present (Elmt) loop
2420 Error_Msg_N ("only one item allowed in initialization", Elmt);
2423 Analyze_Initialization_Item (Elmt);
2429 -- Multiple input items appear as an aggregate
2431 if Nkind (Inputs) = N_Aggregate then
2432 if Present (Expressions (Inputs)) then
2433 Input := First (Expressions (Inputs));
2434 while Present (Input) loop
2435 Analyze_Input_Item (Input);
2440 if Present (Component_Associations (Inputs)) then
2442 ("inputs must appear in named association form", Inputs);
2445 -- Single input item
2448 Analyze_Input_Item (Inputs);
2450 end Analyze_Initialization_Item_With_Inputs;
2452 ----------------------------------
2453 -- Collect_States_And_Variables --
2454 ----------------------------------
2456 procedure Collect_States_And_Variables is
2460 -- Collect the abstract states defined in the package (if any)
2462 if Present (Abstract_States (Pack_Id)) then
2463 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id));
2466 -- Collect all variables the appear in the visible declarations of
2467 -- the related package.
2469 if Present (Visible_Declarations (Pack_Spec)) then
2470 Decl := First (Visible_Declarations (Pack_Spec));
2471 while Present (Decl) loop
2472 if Nkind (Decl) = N_Object_Declaration
2473 and then Ekind (Defining_Entity (Decl)) = E_Variable
2474 and then Comes_From_Source (Decl)
2476 Add_Item (Defining_Entity (Decl), States_And_Vars);
2482 end Collect_States_And_Variables;
2486 Inits : constant Node_Id :=
2487 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2490 -- Start of processing for Analyze_Initializes_In_Decl_Part
2495 -- Initialize the various lists used during analysis
2497 Collect_States_And_Variables;
2499 -- Multiple initialization clauses appear as an aggregate
2501 if Nkind (Inits) = N_Aggregate then
2502 if Present (Expressions (Inits)) then
2503 Init := First (Expressions (Inits));
2504 while Present (Init) loop
2505 Analyze_Initialization_Item (Init);
2511 if Present (Component_Associations (Inits)) then
2512 Init := First (Component_Associations (Inits));
2513 while Present (Init) loop
2514 Analyze_Initialization_Item_With_Inputs (Init);
2520 -- Various forms of a single initialization clause. Note that these may
2521 -- include malformed initializations.
2524 Analyze_Initialization_Item (Inits);
2526 end Analyze_Initializes_In_Decl_Part;
2528 --------------------
2529 -- Analyze_Pragma --
2530 --------------------
2532 procedure Analyze_Pragma (N : Node_Id) is
2533 Loc : constant Source_Ptr := Sloc (N);
2534 Prag_Id : Pragma_Id;
2537 -- Name of the source pragma, or name of the corresponding aspect for
2538 -- pragmas which originate in a source aspect. In the latter case, the
2539 -- name may be different from the pragma name.
2541 Pragma_Exit : exception;
2542 -- This exception is used to exit pragma processing completely. It is
2543 -- used when an error is detected, and no further processing is
2544 -- required. It is also used if an earlier error has left the tree in
2545 -- a state where the pragma should not be processed.
2548 -- Number of pragma argument associations
2554 -- First four pragma arguments (pragma argument association nodes, or
2555 -- Empty if the corresponding argument does not exist).
2557 type Name_List is array (Natural range <>) of Name_Id;
2558 type Args_List is array (Natural range <>) of Node_Id;
2559 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2561 procedure Ada_2005_Pragma;
2562 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2563 -- Ada 95 mode, these are implementation defined pragmas, so should be
2564 -- caught by the No_Implementation_Pragmas restriction.
2566 procedure Ada_2012_Pragma;
2567 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2568 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2569 -- should be caught by the No_Implementation_Pragmas restriction.
2571 procedure Analyze_Refined_Pragma
2572 (Spec_Id : out Entity_Id;
2573 Body_Id : out Entity_Id;
2574 Legal : out Boolean);
2575 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2576 -- Refined_Global and Refined_Post. Check the placement and related
2577 -- context of the pragma. Spec_Id is the entity of the related
2578 -- subprogram. Body_Id is the entity of the subprogram body. Flag Legal
2579 -- is set when the pragma is properly placed.
2581 procedure Check_Ada_83_Warning;
2582 -- Issues a warning message for the current pragma if operating in Ada
2583 -- 83 mode (used for language pragmas that are not a standard part of
2584 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2587 procedure Check_Arg_Count (Required : Nat);
2588 -- Check argument count for pragma is equal to given parameter. If not,
2589 -- then issue an error message and raise Pragma_Exit.
2591 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2592 -- Arg which can either be a pragma argument association, in which case
2593 -- the check is applied to the expression of the association or an
2594 -- expression directly.
2596 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2597 -- Check that an argument has the right form for an EXTERNAL_NAME
2598 -- parameter of an extended import/export pragma. The rule is that the
2599 -- name must be an identifier or string literal (in Ada 83 mode) or a
2600 -- static string expression (in Ada 95 mode).
2602 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2603 -- Check the specified argument Arg to make sure that it is an
2604 -- identifier. If not give error and raise Pragma_Exit.
2606 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2607 -- Check the specified argument Arg to make sure that it is an integer
2608 -- literal. If not give error and raise Pragma_Exit.
2610 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2611 -- Check the specified argument Arg to make sure that it has the proper
2612 -- syntactic form for a local name and meets the semantic requirements
2613 -- for a local name. The local name is analyzed as part of the
2614 -- processing for this call. In addition, the local name is required
2615 -- to represent an entity at the library level.
2617 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2618 -- Check the specified argument Arg to make sure that it has the proper
2619 -- syntactic form for a local name and meets the semantic requirements
2620 -- for a local name. The local name is analyzed as part of the
2621 -- processing for this call.
2623 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2624 -- Check the specified argument Arg to make sure that it is a valid
2625 -- locking policy name. If not give error and raise Pragma_Exit.
2627 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2628 -- Check the specified argument Arg to make sure that it is a valid
2629 -- elaboration policy name. If not give error and raise Pragma_Exit.
2631 procedure Check_Arg_Is_One_Of
2634 procedure Check_Arg_Is_One_Of
2636 N1, N2, N3 : Name_Id);
2637 procedure Check_Arg_Is_One_Of
2639 N1, N2, N3, N4 : Name_Id);
2640 procedure Check_Arg_Is_One_Of
2642 N1, N2, N3, N4, N5 : Name_Id);
2643 -- Check the specified argument Arg to make sure that it is an
2644 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2645 -- present). If not then give error and raise Pragma_Exit.
2647 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2648 -- Check the specified argument Arg to make sure that it is a valid
2649 -- queuing policy name. If not give error and raise Pragma_Exit.
2651 procedure Check_Arg_Is_Static_Expression
2653 Typ : Entity_Id := Empty);
2654 -- Check the specified argument Arg to make sure that it is a static
2655 -- expression of the given type (i.e. it will be analyzed and resolved
2656 -- using this type, which can be any valid argument to Resolve, e.g.
2657 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2658 -- Typ is left Empty, then any static expression is allowed.
2660 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2661 -- Check the specified argument Arg to make sure that it is a valid task
2662 -- dispatching policy name. If not give error and raise Pragma_Exit.
2664 procedure Check_Arg_Order (Names : Name_List);
2665 -- Checks for an instance of two arguments with identifiers for the
2666 -- current pragma which are not in the sequence indicated by Names,
2667 -- and if so, generates a fatal message about bad order of arguments.
2669 procedure Check_At_Least_N_Arguments (N : Nat);
2670 -- Check there are at least N arguments present
2672 procedure Check_At_Most_N_Arguments (N : Nat);
2673 -- Check there are no more than N arguments present
2675 procedure Check_Component
2678 In_Variant_Part : Boolean := False);
2679 -- Examine an Unchecked_Union component for correct use of per-object
2680 -- constrained subtypes, and for restrictions on finalizable components.
2681 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2682 -- should be set when Comp comes from a record variant.
2684 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id);
2685 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2686 -- Initial_Condition and Initializes. Determine whether pragma First
2687 -- appears before pragma Second. If this is not the case, emit an error.
2689 procedure Check_Duplicate_Pragma (E : Entity_Id);
2690 -- Check if a rep item of the same name as the current pragma is already
2691 -- chained as a rep pragma to the given entity. If so give a message
2692 -- about the duplicate, and then raise Pragma_Exit so does not return.
2694 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
2695 -- Nam is an N_String_Literal node containing the external name set by
2696 -- an Import or Export pragma (or extended Import or Export pragma).
2697 -- This procedure checks for possible duplications if this is the export
2698 -- case, and if found, issues an appropriate error message.
2700 procedure Check_Expr_Is_Static_Expression
2702 Typ : Entity_Id := Empty);
2703 -- Check the specified expression Expr to make sure that it is a static
2704 -- expression of the given type (i.e. it will be analyzed and resolved
2705 -- using this type, which can be any valid argument to Resolve, e.g.
2706 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2707 -- Typ is left Empty, then any static expression is allowed.
2709 procedure Check_First_Subtype (Arg : Node_Id);
2710 -- Checks that Arg, whose expression is an entity name, references a
2713 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
2714 -- Checks that the given argument has an identifier, and if so, requires
2715 -- it to match the given identifier name. If there is no identifier, or
2716 -- a non-matching identifier, then an error message is given and
2717 -- Pragma_Exit is raised.
2719 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
2720 -- Checks that the given argument has an identifier, and if so, requires
2721 -- it to match one of the given identifier names. If there is no
2722 -- identifier, or a non-matching identifier, then an error message is
2723 -- given and Pragma_Exit is raised.
2725 procedure Check_In_Main_Program;
2726 -- Common checks for pragmas that appear within a main program
2727 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2729 procedure Check_Interrupt_Or_Attach_Handler;
2730 -- Common processing for first argument of pragma Interrupt_Handler or
2731 -- pragma Attach_Handler.
2733 procedure Check_Loop_Pragma_Placement;
2734 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
2735 -- appear immediately within a construct restricted to loops.
2737 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
2738 -- Check that pragma appears in a declarative part, or in a package
2739 -- specification, i.e. that it does not occur in a statement sequence
2742 procedure Check_No_Identifier (Arg : Node_Id);
2743 -- Checks that the given argument does not have an identifier. If
2744 -- an identifier is present, then an error message is issued, and
2745 -- Pragma_Exit is raised.
2747 procedure Check_No_Identifiers;
2748 -- Checks that none of the arguments to the pragma has an identifier.
2749 -- If any argument has an identifier, then an error message is issued,
2750 -- and Pragma_Exit is raised.
2752 procedure Check_No_Link_Name;
2753 -- Checks that no link name is specified
2755 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
2756 -- Checks if the given argument has an identifier, and if so, requires
2757 -- it to match the given identifier name. If there is a non-matching
2758 -- identifier, then an error message is given and Pragma_Exit is raised.
2760 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
2761 -- Checks if the given argument has an identifier, and if so, requires
2762 -- it to match the given identifier name. If there is a non-matching
2763 -- identifier, then an error message is given and Pragma_Exit is raised.
2764 -- In this version of the procedure, the identifier name is given as
2765 -- a string with lower case letters.
2767 procedure Check_Pre_Post;
2768 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
2769 -- pragmas. These are processed by transformation to equivalent
2770 -- Precondition and Postcondition pragmas, but Pre and Post need an
2771 -- additional check that they are not used in a subprogram body when
2772 -- there is a separate spec present.
2774 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
2775 -- Called to process a precondition or postcondition pragma. There are
2778 -- The pragma appears after a subprogram spec
2780 -- If the corresponding check is not enabled, the pragma is analyzed
2781 -- but otherwise ignored and control returns with In_Body set False.
2783 -- If the check is enabled, then the first step is to analyze the
2784 -- pragma, but this is skipped if the subprogram spec appears within
2785 -- a package specification (because this is the case where we delay
2786 -- analysis till the end of the spec). Then (whether or not it was
2787 -- analyzed), the pragma is chained to the subprogram in question
2788 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2789 -- to the caller with In_Body set False.
2791 -- The pragma appears at the start of subprogram body declarations
2793 -- In this case an immediate return to the caller is made with
2794 -- In_Body set True, and the pragma is NOT analyzed.
2796 -- In all other cases, an error message for bad placement is given
2798 procedure Check_Static_Constraint (Constr : Node_Id);
2799 -- Constr is a constraint from an N_Subtype_Indication node from a
2800 -- component constraint in an Unchecked_Union type. This routine checks
2801 -- that the constraint is static as required by the restrictions for
2804 procedure Check_Test_Case;
2805 -- Called to process a test-case pragma. It starts with checking pragma
2806 -- arguments, and the rest of the treatment is similar to the one for
2807 -- pre- and postcondition in Check_Precondition_Postcondition, except
2808 -- the placement rules for the test-case pragma are stricter. These
2809 -- pragmas may only occur after a subprogram spec declared directly
2810 -- in a package spec unit. In this case, the pragma is chained to the
2811 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2812 -- and analysis of the pragma is delayed till the end of the spec. In
2813 -- all other cases, an error message for bad placement is given.
2815 procedure Check_Valid_Configuration_Pragma;
2816 -- Legality checks for placement of a configuration pragma
2818 procedure Check_Valid_Library_Unit_Pragma;
2819 -- Legality checks for library unit pragmas. A special case arises for
2820 -- pragmas in generic instances that come from copies of the original
2821 -- library unit pragmas in the generic templates. In the case of other
2822 -- than library level instantiations these can appear in contexts which
2823 -- would normally be invalid (they only apply to the original template
2824 -- and to library level instantiations), and they are simply ignored,
2825 -- which is implemented by rewriting them as null statements.
2827 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
2828 -- Check an Unchecked_Union variant for lack of nested variants and
2829 -- presence of at least one component. UU_Typ is the related Unchecked_
2832 procedure Error_Pragma (Msg : String);
2833 pragma No_Return (Error_Pragma);
2834 -- Outputs error message for current pragma. The message contains a %
2835 -- that will be replaced with the pragma name, and the flag is placed
2836 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2837 -- calls Fix_Error (see spec of that procedure for details).
2839 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
2840 pragma No_Return (Error_Pragma_Arg);
2841 -- Outputs error message for current pragma. The message may contain
2842 -- a % that will be replaced with the pragma name. The parameter Arg
2843 -- may either be a pragma argument association, in which case the flag
2844 -- is placed on the expression of this association, or an expression,
2845 -- in which case the flag is placed directly on the expression. The
2846 -- message is placed using Error_Msg_N, so the message may also contain
2847 -- an & insertion character which will reference the given Arg value.
2848 -- After placing the message, Pragma_Exit is raised. Note: this routine
2849 -- calls Fix_Error (see spec of that procedure for details).
2851 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
2852 pragma No_Return (Error_Pragma_Arg);
2853 -- Similar to above form of Error_Pragma_Arg except that two messages
2854 -- are provided, the second is a continuation comment starting with \.
2856 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
2857 pragma No_Return (Error_Pragma_Arg_Ident);
2858 -- Outputs error message for current pragma. The message may contain
2859 -- a % that will be replaced with the pragma name. The parameter Arg
2860 -- must be a pragma argument association with a non-empty identifier
2861 -- (i.e. its Chars field must be set), and the error message is placed
2862 -- on the identifier. The message is placed using Error_Msg_N so
2863 -- the message may also contain an & insertion character which will
2864 -- reference the identifier. After placing the message, Pragma_Exit
2865 -- is raised. Note: this routine calls Fix_Error (see spec of that
2866 -- procedure for details).
2868 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
2869 pragma No_Return (Error_Pragma_Ref);
2870 -- Outputs error message for current pragma. The message may contain
2871 -- a % that will be replaced with the pragma name. The parameter Ref
2872 -- must be an entity whose name can be referenced by & and sloc by #.
2873 -- After placing the message, Pragma_Exit is raised. Note: this routine
2874 -- calls Fix_Error (see spec of that procedure for details).
2876 function Find_Lib_Unit_Name return Entity_Id;
2877 -- Used for a library unit pragma to find the entity to which the
2878 -- library unit pragma applies, returns the entity found.
2880 procedure Find_Program_Unit_Name (Id : Node_Id);
2881 -- If the pragma is a compilation unit pragma, the id must denote the
2882 -- compilation unit in the same compilation, and the pragma must appear
2883 -- in the list of preceding or trailing pragmas. If it is a program
2884 -- unit pragma that is not a compilation unit pragma, then the
2885 -- identifier must be visible.
2887 function Find_Unique_Parameterless_Procedure
2889 Arg : Node_Id) return Entity_Id;
2890 -- Used for a procedure pragma to find the unique parameterless
2891 -- procedure identified by Name, returns it if it exists, otherwise
2892 -- errors out and uses Arg as the pragma argument for the message.
2894 procedure Fix_Error (Msg : in out String);
2895 -- This is called prior to issuing an error message. Msg is a string
2896 -- that typically contains the substring "pragma". If the pragma comes
2897 -- from an aspect, each such "pragma" substring is replaced with the
2898 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
2899 -- aspect (which may be different from the pragma name). If the current
2900 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
2901 -- is set to the original pragma name.
2903 procedure Gather_Associations
2905 Args : out Args_List);
2906 -- This procedure is used to gather the arguments for a pragma that
2907 -- permits arbitrary ordering of parameters using the normal rules
2908 -- for named and positional parameters. The Names argument is a list
2909 -- of Name_Id values that corresponds to the allowed pragma argument
2910 -- association identifiers in order. The result returned in Args is
2911 -- a list of corresponding expressions that are the pragma arguments.
2912 -- Note that this is a list of expressions, not of pragma argument
2913 -- associations (Gather_Associations has completely checked all the
2914 -- optional identifiers when it returns). An entry in Args is Empty
2915 -- on return if the corresponding argument is not present.
2917 procedure GNAT_Pragma;
2918 -- Called for all GNAT defined pragmas to check the relevant restriction
2919 -- (No_Implementation_Pragmas).
2921 procedure S14_Pragma;
2922 -- Called for all pragmas defined for formal verification to check that
2923 -- the S14_Extensions flag is set.
2924 -- This name needs fixing ??? There is no such thing as an
2925 -- "S14_Extensions" flag ???
2927 function Is_Before_First_Decl
2928 (Pragma_Node : Node_Id;
2929 Decls : List_Id) return Boolean;
2930 -- Return True if Pragma_Node is before the first declarative item in
2931 -- Decls where Decls is the list of declarative items.
2933 function Is_Configuration_Pragma return Boolean;
2934 -- Determines if the placement of the current pragma is appropriate
2935 -- for a configuration pragma.
2937 function Is_In_Context_Clause return Boolean;
2938 -- Returns True if pragma appears within the context clause of a unit,
2939 -- and False for any other placement (does not generate any messages).
2941 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
2942 -- Analyzes the argument, and determines if it is a static string
2943 -- expression, returns True if so, False if non-static or not String.
2945 procedure Pragma_Misplaced;
2946 pragma No_Return (Pragma_Misplaced);
2947 -- Issue fatal error message for misplaced pragma
2949 procedure Process_Atomic_Shared_Volatile;
2950 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
2951 -- Shared is an obsolete Ada 83 pragma, treated as being identical
2952 -- in effect to pragma Atomic.
2954 procedure Process_Compile_Time_Warning_Or_Error;
2955 -- Common processing for Compile_Time_Error and Compile_Time_Warning
2957 procedure Process_Convention
2958 (C : out Convention_Id;
2959 Ent : out Entity_Id);
2960 -- Common processing for Convention, Interface, Import and Export.
2961 -- Checks first two arguments of pragma, and sets the appropriate
2962 -- convention value in the specified entity or entities. On return
2963 -- C is the convention, Ent is the referenced entity.
2965 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
2966 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
2967 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
2969 procedure Process_Extended_Import_Export_Exception_Pragma
2970 (Arg_Internal : Node_Id;
2971 Arg_External : Node_Id;
2973 Arg_Code : Node_Id);
2974 -- Common processing for the pragmas Import/Export_Exception. The three
2975 -- arguments correspond to the three named parameters of the pragma. An
2976 -- argument is empty if the corresponding parameter is not present in
2979 procedure Process_Extended_Import_Export_Object_Pragma
2980 (Arg_Internal : Node_Id;
2981 Arg_External : Node_Id;
2982 Arg_Size : Node_Id);
2983 -- Common processing for the pragmas Import/Export_Object. The three
2984 -- arguments correspond to the three named parameters of the pragmas. An
2985 -- argument is empty if the corresponding parameter is not present in
2988 procedure Process_Extended_Import_Export_Internal_Arg
2989 (Arg_Internal : Node_Id := Empty);
2990 -- Common processing for all extended Import and Export pragmas. The
2991 -- argument is the pragma parameter for the Internal argument. If
2992 -- Arg_Internal is empty or inappropriate, an error message is posted.
2993 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
2994 -- set to identify the referenced entity.
2996 procedure Process_Extended_Import_Export_Subprogram_Pragma
2997 (Arg_Internal : Node_Id;
2998 Arg_External : Node_Id;
2999 Arg_Parameter_Types : Node_Id;
3000 Arg_Result_Type : Node_Id := Empty;
3001 Arg_Mechanism : Node_Id;
3002 Arg_Result_Mechanism : Node_Id := Empty;
3003 Arg_First_Optional_Parameter : Node_Id := Empty);
3004 -- Common processing for all extended Import and Export pragmas applying
3005 -- to subprograms. The caller omits any arguments that do not apply to
3006 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3007 -- only in the Import_Function and Export_Function cases). The argument
3008 -- names correspond to the allowed pragma association identifiers.
3010 procedure Process_Generic_List;
3011 -- Common processing for Share_Generic and Inline_Generic
3013 procedure Process_Import_Or_Interface;
3014 -- Common processing for Import of Interface
3016 procedure Process_Import_Predefined_Type;
3017 -- Processing for completing a type with pragma Import. This is used
3018 -- to declare types that match predefined C types, especially for cases
3019 -- without corresponding Ada predefined type.
3021 type Inline_Status is (Suppressed, Disabled, Enabled);
3022 -- Inline status of a subprogram, indicated as follows:
3023 -- Suppressed: inlining is suppressed for the subprogram
3024 -- Disabled: no inlining is requested for the subprogram
3025 -- Enabled: inlining is requested/required for the subprogram
3027 procedure Process_Inline (Status : Inline_Status);
3028 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3029 -- indicates the inline status specified by the pragma.
3031 procedure Process_Interface_Name
3032 (Subprogram_Def : Entity_Id;
3034 Link_Arg : Node_Id);
3035 -- Given the last two arguments of pragma Import, pragma Export, or
3036 -- pragma Interface_Name, performs validity checks and sets the
3037 -- Interface_Name field of the given subprogram entity to the
3038 -- appropriate external or link name, depending on the arguments given.
3039 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3040 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3041 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3042 -- nor Link_Arg is present, the interface name is set to the default
3043 -- from the subprogram name.
3045 procedure Process_Interrupt_Or_Attach_Handler;
3046 -- Common processing for Interrupt and Attach_Handler pragmas
3048 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3049 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3050 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3051 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3052 -- is not set in the Restrictions case.
3054 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3055 -- Common processing for Suppress and Unsuppress. The boolean parameter
3056 -- Suppress_Case is True for the Suppress case, and False for the
3059 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3060 -- This procedure sets the Is_Exported flag for the given entity,
3061 -- checking that the entity was not previously imported. Arg is
3062 -- the argument that specified the entity. A check is also made
3063 -- for exporting inappropriate entities.
3065 procedure Set_Extended_Import_Export_External_Name
3066 (Internal_Ent : Entity_Id;
3067 Arg_External : Node_Id);
3068 -- Common processing for all extended import export pragmas. The first
3069 -- argument, Internal_Ent, is the internal entity, which has already
3070 -- been checked for validity by the caller. Arg_External is from the
3071 -- Import or Export pragma, and may be null if no External parameter
3072 -- was present. If Arg_External is present and is a non-null string
3073 -- (a null string is treated as the default), then the Interface_Name
3074 -- field of Internal_Ent is set appropriately.
3076 procedure Set_Imported (E : Entity_Id);
3077 -- This procedure sets the Is_Imported flag for the given entity,
3078 -- checking that it is not previously exported or imported.
3080 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3081 -- Mech is a parameter passing mechanism (see Import_Function syntax
3082 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3083 -- has the right form, and if not issues an error message. If the
3084 -- argument has the right form then the Mechanism field of Ent is
3085 -- set appropriately.
3087 procedure Set_Rational_Profile;
3088 -- Activate the set of configuration pragmas and permissions that make
3089 -- up the Rational profile.
3091 procedure Set_Ravenscar_Profile (N : Node_Id);
3092 -- Activate the set of configuration pragmas and restrictions that make
3093 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3094 -- is used for error messages on any constructs that violate the
3097 ---------------------
3098 -- Ada_2005_Pragma --
3099 ---------------------
3101 procedure Ada_2005_Pragma is
3103 if Ada_Version <= Ada_95 then
3104 Check_Restriction (No_Implementation_Pragmas, N);
3106 end Ada_2005_Pragma;
3108 ---------------------
3109 -- Ada_2012_Pragma --
3110 ---------------------
3112 procedure Ada_2012_Pragma is
3114 if Ada_Version <= Ada_2005 then
3115 Check_Restriction (No_Implementation_Pragmas, N);
3117 end Ada_2012_Pragma;
3119 ----------------------------
3120 -- Analyze_Refined_Pragma --
3121 ----------------------------
3123 procedure Analyze_Refined_Pragma
3124 (Spec_Id : out Entity_Id;
3125 Body_Id : out Entity_Id;
3126 Legal : out Boolean)
3128 Body_Decl : Node_Id;
3129 Pack_Spec : Node_Id;
3130 Spec_Decl : Node_Id;
3133 -- Assume that the pragma is illegal
3140 Check_Arg_Count (1);
3141 Check_No_Identifiers;
3143 -- Verify the placement of the pragma and check for duplicates. The
3144 -- pragma must apply to a subprogram body [stub].
3146 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3148 if not Nkind_In (Body_Decl, N_Subprogram_Body,
3149 N_Subprogram_Body_Stub)
3155 Body_Id := Defining_Entity (Body_Decl);
3157 -- The body [stub] must not act as a spec, in other words it has to
3158 -- be paired with a corresponding spec.
3160 if Nkind (Body_Decl) = N_Subprogram_Body then
3161 Spec_Id := Corresponding_Spec (Body_Decl);
3163 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
3166 if No (Spec_Id) then
3167 Error_Pragma ("pragma % cannot apply to a stand alone body");
3171 -- The pragma may only apply to the body [stub] of a subprogram
3172 -- declared in the visible part of a package. Retrieve the context of
3173 -- the subprogram declaration.
3175 Spec_Decl := Parent (Parent (Spec_Id));
3178 (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration,
3179 N_Generic_Subprogram_Declaration,
3180 N_Subprogram_Declaration));
3182 Pack_Spec := Parent (Spec_Decl);
3184 if Nkind (Pack_Spec) /= N_Package_Specification
3185 or else List_Containing (Spec_Decl) /=
3186 Visible_Declarations (Pack_Spec)
3189 ("pragma % must apply to the body of a visible subprogram");
3193 -- If we get here, then the pragma is legal
3196 end Analyze_Refined_Pragma;
3198 --------------------------
3199 -- Check_Ada_83_Warning --
3200 --------------------------
3202 procedure Check_Ada_83_Warning is
3204 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3205 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
3207 end Check_Ada_83_Warning;
3209 ---------------------
3210 -- Check_Arg_Count --
3211 ---------------------
3213 procedure Check_Arg_Count (Required : Nat) is
3215 if Arg_Count /= Required then
3216 Error_Pragma ("wrong number of arguments for pragma%");
3218 end Check_Arg_Count;
3220 --------------------------------
3221 -- Check_Arg_Is_External_Name --
3222 --------------------------------
3224 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
3225 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3228 if Nkind (Argx) = N_Identifier then
3232 Analyze_And_Resolve (Argx, Standard_String);
3234 if Is_OK_Static_Expression (Argx) then
3237 elsif Etype (Argx) = Any_Type then
3240 -- An interesting special case, if we have a string literal and
3241 -- we are in Ada 83 mode, then we allow it even though it will
3242 -- not be flagged as static. This allows expected Ada 83 mode
3243 -- use of external names which are string literals, even though
3244 -- technically these are not static in Ada 83.
3246 elsif Ada_Version = Ada_83
3247 and then Nkind (Argx) = N_String_Literal
3251 -- Static expression that raises Constraint_Error. This has
3252 -- already been flagged, so just exit from pragma processing.
3254 elsif Is_Static_Expression (Argx) then
3257 -- Here we have a real error (non-static expression)
3260 Error_Msg_Name_1 := Pname;
3264 "argument for pragma% must be a identifier or "
3265 & "static string expression!";
3268 Flag_Non_Static_Expr (Msg, Argx);
3273 end Check_Arg_Is_External_Name;
3275 -----------------------------
3276 -- Check_Arg_Is_Identifier --
3277 -----------------------------
3279 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3280 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3282 if Nkind (Argx) /= N_Identifier then
3284 ("argument for pragma% must be identifier", Argx);
3286 end Check_Arg_Is_Identifier;
3288 ----------------------------------
3289 -- Check_Arg_Is_Integer_Literal --
3290 ----------------------------------
3292 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3293 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3295 if Nkind (Argx) /= N_Integer_Literal then
3297 ("argument for pragma% must be integer literal", Argx);
3299 end Check_Arg_Is_Integer_Literal;
3301 -------------------------------------------
3302 -- Check_Arg_Is_Library_Level_Local_Name --
3303 -------------------------------------------
3307 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3308 -- | library_unit_NAME
3310 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3312 Check_Arg_Is_Local_Name (Arg);
3314 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3315 and then Comes_From_Source (N)
3318 ("argument for pragma% must be library level entity", Arg);
3320 end Check_Arg_Is_Library_Level_Local_Name;
3322 -----------------------------
3323 -- Check_Arg_Is_Local_Name --
3324 -----------------------------
3328 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3329 -- | library_unit_NAME
3331 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3332 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3337 if Nkind (Argx) not in N_Direct_Name
3338 and then (Nkind (Argx) /= N_Attribute_Reference
3339 or else Present (Expressions (Argx))
3340 or else Nkind (Prefix (Argx)) /= N_Identifier)
3341 and then (not Is_Entity_Name (Argx)
3342 or else not Is_Compilation_Unit (Entity (Argx)))
3344 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3347 -- No further check required if not an entity name
3349 if not Is_Entity_Name (Argx) then
3355 Ent : constant Entity_Id := Entity (Argx);
3356 Scop : constant Entity_Id := Scope (Ent);
3359 -- Case of a pragma applied to a compilation unit: pragma must
3360 -- occur immediately after the program unit in the compilation.
3362 if Is_Compilation_Unit (Ent) then
3364 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3367 -- Case of pragma placed immediately after spec
3369 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3372 -- Case of pragma placed immediately after body
3374 elsif Nkind (Decl) = N_Subprogram_Declaration
3375 and then Present (Corresponding_Body (Decl))
3379 (Parent (Unit_Declaration_Node
3380 (Corresponding_Body (Decl))));
3382 -- All other cases are illegal
3389 -- Special restricted placement rule from 10.2.1(11.8/2)
3391 elsif Is_Generic_Formal (Ent)
3392 and then Prag_Id = Pragma_Preelaborable_Initialization
3394 OK := List_Containing (N) =
3395 Generic_Formal_Declarations
3396 (Unit_Declaration_Node (Scop));
3398 -- Default case, just check that the pragma occurs in the scope
3399 -- of the entity denoted by the name.
3402 OK := Current_Scope = Scop;
3407 ("pragma% argument must be in same declarative part", Arg);
3411 end Check_Arg_Is_Local_Name;
3413 ---------------------------------
3414 -- Check_Arg_Is_Locking_Policy --
3415 ---------------------------------
3417 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
3418 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3421 Check_Arg_Is_Identifier (Argx);
3423 if not Is_Locking_Policy_Name (Chars (Argx)) then
3424 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
3426 end Check_Arg_Is_Locking_Policy;
3428 -----------------------------------------------
3429 -- Check_Arg_Is_Partition_Elaboration_Policy --
3430 -----------------------------------------------
3432 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
3433 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3436 Check_Arg_Is_Identifier (Argx);
3438 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
3440 ("& is not a valid partition elaboration policy name", Argx);
3442 end Check_Arg_Is_Partition_Elaboration_Policy;
3444 -------------------------
3445 -- Check_Arg_Is_One_Of --
3446 -------------------------
3448 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3449 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3452 Check_Arg_Is_Identifier (Argx);
3454 if not Nam_In (Chars (Argx), N1, N2) then
3455 Error_Msg_Name_2 := N1;
3456 Error_Msg_Name_3 := N2;
3457 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
3459 end Check_Arg_Is_One_Of;
3461 procedure Check_Arg_Is_One_Of
3463 N1, N2, N3 : Name_Id)
3465 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3468 Check_Arg_Is_Identifier (Argx);
3470 if not Nam_In (Chars (Argx), N1, N2, N3) then
3471 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3473 end Check_Arg_Is_One_Of;
3475 procedure Check_Arg_Is_One_Of
3477 N1, N2, N3, N4 : Name_Id)
3479 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3482 Check_Arg_Is_Identifier (Argx);
3484 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
3485 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3487 end Check_Arg_Is_One_Of;
3489 procedure Check_Arg_Is_One_Of
3491 N1, N2, N3, N4, N5 : Name_Id)
3493 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3496 Check_Arg_Is_Identifier (Argx);
3498 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
3499 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3501 end Check_Arg_Is_One_Of;
3503 ---------------------------------
3504 -- Check_Arg_Is_Queuing_Policy --
3505 ---------------------------------
3507 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
3508 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3511 Check_Arg_Is_Identifier (Argx);
3513 if not Is_Queuing_Policy_Name (Chars (Argx)) then
3514 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
3516 end Check_Arg_Is_Queuing_Policy;
3518 ------------------------------------
3519 -- Check_Arg_Is_Static_Expression --
3520 ------------------------------------
3522 procedure Check_Arg_Is_Static_Expression
3524 Typ : Entity_Id := Empty)
3527 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
3528 end Check_Arg_Is_Static_Expression;
3530 ------------------------------------------
3531 -- Check_Arg_Is_Task_Dispatching_Policy --
3532 ------------------------------------------
3534 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
3535 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3538 Check_Arg_Is_Identifier (Argx);
3540 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
3542 ("& is not a valid task dispatching policy name", Argx);
3544 end Check_Arg_Is_Task_Dispatching_Policy;
3546 ---------------------
3547 -- Check_Arg_Order --
3548 ---------------------
3550 procedure Check_Arg_Order (Names : Name_List) is
3553 Highest_So_Far : Natural := 0;
3554 -- Highest index in Names seen do far
3558 for J in 1 .. Arg_Count loop
3559 if Chars (Arg) /= No_Name then
3560 for K in Names'Range loop
3561 if Chars (Arg) = Names (K) then
3562 if K < Highest_So_Far then
3563 Error_Msg_Name_1 := Pname;
3565 ("parameters out of order for pragma%", Arg);
3566 Error_Msg_Name_1 := Names (K);
3567 Error_Msg_Name_2 := Names (Highest_So_Far);
3568 Error_Msg_N ("\% must appear before %", Arg);
3572 Highest_So_Far := K;
3580 end Check_Arg_Order;
3582 --------------------------------
3583 -- Check_At_Least_N_Arguments --
3584 --------------------------------
3586 procedure Check_At_Least_N_Arguments (N : Nat) is
3588 if Arg_Count < N then
3589 Error_Pragma ("too few arguments for pragma%");
3591 end Check_At_Least_N_Arguments;
3593 -------------------------------
3594 -- Check_At_Most_N_Arguments --
3595 -------------------------------
3597 procedure Check_At_Most_N_Arguments (N : Nat) is
3600 if Arg_Count > N then
3602 for J in 1 .. N loop
3604 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
3607 end Check_At_Most_N_Arguments;
3609 ---------------------
3610 -- Check_Component --
3611 ---------------------
3613 procedure Check_Component
3616 In_Variant_Part : Boolean := False)
3618 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
3619 Sindic : constant Node_Id :=
3620 Subtype_Indication (Component_Definition (Comp));
3621 Typ : constant Entity_Id := Etype (Comp_Id);
3624 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
3625 -- object constraint, then the component type shall be an Unchecked_
3628 if Nkind (Sindic) = N_Subtype_Indication
3629 and then Has_Per_Object_Constraint (Comp_Id)
3630 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
3633 ("component subtype subject to per-object constraint "
3634 & "must be an Unchecked_Union", Comp);
3636 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
3637 -- the body of a generic unit, or within the body of any of its
3638 -- descendant library units, no part of the type of a component
3639 -- declared in a variant_part of the unchecked union type shall be of
3640 -- a formal private type or formal private extension declared within
3641 -- the formal part of the generic unit.
3643 elsif Ada_Version >= Ada_2012
3644 and then In_Generic_Body (UU_Typ)
3645 and then In_Variant_Part
3646 and then Is_Private_Type (Typ)
3647 and then Is_Generic_Type (Typ)
3650 ("component of unchecked union cannot be of generic type", Comp);
3652 elsif Needs_Finalization (Typ) then
3654 ("component of unchecked union cannot be controlled", Comp);
3656 elsif Has_Task (Typ) then
3658 ("component of unchecked union cannot have tasks", Comp);
3660 end Check_Component;
3662 -----------------------------
3663 -- Check_Declaration_Order --
3664 -----------------------------
3666 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is
3667 procedure Check_Aspect_Specification_Order;
3668 -- Inspect the aspect specifications of the context to determine the
3671 --------------------------------------
3672 -- Check_Aspect_Specification_Order --
3673 --------------------------------------
3675 procedure Check_Aspect_Specification_Order is
3676 Asp_First : constant Node_Id := Corresponding_Aspect (First);
3677 Asp_Second : constant Node_Id := Corresponding_Aspect (Second);
3681 -- Both aspects must be part of the same aspect specification list
3684 (List_Containing (Asp_First) = List_Containing (Asp_Second));
3686 -- Try to reach Second starting from First in a left to right
3687 -- traversal of the aspect specifications.
3689 Asp := Next (Asp_First);
3690 while Present (Asp) loop
3692 -- The order is ok, First is followed by Second
3694 if Asp = Asp_Second then
3701 -- If we get here, then the aspects are out of order
3703 Error_Msg_N ("aspect % cannot come after aspect %", First);
3704 end Check_Aspect_Specification_Order;
3710 -- Start of processing for Check_Declaration_Order
3713 -- Cannot check the order if one of the pragmas is missing
3715 if No (First) or else No (Second) then
3719 -- Set up the error names in case the order is incorrect
3721 Error_Msg_Name_1 := Pragma_Name (First);
3722 Error_Msg_Name_2 := Pragma_Name (Second);
3724 if From_Aspect_Specification (First) then
3726 -- Both pragmas are actually aspects, check their declaration
3727 -- order in the associated aspect specification list. Otherwise
3728 -- First is an aspect and Second a source pragma.
3730 if From_Aspect_Specification (Second) then
3731 Check_Aspect_Specification_Order;
3734 -- Abstract_States is a source pragma
3737 if From_Aspect_Specification (Second) then
3738 Error_Msg_N ("pragma % cannot come after aspect %", First);
3740 -- Both pragmas are source constructs. Try to reach First from
3741 -- Second by traversing the declarations backwards.
3744 Stmt := Prev (Second);
3745 while Present (Stmt) loop
3747 -- The order is ok, First is followed by Second
3749 if Stmt = First then
3756 -- If we get here, then the pragmas are out of order
3758 Error_Msg_N ("pragma % cannot come after pragma %", First);
3761 end Check_Declaration_Order;
3763 ----------------------------
3764 -- Check_Duplicate_Pragma --
3765 ----------------------------
3767 procedure Check_Duplicate_Pragma (E : Entity_Id) is
3768 Id : Entity_Id := E;
3772 -- Nothing to do if this pragma comes from an aspect specification,
3773 -- since we could not be duplicating a pragma, and we dealt with the
3774 -- case of duplicated aspects in Analyze_Aspect_Specifications.
3776 if From_Aspect_Specification (N) then
3780 -- Otherwise current pragma may duplicate previous pragma or a
3781 -- previously given aspect specification or attribute definition
3782 -- clause for the same pragma.
3784 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
3787 Error_Msg_Name_1 := Pragma_Name (N);
3788 Error_Msg_Sloc := Sloc (P);
3790 -- For a single protected or a single task object, the error is
3791 -- issued on the original entity.
3793 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
3794 Id := Defining_Identifier (Original_Node (Parent (Id)));
3797 if Nkind (P) = N_Aspect_Specification
3798 or else From_Aspect_Specification (P)
3800 Error_Msg_NE ("aspect% for & previously given#", N, Id);
3802 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
3807 end Check_Duplicate_Pragma;
3809 ----------------------------------
3810 -- Check_Duplicated_Export_Name --
3811 ----------------------------------
3813 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
3814 String_Val : constant String_Id := Strval (Nam);
3817 -- We are only interested in the export case, and in the case of
3818 -- generics, it is the instance, not the template, that is the
3819 -- problem (the template will generate a warning in any case).
3821 if not Inside_A_Generic
3822 and then (Prag_Id = Pragma_Export
3824 Prag_Id = Pragma_Export_Procedure
3826 Prag_Id = Pragma_Export_Valued_Procedure
3828 Prag_Id = Pragma_Export_Function)
3830 for J in Externals.First .. Externals.Last loop
3831 if String_Equal (String_Val, Strval (Externals.Table (J))) then
3832 Error_Msg_Sloc := Sloc (Externals.Table (J));
3833 Error_Msg_N ("external name duplicates name given#", Nam);
3838 Externals.Append (Nam);
3840 end Check_Duplicated_Export_Name;
3842 -------------------------------------
3843 -- Check_Expr_Is_Static_Expression --
3844 -------------------------------------
3846 procedure Check_Expr_Is_Static_Expression
3848 Typ : Entity_Id := Empty)
3851 if Present (Typ) then
3852 Analyze_And_Resolve (Expr, Typ);
3854 Analyze_And_Resolve (Expr);
3857 if Is_OK_Static_Expression (Expr) then
3860 elsif Etype (Expr) = Any_Type then
3863 -- An interesting special case, if we have a string literal and we
3864 -- are in Ada 83 mode, then we allow it even though it will not be
3865 -- flagged as static. This allows the use of Ada 95 pragmas like
3866 -- Import in Ada 83 mode. They will of course be flagged with
3867 -- warnings as usual, but will not cause errors.
3869 elsif Ada_Version = Ada_83
3870 and then Nkind (Expr) = N_String_Literal
3874 -- Static expression that raises Constraint_Error. This has already
3875 -- been flagged, so just exit from pragma processing.
3877 elsif Is_Static_Expression (Expr) then
3880 -- Finally, we have a real error
3883 Error_Msg_Name_1 := Pname;
3887 "argument for pragma% must be a static expression!";
3890 Flag_Non_Static_Expr (Msg, Expr);
3895 end Check_Expr_Is_Static_Expression;
3897 -------------------------
3898 -- Check_First_Subtype --
3899 -------------------------
3901 procedure Check_First_Subtype (Arg : Node_Id) is
3902 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3903 Ent : constant Entity_Id := Entity (Argx);
3906 if Is_First_Subtype (Ent) then
3909 elsif Is_Type (Ent) then
3911 ("pragma% cannot apply to subtype", Argx);
3913 elsif Is_Object (Ent) then
3915 ("pragma% cannot apply to object, requires a type", Argx);
3919 ("pragma% cannot apply to&, requires a type", Argx);
3921 end Check_First_Subtype;
3923 ----------------------
3924 -- Check_Identifier --
3925 ----------------------
3927 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
3930 and then Nkind (Arg) = N_Pragma_Argument_Association
3932 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
3933 Error_Msg_Name_1 := Pname;
3934 Error_Msg_Name_2 := Id;
3935 Error_Msg_N ("pragma% argument expects identifier%", Arg);
3939 end Check_Identifier;
3941 --------------------------------
3942 -- Check_Identifier_Is_One_Of --
3943 --------------------------------
3945 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3948 and then Nkind (Arg) = N_Pragma_Argument_Association
3950 if Chars (Arg) = No_Name then
3951 Error_Msg_Name_1 := Pname;
3952 Error_Msg_N ("pragma% argument expects an identifier", Arg);
3955 elsif Chars (Arg) /= N1
3956 and then Chars (Arg) /= N2
3958 Error_Msg_Name_1 := Pname;
3959 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
3963 end Check_Identifier_Is_One_Of;
3965 ---------------------------
3966 -- Check_In_Main_Program --
3967 ---------------------------
3969 procedure Check_In_Main_Program is
3970 P : constant Node_Id := Parent (N);
3973 -- Must be at in subprogram body
3975 if Nkind (P) /= N_Subprogram_Body then
3976 Error_Pragma ("% pragma allowed only in subprogram");
3978 -- Otherwise warn if obviously not main program
3980 elsif Present (Parameter_Specifications (Specification (P)))
3981 or else not Is_Compilation_Unit (Defining_Entity (P))
3983 Error_Msg_Name_1 := Pname;
3985 ("??pragma% is only effective in main program", N);
3987 end Check_In_Main_Program;
3989 ---------------------------------------
3990 -- Check_Interrupt_Or_Attach_Handler --
3991 ---------------------------------------
3993 procedure Check_Interrupt_Or_Attach_Handler is
3994 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
3995 Handler_Proc, Proc_Scope : Entity_Id;
4000 if Prag_Id = Pragma_Interrupt_Handler then
4001 Check_Restriction (No_Dynamic_Attachment, N);
4004 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4005 Proc_Scope := Scope (Handler_Proc);
4007 -- On AAMP only, a pragma Interrupt_Handler is supported for
4008 -- nonprotected parameterless procedures.
4010 if not AAMP_On_Target
4011 or else Prag_Id = Pragma_Attach_Handler
4013 if Ekind (Proc_Scope) /= E_Protected_Type then
4015 ("argument of pragma% must be protected procedure", Arg1);
4018 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
4019 Error_Pragma ("pragma% must be in protected definition");
4023 if not Is_Library_Level_Entity (Proc_Scope)
4024 or else (AAMP_On_Target
4025 and then not Is_Library_Level_Entity (Handler_Proc))
4028 ("argument for pragma% must be library level entity", Arg1);
4031 -- AI05-0033: A pragma cannot appear within a generic body, because
4032 -- instance can be in a nested scope. The check that protected type
4033 -- is itself a library-level declaration is done elsewhere.
4035 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4036 -- handle code prior to AI-0033. Analysis tools typically are not
4037 -- interested in this pragma in any case, so no need to worry too
4038 -- much about its placement.
4040 if Inside_A_Generic then
4041 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4042 and then In_Package_Body (Scope (Current_Scope))
4043 and then not Relaxed_RM_Semantics
4045 Error_Pragma ("pragma% cannot be used inside a generic");
4048 end Check_Interrupt_Or_Attach_Handler;
4050 ---------------------------------
4051 -- Check_Loop_Pragma_Placement --
4052 ---------------------------------
4054 procedure Check_Loop_Pragma_Placement is
4055 procedure Placement_Error (Constr : Node_Id);
4056 pragma No_Return (Placement_Error);
4057 -- Node Constr denotes the last loop restricted construct before we
4058 -- encountered an illegal relation between enclosing constructs. Emit
4059 -- an error depending on what Constr was.
4061 ---------------------
4062 -- Placement_Error --
4063 ---------------------
4065 procedure Placement_Error (Constr : Node_Id) is
4067 if Nkind (Constr) = N_Pragma then
4069 ("pragma % must appear immediately within the statements "
4073 ("block containing pragma % must appear immediately within "
4074 & "the statements of a loop", Constr);
4076 end Placement_Error;
4078 -- Local declarations
4083 -- Start of processing for Check_Loop_Pragma_Placement
4088 while Present (Stmt) loop
4090 -- The pragma or previous block must appear immediately within the
4091 -- current block's declarative or statement part.
4093 if Nkind (Stmt) = N_Block_Statement then
4094 if (No (Declarations (Stmt))
4095 or else List_Containing (Prev) /= Declarations (Stmt))
4097 List_Containing (Prev) /=
4098 Statements (Handled_Statement_Sequence (Stmt))
4100 Placement_Error (Prev);
4103 -- Keep inspecting the parents because we are now within a
4104 -- chain of nested blocks.
4108 Stmt := Parent (Stmt);
4111 -- The pragma or previous block must appear immediately within the
4112 -- statements of the loop.
4114 elsif Nkind (Stmt) = N_Loop_Statement then
4115 if List_Containing (Prev) /= Statements (Stmt) then
4116 Placement_Error (Prev);
4119 -- Stop the traversal because we reached the innermost loop
4120 -- regardless of whether we encountered an error or not.
4124 -- Ignore a handled statement sequence. Note that this node may
4125 -- be related to a subprogram body in which case we will emit an
4126 -- error on the next iteration of the search.
4128 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
4129 Stmt := Parent (Stmt);
4131 -- Any other statement breaks the chain from the pragma to the
4135 Placement_Error (Prev);
4139 end Check_Loop_Pragma_Placement;
4141 -------------------------------------------
4142 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4143 -------------------------------------------
4145 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
4154 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4157 elsif Nkind_In (P, N_Package_Specification,
4162 -- Note: the following tests seem a little peculiar, because
4163 -- they test for bodies, but if we were in the statement part
4164 -- of the body, we would already have hit the handled statement
4165 -- sequence, so the only way we get here is by being in the
4166 -- declarative part of the body.
4168 elsif Nkind_In (P, N_Subprogram_Body,
4179 Error_Pragma ("pragma% is not in declarative part or package spec");
4180 end Check_Is_In_Decl_Part_Or_Package_Spec;
4182 -------------------------
4183 -- Check_No_Identifier --
4184 -------------------------
4186 procedure Check_No_Identifier (Arg : Node_Id) is
4188 if Nkind (Arg) = N_Pragma_Argument_Association
4189 and then Chars (Arg) /= No_Name
4191 Error_Pragma_Arg_Ident
4192 ("pragma% does not permit identifier& here", Arg);
4194 end Check_No_Identifier;
4196 --------------------------
4197 -- Check_No_Identifiers --
4198 --------------------------
4200 procedure Check_No_Identifiers is
4204 for J in 1 .. Arg_Count loop
4205 Check_No_Identifier (Arg_Node);
4208 end Check_No_Identifiers;
4210 ------------------------
4211 -- Check_No_Link_Name --
4212 ------------------------
4214 procedure Check_No_Link_Name is
4216 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
4220 if Present (Arg4) then
4222 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
4224 end Check_No_Link_Name;
4226 -------------------------------
4227 -- Check_Optional_Identifier --
4228 -------------------------------
4230 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
4233 and then Nkind (Arg) = N_Pragma_Argument_Association
4234 and then Chars (Arg) /= No_Name
4236 if Chars (Arg) /= Id then
4237 Error_Msg_Name_1 := Pname;
4238 Error_Msg_Name_2 := Id;
4239 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4243 end Check_Optional_Identifier;
4245 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
4247 Name_Buffer (1 .. Id'Length) := Id;
4248 Name_Len := Id'Length;
4249 Check_Optional_Identifier (Arg, Name_Find);
4250 end Check_Optional_Identifier;
4252 --------------------
4253 -- Check_Pre_Post --
4254 --------------------
4256 procedure Check_Pre_Post is
4261 if not Is_List_Member (N) then
4265 -- If we are within an inlined body, the legality of the pragma
4266 -- has been checked already.
4268 if In_Inlined_Body then
4272 -- Search prior declarations
4275 while Present (Prev (P)) loop
4278 -- If the previous node is a generic subprogram, do not go to to
4279 -- the original node, which is the unanalyzed tree: we need to
4280 -- attach the pre/postconditions to the analyzed version at this
4281 -- point. They get propagated to the original tree when analyzing
4282 -- the corresponding body.
4284 if Nkind (P) not in N_Generic_Declaration then
4285 PO := Original_Node (P);
4290 -- Skip past prior pragma
4292 if Nkind (PO) = N_Pragma then
4295 -- Skip stuff not coming from source
4297 elsif not Comes_From_Source (PO) then
4299 -- The condition may apply to a subprogram instantiation
4301 if Nkind (PO) = N_Subprogram_Declaration
4302 and then Present (Generic_Parent (Specification (PO)))
4306 elsif Nkind (PO) = N_Subprogram_Declaration
4307 and then In_Instance
4311 -- For all other cases of non source code, do nothing
4317 -- Only remaining possibility is subprogram declaration
4324 -- If we fall through loop, pragma is at start of list, so see if it
4325 -- is at the start of declarations of a subprogram body.
4329 if Nkind (PO) = N_Subprogram_Body
4330 and then List_Containing (N) = Declarations (PO)
4332 -- This is only allowed if there is no separate specification
4334 if Present (Corresponding_Spec (PO)) then
4336 ("pragma% must apply to subprogram specification");
4343 --------------------------------------
4344 -- Check_Precondition_Postcondition --
4345 --------------------------------------
4347 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
4351 procedure Chain_PPC (PO : Node_Id);
4352 -- If PO is an entry or a [generic] subprogram declaration node, then
4353 -- the precondition/postcondition applies to this subprogram and the
4354 -- processing for the pragma is completed. Otherwise the pragma is
4361 procedure Chain_PPC (PO : Node_Id) is
4365 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4366 if not From_Aspect_Specification (N) then
4368 ("pragma% cannot be applied to abstract subprogram");
4370 elsif Class_Present (N) then
4375 ("aspect % requires ''Class for abstract subprogram");
4378 -- AI05-0230: The same restriction applies to null procedures. For
4379 -- compatibility with earlier uses of the Ada pragma, apply this
4380 -- rule only to aspect specifications.
4382 -- The above discrepency needs documentation. Robert is dubious
4383 -- about whether it is a good idea ???
4385 elsif Nkind (PO) = N_Subprogram_Declaration
4386 and then Nkind (Specification (PO)) = N_Procedure_Specification
4387 and then Null_Present (Specification (PO))
4388 and then From_Aspect_Specification (N)
4389 and then not Class_Present (N)
4392 ("aspect % requires ''Class for null procedure");
4394 -- Pre/postconditions are legal on a subprogram body if it is not
4395 -- a completion of a declaration. They are also legal on a stub
4396 -- with no previous declarations (this is checked when processing
4397 -- the corresponding aspects).
4399 elsif Nkind (PO) = N_Subprogram_Body
4400 and then Acts_As_Spec (PO)
4404 elsif Nkind (PO) = N_Subprogram_Body_Stub then
4407 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4408 N_Expression_Function,
4409 N_Generic_Subprogram_Declaration,
4410 N_Entry_Declaration)
4415 -- Here if we have [generic] subprogram or entry declaration
4417 if Nkind (PO) = N_Entry_Declaration then
4418 S := Defining_Entity (PO);
4420 S := Defining_Unit_Name (Specification (PO));
4422 if Nkind (S) = N_Defining_Program_Unit_Name then
4423 S := Defining_Identifier (S);
4427 -- Note: we do not analyze the pragma at this point. Instead we
4428 -- delay this analysis until the end of the declarative part in
4429 -- which the pragma appears. This implements the required delay
4430 -- in this analysis, allowing forward references. The analysis
4431 -- happens at the end of Analyze_Declarations.
4433 -- Chain spec PPC pragma to list for subprogram
4435 Add_Contract_Item (N, S);
4437 -- Return indicating spec case
4443 -- Start of processing for Check_Precondition_Postcondition
4446 if not Is_List_Member (N) then
4450 -- Preanalyze message argument if present. Visibility in this
4451 -- argument is established at the point of pragma occurrence.
4453 if Arg_Count = 2 then
4454 Check_Optional_Identifier (Arg2, Name_Message);
4455 Preanalyze_Spec_Expression
4456 (Get_Pragma_Arg (Arg2), Standard_String);
4459 -- For a pragma PPC in the extended main source unit, record enabled
4462 if Is_Checked (N) and then not Split_PPC (N) then
4463 Set_SCO_Pragma_Enabled (Loc);
4466 -- If we are within an inlined body, the legality of the pragma
4467 -- has been checked already.
4469 if In_Inlined_Body then
4474 -- Search prior declarations
4477 while Present (Prev (P)) loop
4480 -- If the previous node is a generic subprogram, do not go to to
4481 -- the original node, which is the unanalyzed tree: we need to
4482 -- attach the pre/postconditions to the analyzed version at this
4483 -- point. They get propagated to the original tree when analyzing
4484 -- the corresponding body.
4486 if Nkind (P) not in N_Generic_Declaration then
4487 PO := Original_Node (P);
4492 -- Skip past prior pragma
4494 if Nkind (PO) = N_Pragma then
4497 -- Skip stuff not coming from source
4499 elsif not Comes_From_Source (PO) then
4501 -- The condition may apply to a subprogram instantiation
4503 if Nkind (PO) = N_Subprogram_Declaration
4504 and then Present (Generic_Parent (Specification (PO)))
4509 elsif Nkind (PO) = N_Subprogram_Declaration
4510 and then In_Instance
4515 -- For all other cases of non source code, do nothing
4521 -- Only remaining possibility is subprogram declaration
4529 -- If we fall through loop, pragma is at start of list, so see if it
4530 -- is at the start of declarations of a subprogram body.
4534 if Nkind (PO) = N_Subprogram_Body
4535 and then List_Containing (N) = Declarations (PO)
4537 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
4539 -- Analyze pragma expression for correctness and for ASIS use
4541 Preanalyze_Assert_Expression
4542 (Get_Pragma_Arg (Arg1), Standard_Boolean);
4544 -- In ASIS mode, for a pragma generated from a source aspect,
4545 -- also analyze the original aspect expression.
4547 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4548 Preanalyze_Assert_Expression
4549 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
4553 -- Retain a copy of the pre- or postcondition pragma for formal
4554 -- verification purposes. The copy is needed because the pragma is
4555 -- expanded into other constructs which are not acceptable in the
4558 if Acts_As_Spec (PO)
4559 and then (SPARK_Mode or Formal_Extensions)
4562 Prag : constant Node_Id := New_Copy_Tree (N);
4565 -- Preanalyze the pragma
4567 Preanalyze_Assert_Expression
4569 (First (Pragma_Argument_Associations (Prag))),
4572 -- Preanalyze the corresponding aspect (if any)
4574 if Present (Corresponding_Aspect (Prag)) then
4575 Preanalyze_Assert_Expression
4576 (Expression (Corresponding_Aspect (Prag)),
4580 -- Chain the copy on the contract of the body
4583 (Prag, Defining_Unit_Name (Specification (PO)));
4590 -- See if it is in the pragmas after a library level subprogram
4592 elsif Nkind (PO) = N_Compilation_Unit_Aux then
4594 -- In formal verification mode, analyze pragma expression for
4595 -- correctness, as it is not expanded later. Ditto in ASIS_Mode
4596 -- where there is no later point at which the aspect will be
4599 if SPARK_Mode or else ASIS_Mode then
4600 Analyze_Pre_Post_Condition_In_Decl_Part
4601 (N, Defining_Entity (Unit (Parent (PO))));
4604 Chain_PPC (Unit (Parent (PO)));
4608 -- If we fall through, pragma was misplaced
4611 end Check_Precondition_Postcondition;
4613 -----------------------------
4614 -- Check_Static_Constraint --
4615 -----------------------------
4617 -- Note: for convenience in writing this procedure, in addition to
4618 -- the officially (i.e. by spec) allowed argument which is always a
4619 -- constraint, it also allows ranges and discriminant associations.
4620 -- Above is not clear ???
4622 procedure Check_Static_Constraint (Constr : Node_Id) is
4624 procedure Require_Static (E : Node_Id);
4625 -- Require given expression to be static expression
4627 --------------------
4628 -- Require_Static --
4629 --------------------
4631 procedure Require_Static (E : Node_Id) is
4633 if not Is_OK_Static_Expression (E) then
4634 Flag_Non_Static_Expr
4635 ("non-static constraint not allowed in Unchecked_Union!", E);
4640 -- Start of processing for Check_Static_Constraint
4643 case Nkind (Constr) is
4644 when N_Discriminant_Association =>
4645 Require_Static (Expression (Constr));
4648 Require_Static (Low_Bound (Constr));
4649 Require_Static (High_Bound (Constr));
4651 when N_Attribute_Reference =>
4652 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
4653 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
4655 when N_Range_Constraint =>
4656 Check_Static_Constraint (Range_Expression (Constr));
4658 when N_Index_Or_Discriminant_Constraint =>
4662 IDC := First (Constraints (Constr));
4663 while Present (IDC) loop
4664 Check_Static_Constraint (IDC);
4672 end Check_Static_Constraint;
4674 ---------------------
4675 -- Check_Test_Case --
4676 ---------------------
4678 procedure Check_Test_Case is
4682 procedure Chain_CTC (PO : Node_Id);
4683 -- If PO is a [generic] subprogram declaration node, then the
4684 -- test-case applies to this subprogram and the processing for
4685 -- the pragma is completed. Otherwise the pragma is misplaced.
4691 procedure Chain_CTC (PO : Node_Id) is
4695 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
4697 ("pragma% cannot be applied to abstract subprogram");
4699 elsif Nkind (PO) = N_Entry_Declaration then
4700 Error_Pragma ("pragma% cannot be applied to entry");
4702 elsif not Nkind_In (PO, N_Subprogram_Declaration,
4703 N_Generic_Subprogram_Declaration)
4708 -- Here if we have [generic] subprogram declaration
4710 S := Defining_Unit_Name (Specification (PO));
4712 -- Note: we do not analyze the pragma at this point. Instead we
4713 -- delay this analysis until the end of the declarative part in
4714 -- which the pragma appears. This implements the required delay
4715 -- in this analysis, allowing forward references. The analysis
4716 -- happens at the end of Analyze_Declarations.
4718 -- There should not be another test-case with the same name
4719 -- associated to this subprogram.
4722 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
4726 CTC := Contract_Test_Cases (Contract (S));
4727 while Present (CTC) loop
4729 -- Omit pragma Contract_Cases because it does not introduce
4730 -- a unique case name and it does not follow the syntax of
4733 if Pragma_Name (CTC) = Name_Contract_Cases then
4737 (Name, Get_Name_From_CTC_Pragma (CTC))
4739 Error_Msg_Sloc := Sloc (CTC);
4740 Error_Pragma ("name for pragma% is already used#");
4743 CTC := Next_Pragma (CTC);
4747 -- Chain spec CTC pragma to list for subprogram
4749 Add_Contract_Item (N, S);
4752 -- Start of processing for Check_Test_Case
4755 -- First check pragma arguments
4757 Check_At_Least_N_Arguments (2);
4758 Check_At_Most_N_Arguments (4);
4760 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
4762 Check_Optional_Identifier (Arg1, Name_Name);
4763 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
4765 -- In ASIS mode, for a pragma generated from a source aspect, also
4766 -- analyze the original aspect expression.
4768 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
4769 Check_Expr_Is_Static_Expression
4770 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
4773 Check_Optional_Identifier (Arg2, Name_Mode);
4774 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
4776 if Arg_Count = 4 then
4777 Check_Identifier (Arg3, Name_Requires);
4778 Check_Identifier (Arg4, Name_Ensures);
4780 elsif Arg_Count = 3 then
4781 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
4784 -- Check pragma placement
4786 if not Is_List_Member (N) then
4790 -- Test-case should only appear in package spec unit
4792 if Get_Source_Unit (N) = No_Unit
4793 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
4794 N_Package_Declaration,
4795 N_Generic_Package_Declaration)
4800 -- Search prior declarations
4803 while Present (Prev (P)) loop
4806 -- If the previous node is a generic subprogram, do not go to to
4807 -- the original node, which is the unanalyzed tree: we need to
4808 -- attach the test-case to the analyzed version at this point.
4809 -- They get propagated to the original tree when analyzing the
4810 -- corresponding body.
4812 if Nkind (P) not in N_Generic_Declaration then
4813 PO := Original_Node (P);
4818 -- Skip past prior pragma
4820 if Nkind (PO) = N_Pragma then
4823 -- Skip stuff not coming from source
4825 elsif not Comes_From_Source (PO) then
4828 -- Only remaining possibility is subprogram declaration. First
4829 -- check that it is declared directly in a package declaration.
4830 -- This may be either the package declaration for the current unit
4831 -- being defined or a local package declaration.
4833 elsif not Present (Parent (Parent (PO)))
4834 or else not Present (Parent (Parent (Parent (PO))))
4835 or else not Nkind_In (Parent (Parent (PO)),
4836 N_Package_Declaration,
4837 N_Generic_Package_Declaration)
4847 -- If we fall through, pragma was misplaced
4850 end Check_Test_Case;
4852 --------------------------------------
4853 -- Check_Valid_Configuration_Pragma --
4854 --------------------------------------
4856 -- A configuration pragma must appear in the context clause of a
4857 -- compilation unit, and only other pragmas may precede it. Note that
4858 -- the test also allows use in a configuration pragma file.
4860 procedure Check_Valid_Configuration_Pragma is
4862 if not Is_Configuration_Pragma then
4863 Error_Pragma ("incorrect placement for configuration pragma%");
4865 end Check_Valid_Configuration_Pragma;
4867 -------------------------------------
4868 -- Check_Valid_Library_Unit_Pragma --
4869 -------------------------------------
4871 procedure Check_Valid_Library_Unit_Pragma is
4873 Parent_Node : Node_Id;
4874 Unit_Name : Entity_Id;
4875 Unit_Kind : Node_Kind;
4876 Unit_Node : Node_Id;
4877 Sindex : Source_File_Index;
4880 if not Is_List_Member (N) then
4884 Plist := List_Containing (N);
4885 Parent_Node := Parent (Plist);
4887 if Parent_Node = Empty then
4890 -- Case of pragma appearing after a compilation unit. In this case
4891 -- it must have an argument with the corresponding name and must
4892 -- be part of the following pragmas of its parent.
4894 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
4895 if Plist /= Pragmas_After (Parent_Node) then
4898 elsif Arg_Count = 0 then
4900 ("argument required if outside compilation unit");
4903 Check_No_Identifiers;
4904 Check_Arg_Count (1);
4905 Unit_Node := Unit (Parent (Parent_Node));
4906 Unit_Kind := Nkind (Unit_Node);
4908 Analyze (Get_Pragma_Arg (Arg1));
4910 if Unit_Kind = N_Generic_Subprogram_Declaration
4911 or else Unit_Kind = N_Subprogram_Declaration
4913 Unit_Name := Defining_Entity (Unit_Node);
4915 elsif Unit_Kind in N_Generic_Instantiation then
4916 Unit_Name := Defining_Entity (Unit_Node);
4919 Unit_Name := Cunit_Entity (Current_Sem_Unit);
4922 if Chars (Unit_Name) /=
4923 Chars (Entity (Get_Pragma_Arg (Arg1)))
4926 ("pragma% argument is not current unit name", Arg1);
4929 if Ekind (Unit_Name) = E_Package
4930 and then Present (Renamed_Entity (Unit_Name))
4932 Error_Pragma ("pragma% not allowed for renamed package");
4936 -- Pragma appears other than after a compilation unit
4939 -- Here we check for the generic instantiation case and also
4940 -- for the case of processing a generic formal package. We
4941 -- detect these cases by noting that the Sloc on the node
4942 -- does not belong to the current compilation unit.
4944 Sindex := Source_Index (Current_Sem_Unit);
4946 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
4947 Rewrite (N, Make_Null_Statement (Loc));
4950 -- If before first declaration, the pragma applies to the
4951 -- enclosing unit, and the name if present must be this name.
4953 elsif Is_Before_First_Decl (N, Plist) then
4954 Unit_Node := Unit_Declaration_Node (Current_Scope);
4955 Unit_Kind := Nkind (Unit_Node);
4957 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
4960 elsif Unit_Kind = N_Subprogram_Body
4961 and then not Acts_As_Spec (Unit_Node)
4965 elsif Nkind (Parent_Node) = N_Package_Body then
4968 elsif Nkind (Parent_Node) = N_Package_Specification
4969 and then Plist = Private_Declarations (Parent_Node)
4973 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
4974 or else Nkind (Parent_Node) =
4975 N_Generic_Subprogram_Declaration)
4976 and then Plist = Generic_Formal_Declarations (Parent_Node)
4980 elsif Arg_Count > 0 then
4981 Analyze (Get_Pragma_Arg (Arg1));
4983 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
4985 ("name in pragma% must be enclosing unit", Arg1);
4988 -- It is legal to have no argument in this context
4994 -- Error if not before first declaration. This is because a
4995 -- library unit pragma argument must be the name of a library
4996 -- unit (RM 10.1.5(7)), but the only names permitted in this
4997 -- context are (RM 10.1.5(6)) names of subprogram declarations,
4998 -- generic subprogram declarations or generic instantiations.
5002 ("pragma% misplaced, must be before first declaration");
5006 end Check_Valid_Library_Unit_Pragma;
5012 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5013 Clist : constant Node_Id := Component_List (Variant);
5017 Comp := First (Component_Items (Clist));
5018 while Present (Comp) loop
5019 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5028 procedure Error_Pragma (Msg : String) is
5029 MsgF : String := Msg;
5031 Error_Msg_Name_1 := Pname;
5033 Error_Msg_N (MsgF, N);
5037 ----------------------
5038 -- Error_Pragma_Arg --
5039 ----------------------
5041 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5042 MsgF : String := Msg;
5044 Error_Msg_Name_1 := Pname;
5046 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5048 end Error_Pragma_Arg;
5050 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5051 MsgF : String := Msg1;
5053 Error_Msg_Name_1 := Pname;
5055 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
5056 Error_Pragma_Arg (Msg2, Arg);
5057 end Error_Pragma_Arg;
5059 ----------------------------
5060 -- Error_Pragma_Arg_Ident --
5061 ----------------------------
5063 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5064 MsgF : String := Msg;
5066 Error_Msg_Name_1 := Pname;
5068 Error_Msg_N (MsgF, Arg);
5070 end Error_Pragma_Arg_Ident;
5072 ----------------------
5073 -- Error_Pragma_Ref --
5074 ----------------------
5076 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5077 MsgF : String := Msg;
5079 Error_Msg_Name_1 := Pname;
5081 Error_Msg_Sloc := Sloc (Ref);
5082 Error_Msg_NE (MsgF, N, Ref);
5084 end Error_Pragma_Ref;
5086 ------------------------
5087 -- Find_Lib_Unit_Name --
5088 ------------------------
5090 function Find_Lib_Unit_Name return Entity_Id is
5092 -- Return inner compilation unit entity, for case of nested
5093 -- categorization pragmas. This happens in generic unit.
5095 if Nkind (Parent (N)) = N_Package_Specification
5096 and then Defining_Entity (Parent (N)) /= Current_Scope
5098 return Defining_Entity (Parent (N));
5100 return Current_Scope;
5102 end Find_Lib_Unit_Name;
5104 ----------------------------
5105 -- Find_Program_Unit_Name --
5106 ----------------------------
5108 procedure Find_Program_Unit_Name (Id : Node_Id) is
5109 Unit_Name : Entity_Id;
5110 Unit_Kind : Node_Kind;
5111 P : constant Node_Id := Parent (N);
5114 if Nkind (P) = N_Compilation_Unit then
5115 Unit_Kind := Nkind (Unit (P));
5117 if Unit_Kind = N_Subprogram_Declaration
5118 or else Unit_Kind = N_Package_Declaration
5119 or else Unit_Kind in N_Generic_Declaration
5121 Unit_Name := Defining_Entity (Unit (P));
5123 if Chars (Id) = Chars (Unit_Name) then
5124 Set_Entity (Id, Unit_Name);
5125 Set_Etype (Id, Etype (Unit_Name));
5127 Set_Etype (Id, Any_Type);
5129 ("cannot find program unit referenced by pragma%");
5133 Set_Etype (Id, Any_Type);
5134 Error_Pragma ("pragma% inapplicable to this unit");
5140 end Find_Program_Unit_Name;
5142 -----------------------------------------
5143 -- Find_Unique_Parameterless_Procedure --
5144 -----------------------------------------
5146 function Find_Unique_Parameterless_Procedure
5148 Arg : Node_Id) return Entity_Id
5150 Proc : Entity_Id := Empty;
5153 -- The body of this procedure needs some comments ???
5155 if not Is_Entity_Name (Name) then
5157 ("argument of pragma% must be entity name", Arg);
5159 elsif not Is_Overloaded (Name) then
5160 Proc := Entity (Name);
5162 if Ekind (Proc) /= E_Procedure
5163 or else Present (First_Formal (Proc))
5166 ("argument of pragma% must be parameterless procedure", Arg);
5171 Found : Boolean := False;
5173 Index : Interp_Index;
5176 Get_First_Interp (Name, Index, It);
5177 while Present (It.Nam) loop
5180 if Ekind (Proc) = E_Procedure
5181 and then No (First_Formal (Proc))
5185 Set_Entity (Name, Proc);
5186 Set_Is_Overloaded (Name, False);
5189 ("ambiguous handler name for pragma% ", Arg);
5193 Get_Next_Interp (Index, It);
5198 ("argument of pragma% must be parameterless procedure",
5201 Proc := Entity (Name);
5207 end Find_Unique_Parameterless_Procedure;
5213 procedure Fix_Error (Msg : in out String) is
5215 -- If we have a rewriting of another pragma, go to that pragma
5217 if Is_Rewrite_Substitution (N)
5218 and then Nkind (Original_Node (N)) = N_Pragma
5220 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5223 -- Case where pragma comes from an aspect specification
5225 if From_Aspect_Specification (N) then
5227 -- Change appearence of "pragma" in message to "aspect"
5229 for J in Msg'First .. Msg'Last - 5 loop
5230 if Msg (J .. J + 5) = "pragma" then
5231 Msg (J .. J + 5) := "aspect";
5235 -- Get name from corresponding aspect
5237 Error_Msg_Name_1 := Original_Aspect_Name (N);
5241 -------------------------
5242 -- Gather_Associations --
5243 -------------------------
5245 procedure Gather_Associations
5247 Args : out Args_List)
5252 -- Initialize all parameters to Empty
5254 for J in Args'Range loop
5258 -- That's all we have to do if there are no argument associations
5260 if No (Pragma_Argument_Associations (N)) then
5264 -- Otherwise first deal with any positional parameters present
5266 Arg := First (Pragma_Argument_Associations (N));
5267 for Index in Args'Range loop
5268 exit when No (Arg) or else Chars (Arg) /= No_Name;
5269 Args (Index) := Get_Pragma_Arg (Arg);
5273 -- Positional parameters all processed, if any left, then we
5274 -- have too many positional parameters.
5276 if Present (Arg) and then Chars (Arg) = No_Name then
5278 ("too many positional associations for pragma%", Arg);
5281 -- Process named parameters if any are present
5283 while Present (Arg) loop
5284 if Chars (Arg) = No_Name then
5286 ("positional association cannot follow named association",
5290 for Index in Names'Range loop
5291 if Names (Index) = Chars (Arg) then
5292 if Present (Args (Index)) then
5294 ("duplicate argument association for pragma%", Arg);
5296 Args (Index) := Get_Pragma_Arg (Arg);
5301 if Index = Names'Last then
5302 Error_Msg_Name_1 := Pname;
5303 Error_Msg_N ("pragma% does not allow & argument", Arg);
5305 -- Check for possible misspelling
5307 for Index1 in Names'Range loop
5308 if Is_Bad_Spelling_Of
5309 (Chars (Arg), Names (Index1))
5311 Error_Msg_Name_1 := Names (Index1);
5312 Error_Msg_N -- CODEFIX
5313 ("\possible misspelling of%", Arg);
5325 end Gather_Associations;
5331 procedure GNAT_Pragma is
5333 -- We need to check the No_Implementation_Pragmas restriction for
5334 -- the case of a pragma from source. Note that the case of aspects
5335 -- generating corresponding pragmas marks these pragmas as not being
5336 -- from source, so this test also catches that case.
5338 if Comes_From_Source (N) then
5339 Check_Restriction (No_Implementation_Pragmas, N);
5343 --------------------------
5344 -- Is_Before_First_Decl --
5345 --------------------------
5347 function Is_Before_First_Decl
5348 (Pragma_Node : Node_Id;
5349 Decls : List_Id) return Boolean
5351 Item : Node_Id := First (Decls);
5354 -- Only other pragmas can come before this pragma
5357 if No (Item) or else Nkind (Item) /= N_Pragma then
5360 elsif Item = Pragma_Node then
5366 end Is_Before_First_Decl;
5368 -----------------------------
5369 -- Is_Configuration_Pragma --
5370 -----------------------------
5372 -- A configuration pragma must appear in the context clause of a
5373 -- compilation unit, and only other pragmas may precede it. Note that
5374 -- the test below also permits use in a configuration pragma file.
5376 function Is_Configuration_Pragma return Boolean is
5377 Lis : constant List_Id := List_Containing (N);
5378 Par : constant Node_Id := Parent (N);
5382 -- If no parent, then we are in the configuration pragma file,
5383 -- so the placement is definitely appropriate.
5388 -- Otherwise we must be in the context clause of a compilation unit
5389 -- and the only thing allowed before us in the context list is more
5390 -- configuration pragmas.
5392 elsif Nkind (Par) = N_Compilation_Unit
5393 and then Context_Items (Par) = Lis
5400 elsif Nkind (Prg) /= N_Pragma then
5410 end Is_Configuration_Pragma;
5412 --------------------------
5413 -- Is_In_Context_Clause --
5414 --------------------------
5416 function Is_In_Context_Clause return Boolean is
5418 Parent_Node : Node_Id;
5421 if not Is_List_Member (N) then
5425 Plist := List_Containing (N);
5426 Parent_Node := Parent (Plist);
5428 if Parent_Node = Empty
5429 or else Nkind (Parent_Node) /= N_Compilation_Unit
5430 or else Context_Items (Parent_Node) /= Plist
5437 end Is_In_Context_Clause;
5439 ---------------------------------
5440 -- Is_Static_String_Expression --
5441 ---------------------------------
5443 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
5444 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5447 Analyze_And_Resolve (Argx);
5448 return Is_OK_Static_Expression (Argx)
5449 and then Nkind (Argx) = N_String_Literal;
5450 end Is_Static_String_Expression;
5452 ----------------------
5453 -- Pragma_Misplaced --
5454 ----------------------
5456 procedure Pragma_Misplaced is
5458 Error_Pragma ("incorrect placement of pragma%");
5459 end Pragma_Misplaced;
5461 ------------------------------------
5462 -- Process_Atomic_Shared_Volatile --
5463 ------------------------------------
5465 procedure Process_Atomic_Shared_Volatile is
5472 procedure Set_Atomic (E : Entity_Id);
5473 -- Set given type as atomic, and if no explicit alignment was given,
5474 -- set alignment to unknown, since back end knows what the alignment
5475 -- requirements are for atomic arrays. Note: this step is necessary
5476 -- for derived types.
5482 procedure Set_Atomic (E : Entity_Id) is
5486 if not Has_Alignment_Clause (E) then
5487 Set_Alignment (E, Uint_0);
5491 -- Start of processing for Process_Atomic_Shared_Volatile
5494 Check_Ada_83_Warning;
5495 Check_No_Identifiers;
5496 Check_Arg_Count (1);
5497 Check_Arg_Is_Local_Name (Arg1);
5498 E_Id := Get_Pragma_Arg (Arg1);
5500 if Etype (E_Id) = Any_Type then
5505 D := Declaration_Node (E);
5508 -- Check duplicate before we chain ourselves!
5510 Check_Duplicate_Pragma (E);
5512 -- Now check appropriateness of the entity
5515 if Rep_Item_Too_Early (E, N)
5517 Rep_Item_Too_Late (E, N)
5521 Check_First_Subtype (Arg1);
5524 if Prag_Id /= Pragma_Volatile then
5526 Set_Atomic (Underlying_Type (E));
5527 Set_Atomic (Base_Type (E));
5530 -- Attribute belongs on the base type. If the view of the type is
5531 -- currently private, it also belongs on the underlying type.
5533 Set_Is_Volatile (Base_Type (E));
5534 Set_Is_Volatile (Underlying_Type (E));
5536 Set_Treat_As_Volatile (E);
5537 Set_Treat_As_Volatile (Underlying_Type (E));
5539 elsif K = N_Object_Declaration
5540 or else (K = N_Component_Declaration
5541 and then Original_Record_Component (E) = E)
5543 if Rep_Item_Too_Late (E, N) then
5547 if Prag_Id /= Pragma_Volatile then
5550 -- If the object declaration has an explicit initialization, a
5551 -- temporary may have to be created to hold the expression, to
5552 -- ensure that access to the object remain atomic.
5554 if Nkind (Parent (E)) = N_Object_Declaration
5555 and then Present (Expression (Parent (E)))
5557 Set_Has_Delayed_Freeze (E);
5560 -- An interesting improvement here. If an object of composite
5561 -- type X is declared atomic, and the type X isn't, that's a
5562 -- pity, since it may not have appropriate alignment etc. We
5563 -- can rescue this in the special case where the object and
5564 -- type are in the same unit by just setting the type as
5565 -- atomic, so that the back end will process it as atomic.
5567 -- Note: we used to do this for elementary types as well,
5568 -- but that turns out to be a bad idea and can have unwanted
5569 -- effects, most notably if the type is elementary, the object
5570 -- a simple component within a record, and both are in a spec:
5571 -- every object of this type in the entire program will be
5572 -- treated as atomic, thus incurring a potentially costly
5573 -- synchronization operation for every access.
5575 -- Of course it would be best if the back end could just adjust
5576 -- the alignment etc for the specific object, but that's not
5577 -- something we are capable of doing at this point.
5579 Utyp := Underlying_Type (Etype (E));
5582 and then Is_Composite_Type (Utyp)
5583 and then Sloc (E) > No_Location
5584 and then Sloc (Utyp) > No_Location
5586 Get_Source_File_Index (Sloc (E)) =
5587 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
5589 Set_Is_Atomic (Underlying_Type (Etype (E)));
5593 Set_Is_Volatile (E);
5594 Set_Treat_As_Volatile (E);
5598 ("inappropriate entity for pragma%", Arg1);
5600 end Process_Atomic_Shared_Volatile;
5602 -------------------------------------------
5603 -- Process_Compile_Time_Warning_Or_Error --
5604 -------------------------------------------
5606 procedure Process_Compile_Time_Warning_Or_Error is
5607 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
5610 Check_Arg_Count (2);
5611 Check_No_Identifiers;
5612 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
5613 Analyze_And_Resolve (Arg1x, Standard_Boolean);
5615 if Compile_Time_Known_Value (Arg1x) then
5616 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
5618 Str : constant String_Id :=
5619 Strval (Get_Pragma_Arg (Arg2));
5620 Len : constant Int := String_Length (Str);
5625 Cent : constant Entity_Id :=
5626 Cunit_Entity (Current_Sem_Unit);
5628 Force : constant Boolean :=
5629 Prag_Id = Pragma_Compile_Time_Warning
5631 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
5632 and then (Ekind (Cent) /= E_Package
5633 or else not In_Private_Part (Cent));
5634 -- Set True if this is the warning case, and we are in the
5635 -- visible part of a package spec, or in a subprogram spec,
5636 -- in which case we want to force the client to see the
5637 -- warning, even though it is not in the main unit.
5640 -- Loop through segments of message separated by line feeds.
5641 -- We output these segments as separate messages with
5642 -- continuation marks for all but the first.
5647 Error_Msg_Strlen := 0;
5649 -- Loop to copy characters from argument to error message
5653 exit when Ptr > Len;
5654 CC := Get_String_Char (Str, Ptr);
5657 -- Ignore wide chars ??? else store character
5659 if In_Character_Range (CC) then
5660 C := Get_Character (CC);
5661 exit when C = ASCII.LF;
5662 Error_Msg_Strlen := Error_Msg_Strlen + 1;
5663 Error_Msg_String (Error_Msg_Strlen) := C;
5667 -- Here with one line ready to go
5669 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
5671 -- If this is a warning in a spec, then we want clients
5672 -- to see the warning, so mark the message with the
5673 -- special sequence !! to force the warning. In the case
5674 -- of a package spec, we do not force this if we are in
5675 -- the private part of the spec.
5678 if Cont = False then
5679 Error_Msg_N ("<~!!", Arg1);
5682 Error_Msg_N ("\<~!!", Arg1);
5685 -- Error, rather than warning, or in a body, so we do not
5686 -- need to force visibility for client (error will be
5687 -- output in any case, and this is the situation in which
5688 -- we do not want a client to get a warning, since the
5689 -- warning is in the body or the spec private part).
5692 if Cont = False then
5693 Error_Msg_N ("<~", Arg1);
5696 Error_Msg_N ("\<~", Arg1);
5700 exit when Ptr > Len;
5705 end Process_Compile_Time_Warning_Or_Error;
5707 ------------------------
5708 -- Process_Convention --
5709 ------------------------
5711 procedure Process_Convention
5712 (C : out Convention_Id;
5713 Ent : out Entity_Id)
5719 Comp_Unit : Unit_Number_Type;
5721 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
5722 -- Called if we have more than one Export/Import/Convention pragma.
5723 -- This is generally illegal, but we have a special case of allowing
5724 -- Import and Interface to coexist if they specify the convention in
5725 -- a consistent manner. We are allowed to do this, since Interface is
5726 -- an implementation defined pragma, and we choose to do it since we
5727 -- know Rational allows this combination. S is the entity id of the
5728 -- subprogram in question. This procedure also sets the special flag
5729 -- Import_Interface_Present in both pragmas in the case where we do
5730 -- have matching Import and Interface pragmas.
5732 procedure Set_Convention_From_Pragma (E : Entity_Id);
5733 -- Set convention in entity E, and also flag that the entity has a
5734 -- convention pragma. If entity is for a private or incomplete type,
5735 -- also set convention and flag on underlying type. This procedure
5736 -- also deals with the special case of C_Pass_By_Copy convention.
5738 -------------------------------
5739 -- Diagnose_Multiple_Pragmas --
5740 -------------------------------
5742 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
5743 Pdec : constant Node_Id := Declaration_Node (S);
5747 function Same_Convention (Decl : Node_Id) return Boolean;
5748 -- Decl is a pragma node. This function returns True if this
5749 -- pragma has a first argument that is an identifier with a
5750 -- Chars field corresponding to the Convention_Id C.
5752 function Same_Name (Decl : Node_Id) return Boolean;
5753 -- Decl is a pragma node. This function returns True if this
5754 -- pragma has a second argument that is an identifier with a
5755 -- Chars field that matches the Chars of the current subprogram.
5757 ---------------------
5758 -- Same_Convention --
5759 ---------------------
5761 function Same_Convention (Decl : Node_Id) return Boolean is
5762 Arg1 : constant Node_Id :=
5763 First (Pragma_Argument_Associations (Decl));
5766 if Present (Arg1) then
5768 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
5770 if Nkind (Arg) = N_Identifier
5771 and then Is_Convention_Name (Chars (Arg))
5772 and then Get_Convention_Id (Chars (Arg)) = C
5780 end Same_Convention;
5786 function Same_Name (Decl : Node_Id) return Boolean is
5787 Arg1 : constant Node_Id :=
5788 First (Pragma_Argument_Associations (Decl));
5796 Arg2 := Next (Arg1);
5803 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
5805 if Nkind (Arg) = N_Identifier
5806 and then Chars (Arg) = Chars (S)
5815 -- Start of processing for Diagnose_Multiple_Pragmas
5820 -- Definitely give message if we have Convention/Export here
5822 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
5825 -- If we have an Import or Export, scan back from pragma to
5826 -- find any previous pragma applying to the same procedure.
5827 -- The scan will be terminated by the start of the list, or
5828 -- hitting the subprogram declaration. This won't allow one
5829 -- pragma to appear in the public part and one in the private
5830 -- part, but that seems very unlikely in practice.
5834 while Present (Decl) and then Decl /= Pdec loop
5836 -- Look for pragma with same name as us
5838 if Nkind (Decl) = N_Pragma
5839 and then Same_Name (Decl)
5841 -- Give error if same as our pragma or Export/Convention
5843 if Nam_In (Pragma_Name (Decl), Name_Export,
5849 -- Case of Import/Interface or the other way round
5851 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
5854 -- Here we know that we have Import and Interface. It
5855 -- doesn't matter which way round they are. See if
5856 -- they specify the same convention. If so, all OK,
5857 -- and set special flags to stop other messages
5859 if Same_Convention (Decl) then
5860 Set_Import_Interface_Present (N);
5861 Set_Import_Interface_Present (Decl);
5864 -- If different conventions, special message
5867 Error_Msg_Sloc := Sloc (Decl);
5869 ("convention differs from that given#", Arg1);
5879 -- Give message if needed if we fall through those tests
5880 -- except on Relaxed_RM_Semantics where we let go: either this
5881 -- is a case accepted/ignored by other Ada compilers (e.g.
5882 -- a mix of Convention and Import), or another error will be
5883 -- generated later (e.g. using both Import and Export).
5885 if Err and not Relaxed_RM_Semantics then
5887 ("at most one Convention/Export/Import pragma is allowed",
5890 end Diagnose_Multiple_Pragmas;
5892 --------------------------------
5893 -- Set_Convention_From_Pragma --
5894 --------------------------------
5896 procedure Set_Convention_From_Pragma (E : Entity_Id) is
5898 -- Ada 2005 (AI-430): Check invalid attempt to change convention
5899 -- for an overridden dispatching operation. Technically this is
5900 -- an amendment and should only be done in Ada 2005 mode. However,
5901 -- this is clearly a mistake, since the problem that is addressed
5902 -- by this AI is that there is a clear gap in the RM!
5904 if Is_Dispatching_Operation (E)
5905 and then Present (Overridden_Operation (E))
5906 and then C /= Convention (Overridden_Operation (E))
5908 -- An attempt to override a subprogram with a ghost subprogram
5909 -- appears as a mismatch in conventions.
5911 if C = Convention_Ghost then
5912 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
5915 ("cannot change convention for overridden dispatching "
5916 & "operation", Arg1);
5920 -- Special checks for Convention_Stdcall
5922 if C = Convention_Stdcall then
5924 -- A dispatching call is not allowed. A dispatching subprogram
5925 -- cannot be used to interface to the Win32 API, so in fact
5926 -- this check does not impose any effective restriction.
5928 if Is_Dispatching_Operation (E) then
5929 Error_Msg_Sloc := Sloc (E);
5931 -- Note: make this unconditional so that if there is more
5932 -- than one call to which the pragma applies, we get a
5933 -- message for each call. Also don't use Error_Pragma,
5934 -- so that we get multiple messages!
5937 ("dispatching subprogram# cannot use Stdcall convention!",
5940 -- Subprogram is allowed, but not a generic subprogram
5942 elsif not Is_Subprogram (E)
5943 and then not Is_Generic_Subprogram (E)
5947 and then Ekind (E) /= E_Variable
5949 -- An access to subprogram is also allowed
5953 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
5955 -- Allow internal call to set convention of subprogram type
5957 and then not (Ekind (E) = E_Subprogram_Type)
5960 ("second argument of pragma% must be subprogram (type)",
5965 -- Set the convention
5967 Set_Convention (E, C);
5968 Set_Has_Convention_Pragma (E);
5970 if Is_Incomplete_Or_Private_Type (E)
5971 and then Present (Underlying_Type (E))
5973 Set_Convention (Underlying_Type (E), C);
5974 Set_Has_Convention_Pragma (Underlying_Type (E), True);
5977 -- A class-wide type should inherit the convention of the specific
5978 -- root type (although this isn't specified clearly by the RM).
5980 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
5981 Set_Convention (Class_Wide_Type (E), C);
5984 -- If the entity is a record type, then check for special case of
5985 -- C_Pass_By_Copy, which is treated the same as C except that the
5986 -- special record flag is set. This convention is only permitted
5987 -- on record types (see AI95-00131).
5989 if Cname = Name_C_Pass_By_Copy then
5990 if Is_Record_Type (E) then
5991 Set_C_Pass_By_Copy (Base_Type (E));
5992 elsif Is_Incomplete_Or_Private_Type (E)
5993 and then Is_Record_Type (Underlying_Type (E))
5995 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
5998 ("C_Pass_By_Copy convention allowed only for record type",
6003 -- If the entity is a derived boolean type, check for the special
6004 -- case of convention C, C++, or Fortran, where we consider any
6005 -- nonzero value to represent true.
6007 if Is_Discrete_Type (E)
6008 and then Root_Type (Etype (E)) = Standard_Boolean
6014 C = Convention_Fortran)
6016 Set_Nonzero_Is_True (Base_Type (E));
6018 end Set_Convention_From_Pragma;
6020 -- Start of processing for Process_Convention
6023 Check_At_Least_N_Arguments (2);
6024 Check_Optional_Identifier (Arg1, Name_Convention);
6025 Check_Arg_Is_Identifier (Arg1);
6026 Cname := Chars (Get_Pragma_Arg (Arg1));
6028 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6029 -- tested again below to set the critical flag).
6031 if Cname = Name_C_Pass_By_Copy then
6034 -- Otherwise we must have something in the standard convention list
6036 elsif Is_Convention_Name (Cname) then
6037 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6039 -- In DEC VMS, it seems that there is an undocumented feature that
6040 -- any unrecognized convention is treated as the default, which for
6041 -- us is convention C. It does not seem so terrible to do this
6042 -- unconditionally, silently in the VMS case, and with a warning
6043 -- in the non-VMS case.
6046 if Warn_On_Export_Import and not OpenVMS_On_Target then
6048 ("??unrecognized convention name, C assumed",
6049 Get_Pragma_Arg (Arg1));
6055 Check_Optional_Identifier (Arg2, Name_Entity);
6056 Check_Arg_Is_Local_Name (Arg2);
6058 Id := Get_Pragma_Arg (Arg2);
6061 if not Is_Entity_Name (Id) then
6062 Error_Pragma_Arg ("entity name required", Arg2);
6067 -- Set entity to return
6071 -- Ada_Pass_By_Copy special checking
6073 if C = Convention_Ada_Pass_By_Copy then
6074 if not Is_First_Subtype (E) then
6076 ("convention `Ada_Pass_By_Copy` only allowed for types",
6080 if Is_By_Reference_Type (E) then
6082 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6087 -- Ada_Pass_By_Reference special checking
6089 if C = Convention_Ada_Pass_By_Reference then
6090 if not Is_First_Subtype (E) then
6092 ("convention `Ada_Pass_By_Reference` only allowed for types",
6096 if Is_By_Copy_Type (E) then
6098 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6103 -- Ghost special checking
6105 if Is_Ghost_Subprogram (E)
6106 and then Present (Overridden_Operation (E))
6108 Error_Msg_N ("ghost subprogram & cannot be overriding", E);
6111 -- Go to renamed subprogram if present, since convention applies to
6112 -- the actual renamed entity, not to the renaming entity. If the
6113 -- subprogram is inherited, go to parent subprogram.
6115 if Is_Subprogram (E)
6116 and then Present (Alias (E))
6118 if Nkind (Parent (Declaration_Node (E))) =
6119 N_Subprogram_Renaming_Declaration
6121 if Scope (E) /= Scope (Alias (E)) then
6123 ("cannot apply pragma% to non-local entity&#", E);
6128 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6129 N_Private_Extension_Declaration)
6130 and then Scope (E) = Scope (Alias (E))
6134 -- Return the parent subprogram the entity was inherited from
6140 -- Check that we are not applying this to a specless body
6141 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6144 if Is_Subprogram (E)
6145 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6146 and then not Relaxed_RM_Semantics
6149 ("pragma% requires separate spec and must come before body");
6152 -- Check that we are not applying this to a named constant
6154 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6155 Error_Msg_Name_1 := Pname;
6157 ("cannot apply pragma% to named constant!",
6158 Get_Pragma_Arg (Arg2));
6160 ("\supply appropriate type for&!", Arg2);
6163 if Ekind (E) = E_Enumeration_Literal then
6164 Error_Pragma ("enumeration literal not allowed for pragma%");
6167 -- Check for rep item appearing too early or too late
6169 if Etype (E) = Any_Type
6170 or else Rep_Item_Too_Early (E, N)
6174 elsif Present (Underlying_Type (E)) then
6175 E := Underlying_Type (E);
6178 if Rep_Item_Too_Late (E, N) then
6182 if Has_Convention_Pragma (E) then
6183 Diagnose_Multiple_Pragmas (E);
6185 elsif Convention (E) = Convention_Protected
6186 or else Ekind (Scope (E)) = E_Protected_Type
6189 ("a protected operation cannot be given a different convention",
6193 -- For Intrinsic, a subprogram is required
6195 if C = Convention_Intrinsic
6196 and then not Is_Subprogram (E)
6197 and then not Is_Generic_Subprogram (E)
6200 ("second argument of pragma% must be a subprogram", Arg2);
6203 -- Deal with non-subprogram cases
6205 if not Is_Subprogram (E)
6206 and then not Is_Generic_Subprogram (E)
6208 Set_Convention_From_Pragma (E);
6211 Check_First_Subtype (Arg2);
6212 Set_Convention_From_Pragma (Base_Type (E));
6214 -- For access subprograms, we must set the convention on the
6215 -- internally generated directly designated type as well.
6217 if Ekind (E) = E_Access_Subprogram_Type then
6218 Set_Convention_From_Pragma (Directly_Designated_Type (E));
6222 -- For the subprogram case, set proper convention for all homonyms
6223 -- in same scope and the same declarative part, i.e. the same
6224 -- compilation unit.
6227 Comp_Unit := Get_Source_Unit (E);
6228 Set_Convention_From_Pragma (E);
6230 -- Treat a pragma Import as an implicit body, and pragma import
6231 -- as implicit reference (for navigation in GPS).
6233 if Prag_Id = Pragma_Import then
6234 Generate_Reference (E, Id, 'b');
6236 -- For exported entities we restrict the generation of references
6237 -- to entities exported to foreign languages since entities
6238 -- exported to Ada do not provide further information to GPS and
6239 -- add undesired references to the output of the gnatxref tool.
6241 elsif Prag_Id = Pragma_Export
6242 and then Convention (E) /= Convention_Ada
6244 Generate_Reference (E, Id, 'i');
6247 -- If the pragma comes from from an aspect, it only applies to the
6248 -- given entity, not its homonyms.
6250 if From_Aspect_Specification (N) then
6254 -- Otherwise Loop through the homonyms of the pragma argument's
6255 -- entity, an apply convention to those in the current scope.
6261 exit when No (E1) or else Scope (E1) /= Current_Scope;
6263 -- Ignore entry for which convention is already set
6265 if Has_Convention_Pragma (E1) then
6269 -- Do not set the pragma on inherited operations or on formal
6272 if Comes_From_Source (E1)
6273 and then Comp_Unit = Get_Source_Unit (E1)
6274 and then not Is_Formal_Subprogram (E1)
6275 and then Nkind (Original_Node (Parent (E1))) /=
6276 N_Full_Type_Declaration
6278 if Present (Alias (E1))
6279 and then Scope (E1) /= Scope (Alias (E1))
6282 ("cannot apply pragma% to non-local entity& declared#",
6286 Set_Convention_From_Pragma (E1);
6288 if Prag_Id = Pragma_Import then
6289 Generate_Reference (E1, Id, 'b');
6297 end Process_Convention;
6299 ----------------------------------------
6300 -- Process_Disable_Enable_Atomic_Sync --
6301 ----------------------------------------
6303 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
6305 Check_No_Identifiers;
6306 Check_At_Most_N_Arguments (1);
6308 -- Modeled internally as
6309 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6313 Pragma_Identifier =>
6314 Make_Identifier (Loc, Nam),
6315 Pragma_Argument_Associations => New_List (
6316 Make_Pragma_Argument_Association (Loc,
6318 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
6320 if Present (Arg1) then
6321 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
6325 end Process_Disable_Enable_Atomic_Sync;
6327 -----------------------------------------------------
6328 -- Process_Extended_Import_Export_Exception_Pragma --
6329 -----------------------------------------------------
6331 procedure Process_Extended_Import_Export_Exception_Pragma
6332 (Arg_Internal : Node_Id;
6333 Arg_External : Node_Id;
6341 if not OpenVMS_On_Target then
6343 ("??pragma% ignored (applies only to Open'V'M'S)");
6346 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6347 Def_Id := Entity (Arg_Internal);
6349 if Ekind (Def_Id) /= E_Exception then
6351 ("pragma% must refer to declared exception", Arg_Internal);
6354 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6356 if Present (Arg_Form) then
6357 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
6360 if Present (Arg_Form)
6361 and then Chars (Arg_Form) = Name_Ada
6365 Set_Is_VMS_Exception (Def_Id);
6366 Set_Exception_Code (Def_Id, No_Uint);
6369 if Present (Arg_Code) then
6370 if not Is_VMS_Exception (Def_Id) then
6372 ("Code option for pragma% not allowed for Ada case",
6376 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
6377 Code_Val := Expr_Value (Arg_Code);
6379 if not UI_Is_In_Int_Range (Code_Val) then
6381 ("Code option for pragma% must be in 32-bit range",
6385 Set_Exception_Code (Def_Id, Code_Val);
6388 end Process_Extended_Import_Export_Exception_Pragma;
6390 -------------------------------------------------
6391 -- Process_Extended_Import_Export_Internal_Arg --
6392 -------------------------------------------------
6394 procedure Process_Extended_Import_Export_Internal_Arg
6395 (Arg_Internal : Node_Id := Empty)
6398 if No (Arg_Internal) then
6399 Error_Pragma ("Internal parameter required for pragma%");
6402 if Nkind (Arg_Internal) = N_Identifier then
6405 elsif Nkind (Arg_Internal) = N_Operator_Symbol
6406 and then (Prag_Id = Pragma_Import_Function
6408 Prag_Id = Pragma_Export_Function)
6414 ("wrong form for Internal parameter for pragma%", Arg_Internal);
6417 Check_Arg_Is_Local_Name (Arg_Internal);
6418 end Process_Extended_Import_Export_Internal_Arg;
6420 --------------------------------------------------
6421 -- Process_Extended_Import_Export_Object_Pragma --
6422 --------------------------------------------------
6424 procedure Process_Extended_Import_Export_Object_Pragma
6425 (Arg_Internal : Node_Id;
6426 Arg_External : Node_Id;
6432 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6433 Def_Id := Entity (Arg_Internal);
6435 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
6437 ("pragma% must designate an object", Arg_Internal);
6440 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
6442 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
6445 ("previous Common/Psect_Object applies, pragma % not permitted",
6449 if Rep_Item_Too_Late (Def_Id, N) then
6453 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
6455 if Present (Arg_Size) then
6456 Check_Arg_Is_External_Name (Arg_Size);
6459 -- Export_Object case
6461 if Prag_Id = Pragma_Export_Object then
6462 if not Is_Library_Level_Entity (Def_Id) then
6464 ("argument for pragma% must be library level entity",
6468 if Ekind (Current_Scope) = E_Generic_Package then
6469 Error_Pragma ("pragma& cannot appear in a generic unit");
6472 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
6474 ("exported object must have compile time known size",
6478 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
6479 Error_Msg_N ("??duplicate Export_Object pragma", N);
6481 Set_Exported (Def_Id, Arg_Internal);
6484 -- Import_Object case
6487 if Is_Concurrent_Type (Etype (Def_Id)) then
6489 ("cannot use pragma% for task/protected object",
6493 if Ekind (Def_Id) = E_Constant then
6495 ("cannot import a constant", Arg_Internal);
6498 if Warn_On_Export_Import
6499 and then Has_Discriminants (Etype (Def_Id))
6502 ("imported value must be initialized??", Arg_Internal);
6505 if Warn_On_Export_Import
6506 and then Is_Access_Type (Etype (Def_Id))
6509 ("cannot import object of an access type??", Arg_Internal);
6512 if Warn_On_Export_Import
6513 and then Is_Imported (Def_Id)
6515 Error_Msg_N ("??duplicate Import_Object pragma", N);
6517 -- Check for explicit initialization present. Note that an
6518 -- initialization generated by the code generator, e.g. for an
6519 -- access type, does not count here.
6521 elsif Present (Expression (Parent (Def_Id)))
6524 (Original_Node (Expression (Parent (Def_Id))))
6526 Error_Msg_Sloc := Sloc (Def_Id);
6528 ("imported entities cannot be initialized (RM B.1(24))",
6529 "\no initialization allowed for & declared#", Arg1);
6531 Set_Imported (Def_Id);
6532 Note_Possible_Modification (Arg_Internal, Sure => False);
6535 end Process_Extended_Import_Export_Object_Pragma;
6537 ------------------------------------------------------
6538 -- Process_Extended_Import_Export_Subprogram_Pragma --
6539 ------------------------------------------------------
6541 procedure Process_Extended_Import_Export_Subprogram_Pragma
6542 (Arg_Internal : Node_Id;
6543 Arg_External : Node_Id;
6544 Arg_Parameter_Types : Node_Id;
6545 Arg_Result_Type : Node_Id := Empty;
6546 Arg_Mechanism : Node_Id;
6547 Arg_Result_Mechanism : Node_Id := Empty;
6548 Arg_First_Optional_Parameter : Node_Id := Empty)
6554 Ambiguous : Boolean;
6558 function Same_Base_Type
6560 Formal : Entity_Id) return Boolean;
6561 -- Determines if Ptype references the type of Formal. Note that only
6562 -- the base types need to match according to the spec. Ptype here is
6563 -- the argument from the pragma, which is either a type name, or an
6564 -- access attribute.
6566 --------------------
6567 -- Same_Base_Type --
6568 --------------------
6570 function Same_Base_Type
6572 Formal : Entity_Id) return Boolean
6574 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
6578 -- Case where pragma argument is typ'Access
6580 if Nkind (Ptype) = N_Attribute_Reference
6581 and then Attribute_Name (Ptype) = Name_Access
6583 Pref := Prefix (Ptype);
6586 if not Is_Entity_Name (Pref)
6587 or else Entity (Pref) = Any_Type
6592 -- We have a match if the corresponding argument is of an
6593 -- anonymous access type, and its designated type matches the
6594 -- type of the prefix of the access attribute
6596 return Ekind (Ftyp) = E_Anonymous_Access_Type
6597 and then Base_Type (Entity (Pref)) =
6598 Base_Type (Etype (Designated_Type (Ftyp)));
6600 -- Case where pragma argument is a type name
6605 if not Is_Entity_Name (Ptype)
6606 or else Entity (Ptype) = Any_Type
6611 -- We have a match if the corresponding argument is of the type
6612 -- given in the pragma (comparing base types)
6614 return Base_Type (Entity (Ptype)) = Ftyp;
6618 -- Start of processing for
6619 -- Process_Extended_Import_Export_Subprogram_Pragma
6622 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
6626 -- Loop through homonyms (overloadings) of the entity
6628 Hom_Id := Entity (Arg_Internal);
6629 while Present (Hom_Id) loop
6630 Def_Id := Get_Base_Subprogram (Hom_Id);
6632 -- We need a subprogram in the current scope
6634 if not Is_Subprogram (Def_Id)
6635 or else Scope (Def_Id) /= Current_Scope
6642 -- Pragma cannot apply to subprogram body
6644 if Is_Subprogram (Def_Id)
6645 and then Nkind (Parent (Declaration_Node (Def_Id))) =
6649 ("pragma% requires separate spec"
6650 & " and must come before body");
6653 -- Test result type if given, note that the result type
6654 -- parameter can only be present for the function cases.
6656 if Present (Arg_Result_Type)
6657 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
6661 elsif Etype (Def_Id) /= Standard_Void_Type
6663 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
6667 -- Test parameter types if given. Note that this parameter
6668 -- has not been analyzed (and must not be, since it is
6669 -- semantic nonsense), so we get it as the parser left it.
6671 elsif Present (Arg_Parameter_Types) then
6672 Check_Matching_Types : declare
6677 Formal := First_Formal (Def_Id);
6679 if Nkind (Arg_Parameter_Types) = N_Null then
6680 if Present (Formal) then
6684 -- A list of one type, e.g. (List) is parsed as
6685 -- a parenthesized expression.
6687 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
6688 and then Paren_Count (Arg_Parameter_Types) = 1
6691 or else Present (Next_Formal (Formal))
6696 Same_Base_Type (Arg_Parameter_Types, Formal);
6699 -- A list of more than one type is parsed as a aggregate
6701 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
6702 and then Paren_Count (Arg_Parameter_Types) = 0
6704 Ptype := First (Expressions (Arg_Parameter_Types));
6705 while Present (Ptype) or else Present (Formal) loop
6708 or else not Same_Base_Type (Ptype, Formal)
6713 Next_Formal (Formal);
6718 -- Anything else is of the wrong form
6722 ("wrong form for Parameter_Types parameter",
6723 Arg_Parameter_Types);
6725 end Check_Matching_Types;
6728 -- Match is now False if the entry we found did not match
6729 -- either a supplied Parameter_Types or Result_Types argument
6735 -- Ambiguous case, the flag Ambiguous shows if we already
6736 -- detected this and output the initial messages.
6739 if not Ambiguous then
6741 Error_Msg_Name_1 := Pname;
6743 ("pragma% does not uniquely identify subprogram!",
6745 Error_Msg_Sloc := Sloc (Ent);
6746 Error_Msg_N ("matching subprogram #!", N);
6750 Error_Msg_Sloc := Sloc (Def_Id);
6751 Error_Msg_N ("matching subprogram #!", N);
6756 Hom_Id := Homonym (Hom_Id);
6759 -- See if we found an entry
6762 if not Ambiguous then
6763 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
6765 ("pragma% cannot be given for generic subprogram");
6768 ("pragma% does not identify local subprogram");
6775 -- Import pragmas must be for imported entities
6777 if Prag_Id = Pragma_Import_Function
6779 Prag_Id = Pragma_Import_Procedure
6781 Prag_Id = Pragma_Import_Valued_Procedure
6783 if not Is_Imported (Ent) then
6785 ("pragma Import or Interface must precede pragma%");
6788 -- Here we have the Export case which can set the entity as exported
6790 -- But does not do so if the specified external name is null, since
6791 -- that is taken as a signal in DEC Ada 83 (with which we want to be
6792 -- compatible) to request no external name.
6794 elsif Nkind (Arg_External) = N_String_Literal
6795 and then String_Length (Strval (Arg_External)) = 0
6799 -- In all other cases, set entity as exported
6802 Set_Exported (Ent, Arg_Internal);
6805 -- Special processing for Valued_Procedure cases
6807 if Prag_Id = Pragma_Import_Valued_Procedure
6809 Prag_Id = Pragma_Export_Valued_Procedure
6811 Formal := First_Formal (Ent);
6814 Error_Pragma ("at least one parameter required for pragma%");
6816 elsif Ekind (Formal) /= E_Out_Parameter then
6817 Error_Pragma ("first parameter must have mode out for pragma%");
6820 Set_Is_Valued_Procedure (Ent);
6824 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
6826 -- Process Result_Mechanism argument if present. We have already
6827 -- checked that this is only allowed for the function case.
6829 if Present (Arg_Result_Mechanism) then
6830 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
6833 -- Process Mechanism parameter if present. Note that this parameter
6834 -- is not analyzed, and must not be analyzed since it is semantic
6835 -- nonsense, so we get it in exactly as the parser left it.
6837 if Present (Arg_Mechanism) then
6845 -- A single mechanism association without a formal parameter
6846 -- name is parsed as a parenthesized expression. All other
6847 -- cases are parsed as aggregates, so we rewrite the single
6848 -- parameter case as an aggregate for consistency.
6850 if Nkind (Arg_Mechanism) /= N_Aggregate
6851 and then Paren_Count (Arg_Mechanism) = 1
6853 Rewrite (Arg_Mechanism,
6854 Make_Aggregate (Sloc (Arg_Mechanism),
6855 Expressions => New_List (
6856 Relocate_Node (Arg_Mechanism))));
6859 -- Case of only mechanism name given, applies to all formals
6861 if Nkind (Arg_Mechanism) /= N_Aggregate then
6862 Formal := First_Formal (Ent);
6863 while Present (Formal) loop
6864 Set_Mechanism_Value (Formal, Arg_Mechanism);
6865 Next_Formal (Formal);
6868 -- Case of list of mechanism associations given
6871 if Null_Record_Present (Arg_Mechanism) then
6873 ("inappropriate form for Mechanism parameter",
6877 -- Deal with positional ones first
6879 Formal := First_Formal (Ent);
6881 if Present (Expressions (Arg_Mechanism)) then
6882 Mname := First (Expressions (Arg_Mechanism));
6883 while Present (Mname) loop
6886 ("too many mechanism associations", Mname);
6889 Set_Mechanism_Value (Formal, Mname);
6890 Next_Formal (Formal);
6895 -- Deal with named entries
6897 if Present (Component_Associations (Arg_Mechanism)) then
6898 Massoc := First (Component_Associations (Arg_Mechanism));
6899 while Present (Massoc) loop
6900 Choice := First (Choices (Massoc));
6902 if Nkind (Choice) /= N_Identifier
6903 or else Present (Next (Choice))
6906 ("incorrect form for mechanism association",
6910 Formal := First_Formal (Ent);
6914 ("parameter name & not present", Choice);
6917 if Chars (Choice) = Chars (Formal) then
6919 (Formal, Expression (Massoc));
6921 -- Set entity on identifier (needed by ASIS)
6923 Set_Entity (Choice, Formal);
6928 Next_Formal (Formal);
6938 -- Process First_Optional_Parameter argument if present. We have
6939 -- already checked that this is only allowed for the Import case.
6941 if Present (Arg_First_Optional_Parameter) then
6942 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
6944 ("first optional parameter must be formal parameter name",
6945 Arg_First_Optional_Parameter);
6948 Formal := First_Formal (Ent);
6952 ("specified formal parameter& not found",
6953 Arg_First_Optional_Parameter);
6956 exit when Chars (Formal) =
6957 Chars (Arg_First_Optional_Parameter);
6959 Next_Formal (Formal);
6962 Set_First_Optional_Parameter (Ent, Formal);
6964 -- Check specified and all remaining formals have right form
6966 while Present (Formal) loop
6967 if Ekind (Formal) /= E_In_Parameter then
6969 ("optional formal& is not of mode in!",
6970 Arg_First_Optional_Parameter, Formal);
6973 Dval := Default_Value (Formal);
6977 ("optional formal& does not have default value!",
6978 Arg_First_Optional_Parameter, Formal);
6980 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
6985 ("default value for optional formal& is non-static!",
6986 Arg_First_Optional_Parameter, Formal);
6990 Set_Is_Optional_Parameter (Formal);
6991 Next_Formal (Formal);
6994 end Process_Extended_Import_Export_Subprogram_Pragma;
6996 --------------------------
6997 -- Process_Generic_List --
6998 --------------------------
7000 procedure Process_Generic_List is
7005 Check_No_Identifiers;
7006 Check_At_Least_N_Arguments (1);
7008 -- Check all arguments are names of generic units or instances
7011 while Present (Arg) loop
7012 Exp := Get_Pragma_Arg (Arg);
7015 if not Is_Entity_Name (Exp)
7017 (not Is_Generic_Instance (Entity (Exp))
7019 not Is_Generic_Unit (Entity (Exp)))
7022 ("pragma% argument must be name of generic unit/instance",
7028 end Process_Generic_List;
7030 ------------------------------------
7031 -- Process_Import_Predefined_Type --
7032 ------------------------------------
7034 procedure Process_Import_Predefined_Type is
7035 Loc : constant Source_Ptr := Sloc (N);
7037 Ftyp : Node_Id := Empty;
7043 String_To_Name_Buffer (Strval (Expression (Arg3)));
7046 Elmt := First_Elmt (Predefined_Float_Types);
7047 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7051 Ftyp := Node (Elmt);
7053 if Present (Ftyp) then
7055 -- Don't build a derived type declaration, because predefined C
7056 -- types have no declaration anywhere, so cannot really be named.
7057 -- Instead build a full type declaration, starting with an
7058 -- appropriate type definition is built
7060 if Is_Floating_Point_Type (Ftyp) then
7061 Def := Make_Floating_Point_Definition (Loc,
7062 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7063 Make_Real_Range_Specification (Loc,
7064 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7065 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7067 -- Should never have a predefined type we cannot handle
7070 raise Program_Error;
7073 -- Build and insert a Full_Type_Declaration, which will be
7074 -- analyzed as soon as this list entry has been analyzed.
7076 Decl := Make_Full_Type_Declaration (Loc,
7077 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7078 Type_Definition => Def);
7080 Insert_After (N, Decl);
7081 Mark_Rewrite_Insertion (Decl);
7084 Error_Pragma_Arg ("no matching type found for pragma%",
7087 end Process_Import_Predefined_Type;
7089 ---------------------------------
7090 -- Process_Import_Or_Interface --
7091 ---------------------------------
7093 procedure Process_Import_Or_Interface is
7099 Process_Convention (C, Def_Id);
7100 Kill_Size_Check_Code (Def_Id);
7101 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7103 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7105 -- We do not permit Import to apply to a renaming declaration
7107 if Present (Renamed_Object (Def_Id)) then
7109 ("pragma% not allowed for object renaming", Arg2);
7111 -- User initialization is not allowed for imported object, but
7112 -- the object declaration may contain a default initialization,
7113 -- that will be discarded. Note that an explicit initialization
7114 -- only counts if it comes from source, otherwise it is simply
7115 -- the code generator making an implicit initialization explicit.
7117 elsif Present (Expression (Parent (Def_Id)))
7118 and then Comes_From_Source (Expression (Parent (Def_Id)))
7120 Error_Msg_Sloc := Sloc (Def_Id);
7122 ("no initialization allowed for declaration of& #",
7123 "\imported entities cannot be initialized (RM B.1(24))",
7127 Set_Imported (Def_Id);
7128 Process_Interface_Name (Def_Id, Arg3, Arg4);
7130 -- Note that we do not set Is_Public here. That's because we
7131 -- only want to set it if there is no address clause, and we
7132 -- don't know that yet, so we delay that processing till
7135 -- pragma Import completes deferred constants
7137 if Ekind (Def_Id) = E_Constant then
7138 Set_Has_Completion (Def_Id);
7141 -- It is not possible to import a constant of an unconstrained
7142 -- array type (e.g. string) because there is no simple way to
7143 -- write a meaningful subtype for it.
7145 if Is_Array_Type (Etype (Def_Id))
7146 and then not Is_Constrained (Etype (Def_Id))
7149 ("imported constant& must have a constrained subtype",
7154 elsif Is_Subprogram (Def_Id)
7155 or else Is_Generic_Subprogram (Def_Id)
7157 -- If the name is overloaded, pragma applies to all of the denoted
7158 -- entities in the same declarative part, unless the pragma comes
7159 -- from an aspect specification.
7162 while Present (Hom_Id) loop
7164 Def_Id := Get_Base_Subprogram (Hom_Id);
7166 -- Ignore inherited subprograms because the pragma will apply
7167 -- to the parent operation, which is the one called.
7169 if Is_Overloadable (Def_Id)
7170 and then Present (Alias (Def_Id))
7174 -- If it is not a subprogram, it must be in an outer scope and
7175 -- pragma does not apply.
7177 elsif not Is_Subprogram (Def_Id)
7178 and then not Is_Generic_Subprogram (Def_Id)
7182 -- The pragma does not apply to primitives of interfaces
7184 elsif Is_Dispatching_Operation (Def_Id)
7185 and then Present (Find_Dispatching_Type (Def_Id))
7186 and then Is_Interface (Find_Dispatching_Type (Def_Id))
7190 -- Verify that the homonym is in the same declarative part (not
7191 -- just the same scope). If the pragma comes from an aspect
7192 -- specification we know that it is part of the declaration.
7194 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
7195 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
7196 and then not From_Aspect_Specification (N)
7201 Set_Imported (Def_Id);
7203 -- Reject an Import applied to an abstract subprogram
7205 if Is_Subprogram (Def_Id)
7206 and then Is_Abstract_Subprogram (Def_Id)
7208 Error_Msg_Sloc := Sloc (Def_Id);
7210 ("cannot import abstract subprogram& declared#",
7214 -- Special processing for Convention_Intrinsic
7216 if C = Convention_Intrinsic then
7218 -- Link_Name argument not allowed for intrinsic
7222 Set_Is_Intrinsic_Subprogram (Def_Id);
7224 -- If no external name is present, then check that this
7225 -- is a valid intrinsic subprogram. If an external name
7226 -- is present, then this is handled by the back end.
7229 Check_Intrinsic_Subprogram
7230 (Def_Id, Get_Pragma_Arg (Arg2));
7234 -- All interfaced procedures need an external symbol created
7235 -- for them since they are always referenced from another
7238 Set_Is_Public (Def_Id);
7240 -- Verify that the subprogram does not have a completion
7241 -- through a renaming declaration. For other completions the
7242 -- pragma appears as a too late representation.
7245 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
7249 and then Nkind (Decl) = N_Subprogram_Declaration
7250 and then Present (Corresponding_Body (Decl))
7251 and then Nkind (Unit_Declaration_Node
7252 (Corresponding_Body (Decl))) =
7253 N_Subprogram_Renaming_Declaration
7255 Error_Msg_Sloc := Sloc (Def_Id);
7257 ("cannot import&, renaming already provided for "
7258 & "declaration #", N, Def_Id);
7262 Set_Has_Completion (Def_Id);
7263 Process_Interface_Name (Def_Id, Arg3, Arg4);
7266 if Is_Compilation_Unit (Hom_Id) then
7268 -- Its possible homonyms are not affected by the pragma.
7269 -- Such homonyms might be present in the context of other
7270 -- units being compiled.
7274 elsif From_Aspect_Specification (N) then
7278 Hom_Id := Homonym (Hom_Id);
7282 -- When the convention is Java or CIL, we also allow Import to
7283 -- be given for packages, generic packages, exceptions, record
7284 -- components, and access to subprograms.
7286 elsif (C = Convention_Java or else C = Convention_CIL)
7288 (Is_Package_Or_Generic_Package (Def_Id)
7289 or else Ekind (Def_Id) = E_Exception
7290 or else Ekind (Def_Id) = E_Access_Subprogram_Type
7291 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
7293 Set_Imported (Def_Id);
7294 Set_Is_Public (Def_Id);
7295 Process_Interface_Name (Def_Id, Arg3, Arg4);
7297 -- Import a CPP class
7299 elsif C = Convention_CPP
7300 and then (Is_Record_Type (Def_Id)
7301 or else Ekind (Def_Id) = E_Incomplete_Type)
7303 if Ekind (Def_Id) = E_Incomplete_Type then
7304 if Present (Full_View (Def_Id)) then
7305 Def_Id := Full_View (Def_Id);
7309 ("cannot import 'C'P'P type before full declaration seen",
7310 Get_Pragma_Arg (Arg2));
7312 -- Although we have reported the error we decorate it as
7313 -- CPP_Class to avoid reporting spurious errors
7315 Set_Is_CPP_Class (Def_Id);
7320 -- Types treated as CPP classes must be declared limited (note:
7321 -- this used to be a warning but there is no real benefit to it
7322 -- since we did effectively intend to treat the type as limited
7325 if not Is_Limited_Type (Def_Id) then
7327 ("imported 'C'P'P type must be limited",
7328 Get_Pragma_Arg (Arg2));
7331 if Etype (Def_Id) /= Def_Id
7332 and then not Is_CPP_Class (Root_Type (Def_Id))
7334 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
7337 Set_Is_CPP_Class (Def_Id);
7339 -- Imported CPP types must not have discriminants (because C++
7340 -- classes do not have discriminants).
7342 if Has_Discriminants (Def_Id) then
7344 ("imported 'C'P'P type cannot have discriminants",
7345 First (Discriminant_Specifications
7346 (Declaration_Node (Def_Id))));
7349 -- Check that components of imported CPP types do not have default
7350 -- expressions. For private types this check is performed when the
7351 -- full view is analyzed (see Process_Full_View).
7353 if not Is_Private_Type (Def_Id) then
7354 Check_CPP_Type_Has_No_Defaults (Def_Id);
7357 -- Import a CPP exception
7359 elsif C = Convention_CPP
7360 and then Ekind (Def_Id) = E_Exception
7364 ("'External_'Name arguments is required for 'Cpp exception",
7367 -- As only a string is allowed, Check_Arg_Is_External_Name
7369 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7372 if Present (Arg4) then
7374 ("Link_Name argument not allowed for imported Cpp exception",
7378 -- Do not call Set_Interface_Name as the name of the exception
7379 -- shouldn't be modified (and in particular it shouldn't be
7380 -- the External_Name). For exceptions, the External_Name is the
7381 -- name of the RTTI structure.
7383 -- ??? Emit an error if pragma Import/Export_Exception is present
7385 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
7387 Check_Arg_Count (3);
7388 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7390 Process_Import_Predefined_Type;
7394 ("second argument of pragma% must be object, subprogram "
7395 & "or incomplete type",
7399 -- If this pragma applies to a compilation unit, then the unit, which
7400 -- is a subprogram, does not require (or allow) a body. We also do
7401 -- not need to elaborate imported procedures.
7403 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
7405 Cunit : constant Node_Id := Parent (Parent (N));
7407 Set_Body_Required (Cunit, False);
7410 end Process_Import_Or_Interface;
7412 --------------------
7413 -- Process_Inline --
7414 --------------------
7416 procedure Process_Inline (Status : Inline_Status) is
7423 Effective : Boolean := False;
7424 -- Set True if inline has some effect, i.e. if there is at least one
7425 -- subprogram set as inlined as a result of the use of the pragma.
7427 procedure Make_Inline (Subp : Entity_Id);
7428 -- Subp is the defining unit name of the subprogram declaration. Set
7429 -- the flag, as well as the flag in the corresponding body, if there
7432 procedure Set_Inline_Flags (Subp : Entity_Id);
7433 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7434 -- Has_Pragma_Inline_Always for the Inline_Always case.
7436 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
7437 -- Returns True if it can be determined at this stage that inlining
7438 -- is not possible, for example if the body is available and contains
7439 -- exception handlers, we prevent inlining, since otherwise we can
7440 -- get undefined symbols at link time. This function also emits a
7441 -- warning if front-end inlining is enabled and the pragma appears
7444 -- ??? is business with link symbols still valid, or does it relate
7445 -- to front end ZCX which is being phased out ???
7447 ---------------------------
7448 -- Inlining_Not_Possible --
7449 ---------------------------
7451 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
7452 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7456 if Nkind (Decl) = N_Subprogram_Body then
7457 Stats := Handled_Statement_Sequence (Decl);
7458 return Present (Exception_Handlers (Stats))
7459 or else Present (At_End_Proc (Stats));
7461 elsif Nkind (Decl) = N_Subprogram_Declaration
7462 and then Present (Corresponding_Body (Decl))
7464 if Front_End_Inlining
7465 and then Analyzed (Corresponding_Body (Decl))
7467 Error_Msg_N ("pragma appears too late, ignored??", N);
7470 -- If the subprogram is a renaming as body, the body is just a
7471 -- call to the renamed subprogram, and inlining is trivially
7475 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
7476 N_Subprogram_Renaming_Declaration
7482 Handled_Statement_Sequence
7483 (Unit_Declaration_Node (Corresponding_Body (Decl)));
7486 Present (Exception_Handlers (Stats))
7487 or else Present (At_End_Proc (Stats));
7491 -- If body is not available, assume the best, the check is
7492 -- performed again when compiling enclosing package bodies.
7496 end Inlining_Not_Possible;
7502 procedure Make_Inline (Subp : Entity_Id) is
7503 Kind : constant Entity_Kind := Ekind (Subp);
7504 Inner_Subp : Entity_Id := Subp;
7507 -- Ignore if bad type, avoid cascaded error
7509 if Etype (Subp) = Any_Type then
7513 -- Ignore if all inlining is suppressed
7515 elsif Suppress_All_Inlining then
7519 -- If inlining is not possible, for now do not treat as an error
7521 elsif Status /= Suppressed
7522 and then Inlining_Not_Possible (Subp)
7527 -- Here we have a candidate for inlining, but we must exclude
7528 -- derived operations. Otherwise we would end up trying to inline
7529 -- a phantom declaration, and the result would be to drag in a
7530 -- body which has no direct inlining associated with it. That
7531 -- would not only be inefficient but would also result in the
7532 -- backend doing cross-unit inlining in cases where it was
7533 -- definitely inappropriate to do so.
7535 -- However, a simple Comes_From_Source test is insufficient, since
7536 -- we do want to allow inlining of generic instances which also do
7537 -- not come from source. We also need to recognize specs generated
7538 -- by the front-end for bodies that carry the pragma. Finally,
7539 -- predefined operators do not come from source but are not
7540 -- inlineable either.
7542 elsif Is_Generic_Instance (Subp)
7543 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
7547 elsif not Comes_From_Source (Subp)
7548 and then Scope (Subp) /= Standard_Standard
7554 -- The referenced entity must either be the enclosing entity, or
7555 -- an entity declared within the current open scope.
7557 if Present (Scope (Subp))
7558 and then Scope (Subp) /= Current_Scope
7559 and then Subp /= Current_Scope
7562 ("argument of% must be entity in current scope", Assoc);
7566 -- Processing for procedure, operator or function. If subprogram
7567 -- is aliased (as for an instance) indicate that the renamed
7568 -- entity (if declared in the same unit) is inlined.
7570 if Is_Subprogram (Subp) then
7571 Inner_Subp := Ultimate_Alias (Inner_Subp);
7573 if In_Same_Source_Unit (Subp, Inner_Subp) then
7574 Set_Inline_Flags (Inner_Subp);
7576 Decl := Parent (Parent (Inner_Subp));
7578 if Nkind (Decl) = N_Subprogram_Declaration
7579 and then Present (Corresponding_Body (Decl))
7581 Set_Inline_Flags (Corresponding_Body (Decl));
7583 elsif Is_Generic_Instance (Subp) then
7585 -- Indicate that the body needs to be created for
7586 -- inlining subsequent calls. The instantiation node
7587 -- follows the declaration of the wrapper package
7590 if Scope (Subp) /= Standard_Standard
7592 Need_Subprogram_Instance_Body
7593 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
7599 -- Inline is a program unit pragma (RM 10.1.5) and cannot
7600 -- appear in a formal part to apply to a formal subprogram.
7601 -- Do not apply check within an instance or a formal package
7602 -- the test will have been applied to the original generic.
7604 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
7605 and then List_Containing (Decl) = List_Containing (N)
7606 and then not In_Instance
7609 ("Inline cannot apply to a formal subprogram", N);
7611 -- If Subp is a renaming, it is the renamed entity that
7612 -- will appear in any call, and be inlined. However, for
7613 -- ASIS uses it is convenient to indicate that the renaming
7614 -- itself is an inlined subprogram, so that some gnatcheck
7615 -- rules can be applied in the absence of expansion.
7617 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
7618 Set_Inline_Flags (Subp);
7624 -- For a generic subprogram set flag as well, for use at the point
7625 -- of instantiation, to determine whether the body should be
7628 elsif Is_Generic_Subprogram (Subp) then
7629 Set_Inline_Flags (Subp);
7632 -- Literals are by definition inlined
7634 elsif Kind = E_Enumeration_Literal then
7637 -- Anything else is an error
7641 ("expect subprogram name for pragma%", Assoc);
7645 ----------------------
7646 -- Set_Inline_Flags --
7647 ----------------------
7649 procedure Set_Inline_Flags (Subp : Entity_Id) is
7651 -- First set the Has_Pragma_XXX flags and issue the appropriate
7652 -- errors and warnings for suspicious combinations.
7654 if Prag_Id = Pragma_No_Inline then
7655 if Has_Pragma_Inline_Always (Subp) then
7657 ("Inline_Always and No_Inline are mutually exclusive", N);
7658 elsif Has_Pragma_Inline (Subp) then
7660 ("Inline and No_Inline both specified for& ??",
7661 N, Entity (Subp_Id));
7664 Set_Has_Pragma_No_Inline (Subp);
7666 if Prag_Id = Pragma_Inline_Always then
7667 if Has_Pragma_No_Inline (Subp) then
7669 ("Inline_Always and No_Inline are mutually exclusive",
7673 Set_Has_Pragma_Inline_Always (Subp);
7675 if Has_Pragma_No_Inline (Subp) then
7677 ("Inline and No_Inline both specified for& ??",
7678 N, Entity (Subp_Id));
7682 if not Has_Pragma_Inline (Subp) then
7683 Set_Has_Pragma_Inline (Subp);
7688 -- Then adjust the Is_Inlined flag. It can never be set if the
7689 -- subprogram is subject to pragma No_Inline.
7693 Set_Is_Inlined (Subp, False);
7697 if not Has_Pragma_No_Inline (Subp) then
7698 Set_Is_Inlined (Subp, True);
7701 end Set_Inline_Flags;
7703 -- Start of processing for Process_Inline
7706 Check_No_Identifiers;
7707 Check_At_Least_N_Arguments (1);
7709 if Status = Enabled then
7710 Inline_Processing_Required := True;
7714 while Present (Assoc) loop
7715 Subp_Id := Get_Pragma_Arg (Assoc);
7719 if Is_Entity_Name (Subp_Id) then
7720 Subp := Entity (Subp_Id);
7722 if Subp = Any_Id then
7724 -- If previous error, avoid cascaded errors
7726 Check_Error_Detected;
7733 -- For the pragma case, climb homonym chain. This is
7734 -- what implements allowing the pragma in the renaming
7735 -- case, with the result applying to the ancestors, and
7736 -- also allows Inline to apply to all previous homonyms.
7738 if not From_Aspect_Specification (N) then
7739 while Present (Homonym (Subp))
7740 and then Scope (Homonym (Subp)) = Current_Scope
7742 Make_Inline (Homonym (Subp));
7743 Subp := Homonym (Subp);
7751 ("inappropriate argument for pragma%", Assoc);
7754 and then Warn_On_Redundant_Constructs
7755 and then not (Status = Suppressed or else Suppress_All_Inlining)
7757 if Inlining_Not_Possible (Subp) then
7759 ("pragma Inline for& is ignored?r?",
7760 N, Entity (Subp_Id));
7763 ("pragma Inline for& is redundant?r?",
7764 N, Entity (Subp_Id));
7772 ----------------------------
7773 -- Process_Interface_Name --
7774 ----------------------------
7776 procedure Process_Interface_Name
7777 (Subprogram_Def : Entity_Id;
7783 String_Val : String_Id;
7785 procedure Check_Form_Of_Interface_Name
7787 Ext_Name_Case : Boolean);
7788 -- SN is a string literal node for an interface name. This routine
7789 -- performs some minimal checks that the name is reasonable. In
7790 -- particular that no spaces or other obviously incorrect characters
7791 -- appear. This is only a warning, since any characters are allowed.
7792 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
7794 ----------------------------------
7795 -- Check_Form_Of_Interface_Name --
7796 ----------------------------------
7798 procedure Check_Form_Of_Interface_Name
7800 Ext_Name_Case : Boolean)
7802 S : constant String_Id := Strval (Expr_Value_S (SN));
7803 SL : constant Nat := String_Length (S);
7808 Error_Msg_N ("interface name cannot be null string", SN);
7811 for J in 1 .. SL loop
7812 C := Get_String_Char (S, J);
7814 -- Look for dubious character and issue unconditional warning.
7815 -- Definitely dubious if not in character range.
7817 if not In_Character_Range (C)
7819 -- For all cases except CLI target,
7820 -- commas, spaces and slashes are dubious (in CLI, we use
7821 -- commas and backslashes in external names to specify
7822 -- assembly version and public key, while slashes and spaces
7823 -- can be used in names to mark nested classes and
7826 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
7827 and then (Get_Character (C) = ','
7829 Get_Character (C) = '\'))
7830 or else (VM_Target /= CLI_Target
7831 and then (Get_Character (C) = ' '
7833 Get_Character (C) = '/'))
7836 ("??interface name contains illegal character",
7837 Sloc (SN) + Source_Ptr (J));
7840 end Check_Form_Of_Interface_Name;
7842 -- Start of processing for Process_Interface_Name
7845 if No (Link_Arg) then
7846 if No (Ext_Arg) then
7847 if VM_Target = CLI_Target
7848 and then Ekind (Subprogram_Def) = E_Package
7849 and then Nkind (Parent (Subprogram_Def)) =
7850 N_Package_Specification
7851 and then Present (Generic_Parent (Parent (Subprogram_Def)))
7856 (Generic_Parent (Parent (Subprogram_Def))));
7861 elsif Chars (Ext_Arg) = Name_Link_Name then
7863 Link_Nam := Expression (Ext_Arg);
7866 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7867 Ext_Nam := Expression (Ext_Arg);
7872 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
7873 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
7874 Ext_Nam := Expression (Ext_Arg);
7875 Link_Nam := Expression (Link_Arg);
7878 -- Check expressions for external name and link name are static
7880 if Present (Ext_Nam) then
7881 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
7882 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
7884 -- Verify that external name is not the name of a local entity,
7885 -- which would hide the imported one and could lead to run-time
7886 -- surprises. The problem can only arise for entities declared in
7887 -- a package body (otherwise the external name is fully qualified
7888 -- and will not conflict).
7896 if Prag_Id = Pragma_Import then
7897 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
7899 E := Entity_Id (Get_Name_Table_Info (Nam));
7901 if Nam /= Chars (Subprogram_Def)
7902 and then Present (E)
7903 and then not Is_Overloadable (E)
7904 and then Is_Immediately_Visible (E)
7905 and then not Is_Imported (E)
7906 and then Ekind (Scope (E)) = E_Package
7909 while Present (Par) loop
7910 if Nkind (Par) = N_Package_Body then
7911 Error_Msg_Sloc := Sloc (E);
7913 ("imported entity is hidden by & declared#",
7918 Par := Parent (Par);
7925 if Present (Link_Nam) then
7926 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
7927 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
7930 -- If there is no link name, just set the external name
7932 if No (Link_Nam) then
7933 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
7935 -- For the Link_Name case, the given literal is preceded by an
7936 -- asterisk, which indicates to GCC that the given name should be
7937 -- taken literally, and in particular that no prepending of
7938 -- underlines should occur, even in systems where this is the
7944 if VM_Target = No_VM then
7945 Store_String_Char (Get_Char_Code ('*'));
7948 String_Val := Strval (Expr_Value_S (Link_Nam));
7949 Store_String_Chars (String_Val);
7951 Make_String_Literal (Sloc (Link_Nam),
7952 Strval => End_String);
7955 -- Set the interface name. If the entity is a generic instance, use
7956 -- its alias, which is the callable entity.
7958 if Is_Generic_Instance (Subprogram_Def) then
7959 Set_Encoded_Interface_Name
7960 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
7962 Set_Encoded_Interface_Name
7963 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
7966 -- We allow duplicated export names in CIL/Java, as they are always
7967 -- enclosed in a namespace that differentiates them, and overloaded
7968 -- entities are supported by the VM.
7970 if Convention (Subprogram_Def) /= Convention_CIL
7972 Convention (Subprogram_Def) /= Convention_Java
7974 Check_Duplicated_Export_Name (Link_Nam);
7976 end Process_Interface_Name;
7978 -----------------------------------------
7979 -- Process_Interrupt_Or_Attach_Handler --
7980 -----------------------------------------
7982 procedure Process_Interrupt_Or_Attach_Handler is
7983 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
7984 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
7985 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
7988 Set_Is_Interrupt_Handler (Handler_Proc);
7990 -- If the pragma is not associated with a handler procedure within a
7991 -- protected type, then it must be for a nonprotected procedure for
7992 -- the AAMP target, in which case we don't associate a representation
7993 -- item with the procedure's scope.
7995 if Ekind (Proc_Scope) = E_Protected_Type then
7996 if Prag_Id = Pragma_Interrupt_Handler
7998 Prag_Id = Pragma_Attach_Handler
8000 Record_Rep_Item (Proc_Scope, N);
8003 end Process_Interrupt_Or_Attach_Handler;
8005 --------------------------------------------------
8006 -- Process_Restrictions_Or_Restriction_Warnings --
8007 --------------------------------------------------
8009 -- Note: some of the simple identifier cases were handled in par-prag,
8010 -- but it is harmless (and more straightforward) to simply handle all
8011 -- cases here, even if it means we repeat a bit of work in some cases.
8013 procedure Process_Restrictions_Or_Restriction_Warnings
8017 R_Id : Restriction_Id;
8023 -- Ignore all Restrictions pragmas in CodePeer mode
8025 if CodePeer_Mode then
8029 Check_Ada_83_Warning;
8030 Check_At_Least_N_Arguments (1);
8031 Check_Valid_Configuration_Pragma;
8034 while Present (Arg) loop
8036 Expr := Get_Pragma_Arg (Arg);
8038 -- Case of no restriction identifier present
8040 if Id = No_Name then
8041 if Nkind (Expr) /= N_Identifier then
8043 ("invalid form for restriction", Arg);
8048 (Process_Restriction_Synonyms (Expr));
8050 if R_Id not in All_Boolean_Restrictions then
8051 Error_Msg_Name_1 := Pname;
8053 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8055 -- Check for possible misspelling
8057 for J in Restriction_Id loop
8059 Rnm : constant String := Restriction_Id'Image (J);
8062 Name_Buffer (1 .. Rnm'Length) := Rnm;
8063 Name_Len := Rnm'Length;
8064 Set_Casing (All_Lower_Case);
8066 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8068 (Identifier_Casing (Current_Source_File));
8069 Error_Msg_String (1 .. Rnm'Length) :=
8070 Name_Buffer (1 .. Name_Len);
8071 Error_Msg_Strlen := Rnm'Length;
8072 Error_Msg_N -- CODEFIX
8073 ("\possible misspelling of ""~""",
8074 Get_Pragma_Arg (Arg));
8083 if Implementation_Restriction (R_Id) then
8084 Check_Restriction (No_Implementation_Restrictions, Arg);
8087 -- Special processing for No_Elaboration_Code restriction
8089 if R_Id = No_Elaboration_Code then
8091 -- Restriction is only recognized within a configuration
8092 -- pragma file, or within a unit of the main extended
8093 -- program. Note: the test for Main_Unit is needed to
8094 -- properly include the case of configuration pragma files.
8096 if not (Current_Sem_Unit = Main_Unit
8097 or else In_Extended_Main_Source_Unit (N))
8101 -- Don't allow in a subunit unless already specified in
8104 elsif Nkind (Parent (N)) = N_Compilation_Unit
8105 and then Nkind (Unit (Parent (N))) = N_Subunit
8106 and then not Restriction_Active (No_Elaboration_Code)
8109 ("invalid specification of ""No_Elaboration_Code""",
8112 ("\restriction cannot be specified in a subunit", N);
8114 ("\unless also specified in body or spec", N);
8117 -- If we have a No_Elaboration_Code pragma that we
8118 -- accept, then it needs to be added to the configuration
8119 -- restrcition set so that we get proper application to
8120 -- other units in the main extended source as required.
8123 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
8127 -- If this is a warning, then set the warning unless we already
8128 -- have a real restriction active (we never want a warning to
8129 -- override a real restriction).
8132 if not Restriction_Active (R_Id) then
8133 Set_Restriction (R_Id, N);
8134 Restriction_Warnings (R_Id) := True;
8137 -- If real restriction case, then set it and make sure that the
8138 -- restriction warning flag is off, since a real restriction
8139 -- always overrides a warning.
8142 Set_Restriction (R_Id, N);
8143 Restriction_Warnings (R_Id) := False;
8146 -- Check for obsolescent restrictions in Ada 2005 mode
8149 and then Ada_Version >= Ada_2005
8150 and then (R_Id = No_Asynchronous_Control
8152 R_Id = No_Unchecked_Deallocation
8154 R_Id = No_Unchecked_Conversion)
8156 Check_Restriction (No_Obsolescent_Features, N);
8159 -- A very special case that must be processed here: pragma
8160 -- Restrictions (No_Exceptions) turns off all run-time
8161 -- checking. This is a bit dubious in terms of the formal
8162 -- language definition, but it is what is intended by RM
8163 -- H.4(12). Restriction_Warnings never affects generated code
8164 -- so this is done only in the real restriction case.
8166 -- Atomic_Synchronization is not a real check, so it is not
8167 -- affected by this processing).
8169 if R_Id = No_Exceptions and then not Warn then
8170 for J in Scope_Suppress.Suppress'Range loop
8171 if J /= Atomic_Synchronization then
8172 Scope_Suppress.Suppress (J) := True;
8177 -- Case of No_Dependence => unit-name. Note that the parser
8178 -- already made the necessary entry in the No_Dependence table.
8180 elsif Id = Name_No_Dependence then
8181 if not OK_No_Dependence_Unit_Name (Expr) then
8185 -- Case of No_Specification_Of_Aspect => Identifier.
8187 elsif Id = Name_No_Specification_Of_Aspect then
8192 if Nkind (Expr) /= N_Identifier then
8195 A_Id := Get_Aspect_Id (Chars (Expr));
8198 if A_Id = No_Aspect then
8199 Error_Pragma_Arg ("invalid restriction name", Arg);
8201 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
8205 elsif Id = Name_No_Use_Of_Attribute then
8206 if Nkind (Expr) /= N_Identifier
8207 or else not Is_Attribute_Name (Chars (Expr))
8209 Error_Msg_N ("unknown attribute name?", Expr);
8212 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
8215 elsif Id = Name_No_Use_Of_Pragma then
8216 if Nkind (Expr) /= N_Identifier
8217 or else not Is_Pragma_Name (Chars (Expr))
8219 Error_Msg_N ("unknown pragma name?", Expr);
8222 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
8225 -- All other cases of restriction identifier present
8228 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
8229 Analyze_And_Resolve (Expr, Any_Integer);
8231 if R_Id not in All_Parameter_Restrictions then
8233 ("invalid restriction parameter identifier", Arg);
8235 elsif not Is_OK_Static_Expression (Expr) then
8236 Flag_Non_Static_Expr
8237 ("value must be static expression!", Expr);
8240 elsif not Is_Integer_Type (Etype (Expr))
8241 or else Expr_Value (Expr) < 0
8244 ("value must be non-negative integer", Arg);
8247 -- Restriction pragma is active
8249 Val := Expr_Value (Expr);
8251 if not UI_Is_In_Int_Range (Val) then
8253 ("pragma ignored, value too large??", Arg);
8256 -- Warning case. If the real restriction is active, then we
8257 -- ignore the request, since warning never overrides a real
8258 -- restriction. Otherwise we set the proper warning. Note that
8259 -- this circuit sets the warning again if it is already set,
8260 -- which is what we want, since the constant may have changed.
8263 if not Restriction_Active (R_Id) then
8265 (R_Id, N, Integer (UI_To_Int (Val)));
8266 Restriction_Warnings (R_Id) := True;
8269 -- Real restriction case, set restriction and make sure warning
8270 -- flag is off since real restriction always overrides warning.
8273 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
8274 Restriction_Warnings (R_Id) := False;
8280 end Process_Restrictions_Or_Restriction_Warnings;
8282 ---------------------------------
8283 -- Process_Suppress_Unsuppress --
8284 ---------------------------------
8286 -- Note: this procedure makes entries in the check suppress data
8287 -- structures managed by Sem. See spec of package Sem for full
8288 -- details on how we handle recording of check suppression.
8290 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
8295 In_Package_Spec : constant Boolean :=
8296 Is_Package_Or_Generic_Package (Current_Scope)
8297 and then not In_Package_Body (Current_Scope);
8299 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
8300 -- Used to suppress a single check on the given entity
8302 --------------------------------
8303 -- Suppress_Unsuppress_Echeck --
8304 --------------------------------
8306 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
8308 -- Check for error of trying to set atomic synchronization for
8309 -- a non-atomic variable.
8311 if C = Atomic_Synchronization
8312 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
8315 ("pragma & requires atomic type or variable",
8316 Pragma_Identifier (Original_Node (N)));
8319 Set_Checks_May_Be_Suppressed (E);
8321 if In_Package_Spec then
8322 Push_Global_Suppress_Stack_Entry
8325 Suppress => Suppress_Case);
8327 Push_Local_Suppress_Stack_Entry
8330 Suppress => Suppress_Case);
8333 -- If this is a first subtype, and the base type is distinct,
8334 -- then also set the suppress flags on the base type.
8336 if Is_First_Subtype (E) and then Etype (E) /= E then
8337 Suppress_Unsuppress_Echeck (Etype (E), C);
8339 end Suppress_Unsuppress_Echeck;
8341 -- Start of processing for Process_Suppress_Unsuppress
8344 -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on
8345 -- user code: we want to generate checks for analysis purposes, as
8346 -- set respectively by -gnatC and -gnatd.F
8348 if (CodePeer_Mode or SPARK_Mode) and then Comes_From_Source (N) then
8352 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8353 -- declarative part or a package spec (RM 11.5(5)).
8355 if not Is_Configuration_Pragma then
8356 Check_Is_In_Decl_Part_Or_Package_Spec;
8359 Check_At_Least_N_Arguments (1);
8360 Check_At_Most_N_Arguments (2);
8361 Check_No_Identifier (Arg1);
8362 Check_Arg_Is_Identifier (Arg1);
8364 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
8366 if C = No_Check_Id then
8368 ("argument of pragma% is not valid check name", Arg1);
8371 if Arg_Count = 1 then
8373 -- Make an entry in the local scope suppress table. This is the
8374 -- table that directly shows the current value of the scope
8375 -- suppress check for any check id value.
8377 if C = All_Checks then
8379 -- For All_Checks, we set all specific predefined checks with
8380 -- the exception of Elaboration_Check, which is handled
8381 -- specially because of not wanting All_Checks to have the
8382 -- effect of deactivating static elaboration order processing.
8383 -- Atomic_Synchronization is also not affected, since this is
8384 -- not a real check.
8386 for J in Scope_Suppress.Suppress'Range loop
8387 if J /= Elaboration_Check
8389 J /= Atomic_Synchronization
8391 Scope_Suppress.Suppress (J) := Suppress_Case;
8395 -- If not All_Checks, and predefined check, then set appropriate
8396 -- scope entry. Note that we will set Elaboration_Check if this
8397 -- is explicitly specified. Atomic_Synchronization is allowed
8398 -- only if internally generated and entity is atomic.
8400 elsif C in Predefined_Check_Id
8401 and then (not Comes_From_Source (N)
8402 or else C /= Atomic_Synchronization)
8404 Scope_Suppress.Suppress (C) := Suppress_Case;
8407 -- Also make an entry in the Local_Entity_Suppress table
8409 Push_Local_Suppress_Stack_Entry
8412 Suppress => Suppress_Case);
8414 -- Case of two arguments present, where the check is suppressed for
8415 -- a specified entity (given as the second argument of the pragma)
8418 -- This is obsolescent in Ada 2005 mode
8420 if Ada_Version >= Ada_2005 then
8421 Check_Restriction (No_Obsolescent_Features, Arg2);
8424 Check_Optional_Identifier (Arg2, Name_On);
8425 E_Id := Get_Pragma_Arg (Arg2);
8428 if not Is_Entity_Name (E_Id) then
8430 ("second argument of pragma% must be entity name", Arg2);
8439 -- Enforce RM 11.5(7) which requires that for a pragma that
8440 -- appears within a package spec, the named entity must be
8441 -- within the package spec. We allow the package name itself
8442 -- to be mentioned since that makes sense, although it is not
8443 -- strictly allowed by 11.5(7).
8446 and then E /= Current_Scope
8447 and then Scope (E) /= Current_Scope
8450 ("entity in pragma% is not in package spec (RM 11.5(7))",
8454 -- Loop through homonyms. As noted below, in the case of a package
8455 -- spec, only homonyms within the package spec are considered.
8458 Suppress_Unsuppress_Echeck (E, C);
8460 if Is_Generic_Instance (E)
8461 and then Is_Subprogram (E)
8462 and then Present (Alias (E))
8464 Suppress_Unsuppress_Echeck (Alias (E), C);
8467 -- Move to next homonym if not aspect spec case
8469 exit when From_Aspect_Specification (N);
8473 -- If we are within a package specification, the pragma only
8474 -- applies to homonyms in the same scope.
8476 exit when In_Package_Spec
8477 and then Scope (E) /= Current_Scope;
8480 end Process_Suppress_Unsuppress;
8486 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
8488 if Is_Imported (E) then
8490 ("cannot export entity& that was previously imported", Arg);
8492 elsif Present (Address_Clause (E))
8493 and then not Relaxed_RM_Semantics
8496 ("cannot export entity& that has an address clause", Arg);
8499 Set_Is_Exported (E);
8501 -- Generate a reference for entity explicitly, because the
8502 -- identifier may be overloaded and name resolution will not
8505 Generate_Reference (E, Arg);
8507 -- Deal with exporting non-library level entity
8509 if not Is_Library_Level_Entity (E) then
8511 -- Not allowed at all for subprograms
8513 if Is_Subprogram (E) then
8514 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
8516 -- Otherwise set public and statically allocated
8520 Set_Is_Statically_Allocated (E);
8522 -- Warn if the corresponding W flag is set and the pragma comes
8523 -- from source. The latter may not be true e.g. on VMS where we
8524 -- expand export pragmas for exception codes associated with
8525 -- imported or exported exceptions. We do not want to generate
8526 -- a warning for something that the user did not write.
8528 if Warn_On_Export_Import
8529 and then Comes_From_Source (Arg)
8532 ("?x?& has been made static as a result of Export",
8535 ("\?x?this usage is non-standard and non-portable",
8541 if Warn_On_Export_Import and then Is_Type (E) then
8542 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
8545 if Warn_On_Export_Import and Inside_A_Generic then
8547 ("all instances of& will have the same external name?x?",
8552 ----------------------------------------------
8553 -- Set_Extended_Import_Export_External_Name --
8554 ----------------------------------------------
8556 procedure Set_Extended_Import_Export_External_Name
8557 (Internal_Ent : Entity_Id;
8558 Arg_External : Node_Id)
8560 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
8564 if No (Arg_External) then
8568 Check_Arg_Is_External_Name (Arg_External);
8570 if Nkind (Arg_External) = N_String_Literal then
8571 if String_Length (Strval (Arg_External)) = 0 then
8574 New_Name := Adjust_External_Name_Case (Arg_External);
8577 elsif Nkind (Arg_External) = N_Identifier then
8578 New_Name := Get_Default_External_Name (Arg_External);
8580 -- Check_Arg_Is_External_Name should let through only identifiers and
8581 -- string literals or static string expressions (which are folded to
8582 -- string literals).
8585 raise Program_Error;
8588 -- If we already have an external name set (by a prior normal Import
8589 -- or Export pragma), then the external names must match
8591 if Present (Interface_Name (Internal_Ent)) then
8592 Check_Matching_Internal_Names : declare
8593 S1 : constant String_Id := Strval (Old_Name);
8594 S2 : constant String_Id := Strval (New_Name);
8597 pragma No_Return (Mismatch);
8598 -- Called if names do not match
8604 procedure Mismatch is
8606 Error_Msg_Sloc := Sloc (Old_Name);
8608 ("external name does not match that given #",
8612 -- Start of processing for Check_Matching_Internal_Names
8615 if String_Length (S1) /= String_Length (S2) then
8619 for J in 1 .. String_Length (S1) loop
8620 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
8625 end Check_Matching_Internal_Names;
8627 -- Otherwise set the given name
8630 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
8631 Check_Duplicated_Export_Name (New_Name);
8633 end Set_Extended_Import_Export_External_Name;
8639 procedure Set_Imported (E : Entity_Id) is
8641 -- Error message if already imported or exported
8643 if Is_Exported (E) or else Is_Imported (E) then
8645 -- Error if being set Exported twice
8647 if Is_Exported (E) then
8648 Error_Msg_NE ("entity& was previously exported", N, E);
8650 -- Ignore error in CodePeer mode where we treat all imported
8651 -- subprograms as unknown.
8653 elsif CodePeer_Mode then
8656 -- OK if Import/Interface case
8658 elsif Import_Interface_Present (N) then
8661 -- Error if being set Imported twice
8664 Error_Msg_NE ("entity& was previously imported", N, E);
8667 Error_Msg_Name_1 := Pname;
8669 ("\(pragma% applies to all previous entities)", N);
8671 Error_Msg_Sloc := Sloc (E);
8672 Error_Msg_NE ("\import not allowed for& declared#", N, E);
8674 -- Here if not previously imported or exported, OK to import
8677 Set_Is_Imported (E);
8679 -- If the entity is an object that is not at the library level,
8680 -- then it is statically allocated. We do not worry about objects
8681 -- with address clauses in this context since they are not really
8682 -- imported in the linker sense.
8685 and then not Is_Library_Level_Entity (E)
8686 and then No (Address_Clause (E))
8688 Set_Is_Statically_Allocated (E);
8695 -------------------------
8696 -- Set_Mechanism_Value --
8697 -------------------------
8699 -- Note: the mechanism name has not been analyzed (and cannot indeed be
8700 -- analyzed, since it is semantic nonsense), so we get it in the exact
8701 -- form created by the parser.
8703 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
8706 Mech_Name_Id : Name_Id;
8708 procedure Bad_Class;
8709 pragma No_Return (Bad_Class);
8710 -- Signal bad descriptor class name
8712 procedure Bad_Mechanism;
8713 pragma No_Return (Bad_Mechanism);
8714 -- Signal bad mechanism name
8720 procedure Bad_Class is
8722 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
8725 -------------------------
8726 -- Bad_Mechanism_Value --
8727 -------------------------
8729 procedure Bad_Mechanism is
8731 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
8734 -- Start of processing for Set_Mechanism_Value
8737 if Mechanism (Ent) /= Default_Mechanism then
8739 ("mechanism for & has already been set", Mech_Name, Ent);
8742 -- MECHANISM_NAME ::= value | reference | descriptor |
8745 if Nkind (Mech_Name) = N_Identifier then
8746 if Chars (Mech_Name) = Name_Value then
8747 Set_Mechanism (Ent, By_Copy);
8750 elsif Chars (Mech_Name) = Name_Reference then
8751 Set_Mechanism (Ent, By_Reference);
8754 elsif Chars (Mech_Name) = Name_Descriptor then
8755 Check_VMS (Mech_Name);
8757 -- Descriptor => Short_Descriptor if pragma was given
8759 if Short_Descriptors then
8760 Set_Mechanism (Ent, By_Short_Descriptor);
8762 Set_Mechanism (Ent, By_Descriptor);
8767 elsif Chars (Mech_Name) = Name_Short_Descriptor then
8768 Check_VMS (Mech_Name);
8769 Set_Mechanism (Ent, By_Short_Descriptor);
8772 elsif Chars (Mech_Name) = Name_Copy then
8774 ("bad mechanism name, Value assumed", Mech_Name);
8780 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
8781 -- short_descriptor (CLASS_NAME)
8782 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8784 -- Note: this form is parsed as an indexed component
8786 elsif Nkind (Mech_Name) = N_Indexed_Component then
8787 Class := First (Expressions (Mech_Name));
8789 if Nkind (Prefix (Mech_Name)) /= N_Identifier
8791 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
8792 Name_Short_Descriptor)
8793 or else Present (Next (Class))
8797 Mech_Name_Id := Chars (Prefix (Mech_Name));
8799 -- Change Descriptor => Short_Descriptor if pragma was given
8801 if Mech_Name_Id = Name_Descriptor
8802 and then Short_Descriptors
8804 Mech_Name_Id := Name_Short_Descriptor;
8808 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
8809 -- short_descriptor (Class => CLASS_NAME)
8810 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8812 -- Note: this form is parsed as a function call
8814 elsif Nkind (Mech_Name) = N_Function_Call then
8815 Param := First (Parameter_Associations (Mech_Name));
8817 if Nkind (Name (Mech_Name)) /= N_Identifier
8819 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
8820 Name_Short_Descriptor)
8821 or else Present (Next (Param))
8822 or else No (Selector_Name (Param))
8823 or else Chars (Selector_Name (Param)) /= Name_Class
8827 Class := Explicit_Actual_Parameter (Param);
8828 Mech_Name_Id := Chars (Name (Mech_Name));
8835 -- Fall through here with Class set to descriptor class name
8837 Check_VMS (Mech_Name);
8839 if Nkind (Class) /= N_Identifier then
8842 elsif Mech_Name_Id = Name_Descriptor
8843 and then Chars (Class) = Name_UBS
8845 Set_Mechanism (Ent, By_Descriptor_UBS);
8847 elsif Mech_Name_Id = Name_Descriptor
8848 and then Chars (Class) = Name_UBSB
8850 Set_Mechanism (Ent, By_Descriptor_UBSB);
8852 elsif Mech_Name_Id = Name_Descriptor
8853 and then Chars (Class) = Name_UBA
8855 Set_Mechanism (Ent, By_Descriptor_UBA);
8857 elsif Mech_Name_Id = Name_Descriptor
8858 and then Chars (Class) = Name_S
8860 Set_Mechanism (Ent, By_Descriptor_S);
8862 elsif Mech_Name_Id = Name_Descriptor
8863 and then Chars (Class) = Name_SB
8865 Set_Mechanism (Ent, By_Descriptor_SB);
8867 elsif Mech_Name_Id = Name_Descriptor
8868 and then Chars (Class) = Name_A
8870 Set_Mechanism (Ent, By_Descriptor_A);
8872 elsif Mech_Name_Id = Name_Descriptor
8873 and then Chars (Class) = Name_NCA
8875 Set_Mechanism (Ent, By_Descriptor_NCA);
8877 elsif Mech_Name_Id = Name_Short_Descriptor
8878 and then Chars (Class) = Name_UBS
8880 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
8882 elsif Mech_Name_Id = Name_Short_Descriptor
8883 and then Chars (Class) = Name_UBSB
8885 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
8887 elsif Mech_Name_Id = Name_Short_Descriptor
8888 and then Chars (Class) = Name_UBA
8890 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
8892 elsif Mech_Name_Id = Name_Short_Descriptor
8893 and then Chars (Class) = Name_S
8895 Set_Mechanism (Ent, By_Short_Descriptor_S);
8897 elsif Mech_Name_Id = Name_Short_Descriptor
8898 and then Chars (Class) = Name_SB
8900 Set_Mechanism (Ent, By_Short_Descriptor_SB);
8902 elsif Mech_Name_Id = Name_Short_Descriptor
8903 and then Chars (Class) = Name_A
8905 Set_Mechanism (Ent, By_Short_Descriptor_A);
8907 elsif Mech_Name_Id = Name_Short_Descriptor
8908 and then Chars (Class) = Name_NCA
8910 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
8915 end Set_Mechanism_Value;
8917 --------------------------
8918 -- Set_Rational_Profile --
8919 --------------------------
8921 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
8922 -- and extension to the semantics of renaming declarations.
8924 procedure Set_Rational_Profile is
8926 Implicit_Packing := True;
8927 Overriding_Renamings := True;
8928 Use_VADS_Size := True;
8929 end Set_Rational_Profile;
8931 ---------------------------
8932 -- Set_Ravenscar_Profile --
8933 ---------------------------
8935 -- The tasks to be done here are
8937 -- Set required policies
8939 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8940 -- pragma Locking_Policy (Ceiling_Locking)
8942 -- Set Detect_Blocking mode
8944 -- Set required restrictions (see System.Rident for detailed list)
8946 -- Set the No_Dependence rules
8947 -- No_Dependence => Ada.Asynchronous_Task_Control
8948 -- No_Dependence => Ada.Calendar
8949 -- No_Dependence => Ada.Execution_Time.Group_Budget
8950 -- No_Dependence => Ada.Execution_Time.Timers
8951 -- No_Dependence => Ada.Task_Attributes
8952 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8954 procedure Set_Ravenscar_Profile (N : Node_Id) is
8955 Prefix_Entity : Entity_Id;
8956 Selector_Entity : Entity_Id;
8957 Prefix_Node : Node_Id;
8961 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
8963 if Task_Dispatching_Policy /= ' '
8964 and then Task_Dispatching_Policy /= 'F'
8966 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
8967 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8969 -- Set the FIFO_Within_Priorities policy, but always preserve
8970 -- System_Location since we like the error message with the run time
8974 Task_Dispatching_Policy := 'F';
8976 if Task_Dispatching_Policy_Sloc /= System_Location then
8977 Task_Dispatching_Policy_Sloc := Loc;
8981 -- pragma Locking_Policy (Ceiling_Locking)
8983 if Locking_Policy /= ' '
8984 and then Locking_Policy /= 'C'
8986 Error_Msg_Sloc := Locking_Policy_Sloc;
8987 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
8989 -- Set the Ceiling_Locking policy, but preserve System_Location since
8990 -- we like the error message with the run time name.
8993 Locking_Policy := 'C';
8995 if Locking_Policy_Sloc /= System_Location then
8996 Locking_Policy_Sloc := Loc;
9000 -- pragma Detect_Blocking
9002 Detect_Blocking := True;
9004 -- Set the corresponding restrictions
9006 Set_Profile_Restrictions
9007 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9009 -- Set the No_Dependence restrictions
9011 -- The following No_Dependence restrictions:
9012 -- No_Dependence => Ada.Asynchronous_Task_Control
9013 -- No_Dependence => Ada.Calendar
9014 -- No_Dependence => Ada.Task_Attributes
9015 -- are already set by previous call to Set_Profile_Restrictions.
9017 -- Set the following restrictions which were added to Ada 2005:
9018 -- No_Dependence => Ada.Execution_Time.Group_Budget
9019 -- No_Dependence => Ada.Execution_Time.Timers
9021 if Ada_Version >= Ada_2005 then
9022 Name_Buffer (1 .. 3) := "ada";
9025 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9027 Name_Buffer (1 .. 14) := "execution_time";
9030 Selector_Entity := Make_Identifier (Loc, Name_Find);
9033 Make_Selected_Component
9035 Prefix => Prefix_Entity,
9036 Selector_Name => Selector_Entity);
9038 Name_Buffer (1 .. 13) := "group_budgets";
9041 Selector_Entity := Make_Identifier (Loc, Name_Find);
9044 Make_Selected_Component
9046 Prefix => Prefix_Node,
9047 Selector_Name => Selector_Entity);
9049 Set_Restriction_No_Dependence
9051 Warn => Treat_Restrictions_As_Warnings,
9052 Profile => Ravenscar);
9054 Name_Buffer (1 .. 6) := "timers";
9057 Selector_Entity := Make_Identifier (Loc, Name_Find);
9060 Make_Selected_Component
9062 Prefix => Prefix_Node,
9063 Selector_Name => Selector_Entity);
9065 Set_Restriction_No_Dependence
9067 Warn => Treat_Restrictions_As_Warnings,
9068 Profile => Ravenscar);
9071 -- Set the following restrictions which was added to Ada 2012 (see
9073 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9075 if Ada_Version >= Ada_2012 then
9076 Name_Buffer (1 .. 6) := "system";
9079 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9081 Name_Buffer (1 .. 15) := "multiprocessors";
9084 Selector_Entity := Make_Identifier (Loc, Name_Find);
9087 Make_Selected_Component
9089 Prefix => Prefix_Entity,
9090 Selector_Name => Selector_Entity);
9092 Name_Buffer (1 .. 19) := "dispatching_domains";
9095 Selector_Entity := Make_Identifier (Loc, Name_Find);
9098 Make_Selected_Component
9100 Prefix => Prefix_Node,
9101 Selector_Name => Selector_Entity);
9103 Set_Restriction_No_Dependence
9105 Warn => Treat_Restrictions_As_Warnings,
9106 Profile => Ravenscar);
9108 end Set_Ravenscar_Profile;
9114 procedure S14_Pragma is
9116 if not Formal_Extensions then
9117 Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
9121 -- Start of processing for Analyze_Pragma
9124 -- The following code is a defense against recursion. Not clear that
9125 -- this can happen legitimately, but perhaps some error situations
9126 -- can cause it, and we did see this recursion during testing.
9128 if Analyzed (N) then
9131 Set_Analyzed (N, True);
9134 -- Deal with unrecognized pragma
9136 Pname := Pragma_Name (N);
9138 if not Is_Pragma_Name (Pname) then
9139 if Warn_On_Unrecognized_Pragma then
9140 Error_Msg_Name_1 := Pname;
9141 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
9143 for PN in First_Pragma_Name .. Last_Pragma_Name loop
9144 if Is_Bad_Spelling_Of (Pname, PN) then
9145 Error_Msg_Name_1 := PN;
9146 Error_Msg_N -- CODEFIX
9147 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
9156 -- Here to start processing for recognized pragma
9158 Prag_Id := Get_Pragma_Id (Pname);
9159 Pname := Original_Aspect_Name (N);
9161 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9162 -- is already set, indicating that we have already checked the policy
9163 -- at the right point. This happens for example in the case of a pragma
9164 -- that is derived from an Aspect.
9166 if Is_Ignored (N) or else Is_Checked (N) then
9169 -- For a pragma that is a rewriting of another pragma, copy the
9170 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9172 elsif Is_Rewrite_Substitution (N)
9173 and then Nkind (Original_Node (N)) = N_Pragma
9174 and then Original_Node (N) /= N
9176 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
9177 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
9179 -- Otherwise query the applicable policy at this point
9182 Check_Applicable_Policy (N);
9184 -- If pragma is disabled, rewrite as NULL and skip analysis
9186 if Is_Disabled (N) then
9187 Rewrite (N, Make_Null_Statement (Loc));
9201 if Present (Pragma_Argument_Associations (N)) then
9202 Arg_Count := List_Length (Pragma_Argument_Associations (N));
9203 Arg1 := First (Pragma_Argument_Associations (N));
9205 if Present (Arg1) then
9206 Arg2 := Next (Arg1);
9208 if Present (Arg2) then
9209 Arg3 := Next (Arg2);
9211 if Present (Arg3) then
9212 Arg4 := Next (Arg3);
9218 Check_Restriction_No_Use_Of_Pragma (N);
9220 -- An enumeration type defines the pragmas that are supported by the
9221 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9222 -- into the corresponding enumeration value for the following case.
9230 -- pragma Abort_Defer;
9232 when Pragma_Abort_Defer =>
9234 Check_Arg_Count (0);
9236 -- The only required semantic processing is to check the
9237 -- placement. This pragma must appear at the start of the
9238 -- statement sequence of a handled sequence of statements.
9240 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
9241 or else N /= First (Statements (Parent (N)))
9246 --------------------
9247 -- Abstract_State --
9248 --------------------
9250 -- pragma Abstract_State (ABSTRACT_STATE_LIST)
9252 -- ABSTRACT_STATE_LIST ::=
9254 -- | STATE_NAME_WITH_OPTIONS
9255 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
9257 -- STATE_NAME_WITH_OPTIONS ::=
9259 -- | (state_NAME with OPTION_LIST)
9261 -- OPTION_LIST ::= OPTION {, OPTION}
9263 -- OPTION ::= SIMPLE_OPTION | NAME_VALUE_OPTION
9265 -- SIMPLE_OPTION ::=
9266 -- External | Non_Volatile | Input_Only | Output_Only
9268 -- NAME_VALUE_OPTION ::= Part_Of => abstract_state_NAME
9270 when Pragma_Abstract_State => Abstract_State : declare
9271 Pack_Id : Entity_Id;
9273 -- Flags used to verify the consistency of states
9275 Non_Null_Seen : Boolean := False;
9276 Null_Seen : Boolean := False;
9278 procedure Analyze_Abstract_State (State : Node_Id);
9279 -- Verify the legality of a single state declaration. Create and
9280 -- decorate a state abstraction entity and introduce it into the
9281 -- visibility chain.
9283 ----------------------------
9284 -- Analyze_Abstract_State --
9285 ----------------------------
9287 procedure Analyze_Abstract_State (State : Node_Id) is
9288 procedure Check_Duplicate_Option
9290 Status : in out Boolean);
9291 -- Flag Status denotes whether a particular option has been
9292 -- seen while processing a state. This routine verifies that
9293 -- Opt is not a duplicate property and sets the flag Status.
9295 ----------------------------
9296 -- Check_Duplicate_Option --
9297 ----------------------------
9299 procedure Check_Duplicate_Option
9301 Status : in out Boolean)
9305 Error_Msg_N ("duplicate state option", Opt);
9309 end Check_Duplicate_Option;
9313 Errors : constant Nat := Serious_Errors_Detected;
9314 Loc : constant Source_Ptr := Sloc (State);
9317 Is_Null : Boolean := False;
9320 Par_State : Node_Id;
9322 -- Flags used to verify the consistency of options
9324 External_Seen : Boolean := False;
9325 Input_Seen : Boolean := False;
9326 Non_Volatile_Seen : Boolean := False;
9327 Output_Seen : Boolean := False;
9328 Part_Of_Seen : Boolean := False;
9330 -- Start of processing for Analyze_Abstract_State
9333 -- A package with a null abstract state is not allowed to
9334 -- declare additional states.
9338 ("package & has null abstract state", State, Pack_Id);
9340 -- Null states appear as internally generated entities
9342 elsif Nkind (State) = N_Null then
9343 Name := New_Internal_Name ('S');
9347 -- Catch a case where a null state appears in a list of
9350 if Non_Null_Seen then
9352 ("package & has non-null abstract state",
9356 -- Simple state declaration
9358 elsif Nkind (State) = N_Identifier then
9359 Name := Chars (State);
9360 Non_Null_Seen := True;
9362 -- State declaration with various options. This construct
9363 -- appears as an extension aggregate in the tree.
9365 elsif Nkind (State) = N_Extension_Aggregate then
9366 if Nkind (Ancestor_Part (State)) = N_Identifier then
9367 Name := Chars (Ancestor_Part (State));
9368 Non_Null_Seen := True;
9371 ("state name must be an identifier",
9372 Ancestor_Part (State));
9375 -- Process options External, Input_Only, Output_Only and
9376 -- Volatile. Ensure that none of them appear more than once.
9378 Opt := First (Expressions (State));
9379 while Present (Opt) loop
9380 if Nkind (Opt) = N_Identifier then
9381 if Chars (Opt) = Name_External then
9382 Check_Duplicate_Option (Opt, External_Seen);
9383 elsif Chars (Opt) = Name_Input_Only then
9384 Check_Duplicate_Option (Opt, Input_Seen);
9385 elsif Chars (Opt) = Name_Output_Only then
9386 Check_Duplicate_Option (Opt, Output_Seen);
9387 elsif Chars (Opt) = Name_Non_Volatile then
9388 Check_Duplicate_Option (Opt, Non_Volatile_Seen);
9390 -- Ensure that the abstract state component of option
9391 -- Part_Of has not been omitted.
9393 elsif Chars (Opt) = Name_Part_Of then
9395 ("option Part_Of requires an abstract state",
9398 Error_Msg_N ("invalid state option", Opt);
9401 Error_Msg_N ("invalid state option", Opt);
9407 -- External may appear on its own or with exactly one option
9408 -- Input_Only or Output_Only, but not both.
9412 and then Output_Seen
9415 ("option External requires exactly one option "
9416 & "Input_Only or Output_Only", State);
9419 -- Either Input_Only or Output_Only require External
9421 if (Input_Seen or Output_Seen)
9422 and then not External_Seen
9425 ("options Input_Only and Output_Only require option "
9426 & "External", State);
9429 -- Option Part_Of appears as a component association
9431 Assoc := First (Component_Associations (State));
9432 while Present (Assoc) loop
9433 Opt := First (Choices (Assoc));
9434 while Present (Opt) loop
9435 if Nkind (Opt) = N_Identifier
9436 and then Chars (Opt) = Name_Part_Of
9438 Check_Duplicate_Option (Opt, Part_Of_Seen);
9440 Error_Msg_N ("invalid state option", Opt);
9446 -- Part_Of must denote a parent state. Ensure that the
9447 -- tree is not malformed by checking the expression of
9448 -- the component association.
9450 Par_State := Expression (Assoc);
9451 pragma Assert (Present (Par_State));
9453 Analyze (Par_State);
9455 -- Part_Of specified a legal state
9457 if Is_Entity_Name (Par_State)
9458 and then Present (Entity (Par_State))
9459 and then Ekind (Entity (Par_State)) = E_Abstract_State
9464 ("option Part_Of must denote an abstract state",
9471 -- Any other attempt to declare a state is erroneous
9474 Error_Msg_N ("malformed abstract state declaration", State);
9477 -- Do not generate a state abstraction entity if it was not
9478 -- properly declared.
9480 if Serious_Errors_Detected > Errors then
9484 -- The generated state abstraction reuses the same characters
9485 -- from the original state declaration. Decorate the entity.
9487 Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
9488 Set_Comes_From_Source (Id, not Is_Null);
9489 Set_Parent (Id, State);
9490 Set_Ekind (Id, E_Abstract_State);
9491 Set_Etype (Id, Standard_Void_Type);
9492 Set_Refined_State (Id, Empty);
9493 Set_Refinement_Constituents (Id, New_Elmt_List);
9495 -- Every non-null state must be nameable and resolvable the
9496 -- same way a constant is.
9499 Push_Scope (Pack_Id);
9504 -- Verify whether the state introduces an illegal hidden state
9505 -- within a package subject to a null abstract state.
9507 if Formal_Extensions then
9508 Check_No_Hidden_State (Id);
9511 -- Associate the state with its related package
9513 if No (Abstract_States (Pack_Id)) then
9514 Set_Abstract_States (Pack_Id, New_Elmt_List);
9517 Append_Elmt (Id, Abstract_States (Pack_Id));
9518 end Analyze_Abstract_State;
9522 Context : constant Node_Id := Parent (Parent (N));
9525 -- Start of processing for Abstract_State
9530 Check_Arg_Count (1);
9532 -- Ensure the proper placement of the pragma. Abstract states must
9533 -- be associated with a package declaration.
9535 if not Nkind_In (Context, N_Generic_Package_Declaration,
9536 N_Package_Declaration)
9542 Pack_Id := Defining_Entity (Context);
9543 Add_Contract_Item (N, Pack_Id);
9545 -- Verify the declaration order of pragmas Abstract_State and
9548 Check_Declaration_Order
9550 Second => Get_Pragma (Pack_Id, Pragma_Initializes));
9552 State := Expression (Arg1);
9554 -- Multiple abstract states appear as an aggregate
9556 if Nkind (State) = N_Aggregate then
9557 State := First (Expressions (State));
9558 while Present (State) loop
9559 Analyze_Abstract_State (State);
9564 -- Various forms of a single abstract state. Note that these may
9565 -- include malformed state declarations.
9568 Analyze_Abstract_State (State);
9578 -- Note: this pragma also has some specific processing in Par.Prag
9579 -- because we want to set the Ada version mode during parsing.
9581 when Pragma_Ada_83 =>
9583 Check_Arg_Count (0);
9585 -- We really should check unconditionally for proper configuration
9586 -- pragma placement, since we really don't want mixed Ada modes
9587 -- within a single unit, and the GNAT reference manual has always
9588 -- said this was a configuration pragma, but we did not check and
9589 -- are hesitant to add the check now.
9591 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
9592 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
9593 -- or Ada 2012 mode.
9595 if Ada_Version >= Ada_2005 then
9596 Check_Valid_Configuration_Pragma;
9599 -- Now set Ada 83 mode
9601 Ada_Version := Ada_83;
9602 Ada_Version_Explicit := Ada_83;
9603 Ada_Version_Pragma := N;
9611 -- Note: this pragma also has some specific processing in Par.Prag
9612 -- because we want to set the Ada 83 version mode during parsing.
9614 when Pragma_Ada_95 =>
9616 Check_Arg_Count (0);
9618 -- We really should check unconditionally for proper configuration
9619 -- pragma placement, since we really don't want mixed Ada modes
9620 -- within a single unit, and the GNAT reference manual has always
9621 -- said this was a configuration pragma, but we did not check and
9622 -- are hesitant to add the check now.
9624 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
9625 -- or Ada 95, so we must check if we are in Ada 2005 mode.
9627 if Ada_Version >= Ada_2005 then
9628 Check_Valid_Configuration_Pragma;
9631 -- Now set Ada 95 mode
9633 Ada_Version := Ada_95;
9634 Ada_Version_Explicit := Ada_95;
9635 Ada_Version_Pragma := N;
9637 ---------------------
9638 -- Ada_05/Ada_2005 --
9639 ---------------------
9642 -- pragma Ada_05 (LOCAL_NAME);
9645 -- pragma Ada_2005 (LOCAL_NAME):
9647 -- Note: these pragmas also have some specific processing in Par.Prag
9648 -- because we want to set the Ada 2005 version mode during parsing.
9650 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
9656 if Arg_Count = 1 then
9657 Check_Arg_Is_Local_Name (Arg1);
9658 E_Id := Get_Pragma_Arg (Arg1);
9660 if Etype (E_Id) = Any_Type then
9664 Set_Is_Ada_2005_Only (Entity (E_Id));
9665 Record_Rep_Item (Entity (E_Id), N);
9668 Check_Arg_Count (0);
9670 -- For Ada_2005 we unconditionally enforce the documented
9671 -- configuration pragma placement, since we do not want to
9672 -- tolerate mixed modes in a unit involving Ada 2005. That
9673 -- would cause real difficulties for those cases where there
9674 -- are incompatibilities between Ada 95 and Ada 2005.
9676 Check_Valid_Configuration_Pragma;
9678 -- Now set appropriate Ada mode
9680 Ada_Version := Ada_2005;
9681 Ada_Version_Explicit := Ada_2005;
9682 Ada_Version_Pragma := N;
9686 ---------------------
9687 -- Ada_12/Ada_2012 --
9688 ---------------------
9691 -- pragma Ada_12 (LOCAL_NAME);
9694 -- pragma Ada_2012 (LOCAL_NAME):
9696 -- Note: these pragmas also have some specific processing in Par.Prag
9697 -- because we want to set the Ada 2012 version mode during parsing.
9699 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
9705 if Arg_Count = 1 then
9706 Check_Arg_Is_Local_Name (Arg1);
9707 E_Id := Get_Pragma_Arg (Arg1);
9709 if Etype (E_Id) = Any_Type then
9713 Set_Is_Ada_2012_Only (Entity (E_Id));
9714 Record_Rep_Item (Entity (E_Id), N);
9717 Check_Arg_Count (0);
9719 -- For Ada_2012 we unconditionally enforce the documented
9720 -- configuration pragma placement, since we do not want to
9721 -- tolerate mixed modes in a unit involving Ada 2012. That
9722 -- would cause real difficulties for those cases where there
9723 -- are incompatibilities between Ada 95 and Ada 2012. We could
9724 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
9726 Check_Valid_Configuration_Pragma;
9728 -- Now set appropriate Ada mode
9730 Ada_Version := Ada_2012;
9731 Ada_Version_Explicit := Ada_2012;
9732 Ada_Version_Pragma := N;
9736 ----------------------
9737 -- All_Calls_Remote --
9738 ----------------------
9740 -- pragma All_Calls_Remote [(library_package_NAME)];
9742 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
9743 Lib_Entity : Entity_Id;
9746 Check_Ada_83_Warning;
9747 Check_Valid_Library_Unit_Pragma;
9749 if Nkind (N) = N_Null_Statement then
9753 Lib_Entity := Find_Lib_Unit_Name;
9755 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
9757 if Present (Lib_Entity)
9758 and then not Debug_Flag_U
9760 if not Is_Remote_Call_Interface (Lib_Entity) then
9761 Error_Pragma ("pragma% only apply to rci unit");
9763 -- Set flag for entity of the library unit
9766 Set_Has_All_Calls_Remote (Lib_Entity);
9770 end All_Calls_Remote;
9776 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
9777 -- ARG ::= NAME | EXPRESSION
9779 -- The first two arguments are by convention intended to refer to an
9780 -- external tool and a tool-specific function. These arguments are
9783 when Pragma_Annotate => Annotate : declare
9789 Check_At_Least_N_Arguments (1);
9790 Check_Arg_Is_Identifier (Arg1);
9791 Check_No_Identifiers;
9794 -- Second parameter is optional, it is never analyzed
9799 -- Here if we have a second parameter
9802 -- Second parameter must be identifier
9804 Check_Arg_Is_Identifier (Arg2);
9806 -- Process remaining parameters if any
9809 while Present (Arg) loop
9810 Exp := Get_Pragma_Arg (Arg);
9813 if Is_Entity_Name (Exp) then
9816 -- For string literals, we assume Standard_String as the
9817 -- type, unless the string contains wide or wide_wide
9820 elsif Nkind (Exp) = N_String_Literal then
9821 if Has_Wide_Wide_Character (Exp) then
9822 Resolve (Exp, Standard_Wide_Wide_String);
9823 elsif Has_Wide_Character (Exp) then
9824 Resolve (Exp, Standard_Wide_String);
9826 Resolve (Exp, Standard_String);
9829 elsif Is_Overloaded (Exp) then
9831 ("ambiguous argument for pragma%", Exp);
9842 -------------------------------------------------
9843 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
9844 -------------------------------------------------
9847 -- ( [Check => ] Boolean_EXPRESSION
9848 -- [, [Message =>] Static_String_EXPRESSION]);
9850 -- pragma Assert_And_Cut
9851 -- ( [Check => ] Boolean_EXPRESSION
9852 -- [, [Message =>] Static_String_EXPRESSION]);
9855 -- ( [Check => ] Boolean_EXPRESSION
9856 -- [, [Message =>] Static_String_EXPRESSION]);
9858 -- pragma Loop_Invariant
9859 -- ( [Check => ] Boolean_EXPRESSION
9860 -- [, [Message =>] Static_String_EXPRESSION]);
9862 when Pragma_Assert |
9863 Pragma_Assert_And_Cut |
9865 Pragma_Loop_Invariant =>
9871 -- Assert is an Ada 2005 RM-defined pragma
9873 if Prag_Id = Pragma_Assert then
9876 -- The remaining ones are GNAT pragmas
9882 Check_At_Least_N_Arguments (1);
9883 Check_At_Most_N_Arguments (2);
9884 Check_Arg_Order ((Name_Check, Name_Message));
9885 Check_Optional_Identifier (Arg1, Name_Check);
9887 -- Special processing for Loop_Invariant
9889 if Prag_Id = Pragma_Loop_Invariant then
9891 -- Check restricted placement, must be within a loop
9893 Check_Loop_Pragma_Placement;
9895 -- Do preanalyze to deal with embedded Loop_Entry attribute
9897 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
9900 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
9901 -- a corresponding Check pragma:
9903 -- pragma Check (name, condition [, msg]);
9905 -- Where name is the identifier matching the pragma name. So
9906 -- rewrite pragma in this manner, transfer the message argument
9907 -- if present, and analyze the result
9909 -- Note: When dealing with a semantically analyzed tree, the
9910 -- information that a Check node N corresponds to a source Assert,
9911 -- Assume, or Assert_And_Cut pragma can be retrieved from the
9912 -- pragma kind of Original_Node(N).
9914 Expr := Get_Pragma_Arg (Arg1);
9916 Make_Pragma_Argument_Association (Loc,
9917 Expression => Make_Identifier (Loc, Pname)),
9918 Make_Pragma_Argument_Association (Sloc (Expr),
9919 Expression => Expr));
9921 if Arg_Count > 1 then
9922 Check_Optional_Identifier (Arg2, Name_Message);
9923 Append_To (Newa, New_Copy_Tree (Arg2));
9926 -- Rewrite as Check pragma
9930 Chars => Name_Check,
9931 Pragma_Argument_Associations => Newa));
9935 ----------------------
9936 -- Assertion_Policy --
9937 ----------------------
9939 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
9941 -- The following form is Ada 2012 only, but we allow it in all modes
9943 -- Pragma Assertion_Policy (
9944 -- ASSERTION_KIND => POLICY_IDENTIFIER
9945 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
9947 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
9949 -- RM_ASSERTION_KIND ::= Assert |
9950 -- Static_Predicate |
9951 -- Dynamic_Predicate |
9957 -- Type_Invariant'Class
9959 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
9963 -- Initial_Condition |
9970 -- Statement_Assertions
9972 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
9973 -- ID_ASSERTION_KIND list contains implementation-defined additions
9974 -- recognized by GNAT. The effect is to control the behavior of
9975 -- identically named aspects and pragmas, depending on the specified
9976 -- policy identifier:
9978 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
9980 -- Note: Check and Ignore are language-defined. Disable is a GNAT
9981 -- implementation defined addition that results in totally ignoring
9982 -- the corresponding assertion. If Disable is specified, then the
9983 -- argument of the assertion is not even analyzed. This is useful
9984 -- when the aspect/pragma argument references entities in a with'ed
9985 -- package that is replaced by a dummy package in the final build.
9987 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
9988 -- and Type_Invariant'Class were recognized by the parser and
9989 -- transformed into references to the special internal identifiers
9990 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
9991 -- processing is required here.
9993 when Pragma_Assertion_Policy => Assertion_Policy : declare
10002 -- This can always appear as a configuration pragma
10004 if Is_Configuration_Pragma then
10007 -- It can also appear in a declarative part or package spec in Ada
10008 -- 2012 mode. We allow this in other modes, but in that case we
10009 -- consider that we have an Ada 2012 pragma on our hands.
10012 Check_Is_In_Decl_Part_Or_Package_Spec;
10016 -- One argument case with no identifier (first form above)
10019 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
10020 or else Chars (Arg1) = No_Name)
10022 Check_Arg_Is_One_Of
10023 (Arg1, Name_Check, Name_Disable, Name_Ignore);
10025 -- Treat one argument Assertion_Policy as equivalent to:
10027 -- pragma Check_Policy (Assertion, policy)
10029 -- So rewrite pragma in that manner and link on to the chain
10030 -- of Check_Policy pragmas, marking the pragma as analyzed.
10032 Policy := Get_Pragma_Arg (Arg1);
10036 Chars => Name_Check_Policy,
10037 Pragma_Argument_Associations => New_List (
10038 Make_Pragma_Argument_Association (Loc,
10039 Expression => Make_Identifier (Loc, Name_Assertion)),
10041 Make_Pragma_Argument_Association (Loc,
10043 Make_Identifier (Sloc (Policy), Chars (Policy))))));
10046 -- Here if we have two or more arguments
10049 Check_At_Least_N_Arguments (1);
10052 -- Loop through arguments
10055 while Present (Arg) loop
10056 LocP := Sloc (Arg);
10058 -- Kind must be specified
10060 if Nkind (Arg) /= N_Pragma_Argument_Association
10061 or else Chars (Arg) = No_Name
10064 ("missing assertion kind for pragma%", Arg);
10067 -- Check Kind and Policy have allowed forms
10069 Kind := Chars (Arg);
10071 if not Is_Valid_Assertion_Kind (Kind) then
10073 ("invalid assertion kind for pragma%", Arg);
10076 Check_Arg_Is_One_Of
10077 (Arg, Name_Check, Name_Disable, Name_Ignore);
10079 -- We rewrite the Assertion_Policy pragma as a series of
10080 -- Check_Policy pragmas:
10082 -- Check_Policy (Kind, Policy);
10086 Chars => Name_Check_Policy,
10087 Pragma_Argument_Associations => New_List (
10088 Make_Pragma_Argument_Association (LocP,
10089 Expression => Make_Identifier (LocP, Kind)),
10090 Make_Pragma_Argument_Association (LocP,
10091 Expression => Get_Pragma_Arg (Arg)))));
10096 -- Rewrite the Assertion_Policy pragma as null since we have
10097 -- now inserted all the equivalent Check pragmas.
10099 Rewrite (N, Make_Null_Statement (Loc));
10102 end Assertion_Policy;
10104 ------------------------------
10105 -- Assume_No_Invalid_Values --
10106 ------------------------------
10108 -- pragma Assume_No_Invalid_Values (On | Off);
10110 when Pragma_Assume_No_Invalid_Values =>
10112 Check_Valid_Configuration_Pragma;
10113 Check_Arg_Count (1);
10114 Check_No_Identifiers;
10115 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10117 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
10118 Assume_No_Invalid_Values := True;
10120 Assume_No_Invalid_Values := False;
10123 --------------------------
10124 -- Attribute_Definition --
10125 --------------------------
10127 -- pragma Attribute_Definition
10128 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
10129 -- [Entity =>] LOCAL_NAME,
10130 -- [Expression =>] EXPRESSION | NAME);
10132 when Pragma_Attribute_Definition => Attribute_Definition : declare
10133 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
10138 Check_Arg_Count (3);
10139 Check_Optional_Identifier (Arg1, "attribute");
10140 Check_Optional_Identifier (Arg2, "entity");
10141 Check_Optional_Identifier (Arg3, "expression");
10143 if Nkind (Attribute_Designator) /= N_Identifier then
10144 Error_Msg_N ("attribute name expected", Attribute_Designator);
10148 Check_Arg_Is_Local_Name (Arg2);
10150 -- If the attribute is not recognized, then issue a warning (not
10151 -- an error), and ignore the pragma.
10153 Aname := Chars (Attribute_Designator);
10155 if not Is_Attribute_Name (Aname) then
10156 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
10160 -- Otherwise, rewrite the pragma as an attribute definition clause
10163 Make_Attribute_Definition_Clause (Loc,
10164 Name => Get_Pragma_Arg (Arg2),
10166 Expression => Get_Pragma_Arg (Arg3)));
10168 end Attribute_Definition;
10174 -- pragma AST_Entry (entry_IDENTIFIER);
10176 when Pragma_AST_Entry => AST_Entry : declare
10182 Check_Arg_Count (1);
10183 Check_No_Identifiers;
10184 Check_Arg_Is_Local_Name (Arg1);
10185 Ent := Entity (Get_Pragma_Arg (Arg1));
10187 -- Note: the implementation of the AST_Entry pragma could handle
10188 -- the entry family case fine, but for now we are consistent with
10189 -- the DEC rules, and do not allow the pragma, which of course
10190 -- has the effect of also forbidding the attribute.
10192 if Ekind (Ent) /= E_Entry then
10194 ("pragma% argument must be simple entry name", Arg1);
10196 elsif Is_AST_Entry (Ent) then
10198 ("duplicate % pragma for entry", Arg1);
10200 elsif Has_Homonym (Ent) then
10202 ("pragma% argument cannot specify overloaded entry", Arg1);
10206 FF : constant Entity_Id := First_Formal (Ent);
10209 if Present (FF) then
10210 if Present (Next_Formal (FF)) then
10212 ("entry for pragma% can have only one argument",
10215 elsif Parameter_Mode (FF) /= E_In_Parameter then
10217 ("entry parameter for pragma% must have mode IN",
10223 Set_Is_AST_Entry (Ent);
10231 -- pragma Asynchronous (LOCAL_NAME);
10233 when Pragma_Asynchronous => Asynchronous : declare
10239 Formal : Entity_Id;
10241 procedure Process_Async_Pragma;
10242 -- Common processing for procedure and access-to-procedure case
10244 --------------------------
10245 -- Process_Async_Pragma --
10246 --------------------------
10248 procedure Process_Async_Pragma is
10251 Set_Is_Asynchronous (Nm);
10255 -- The formals should be of mode IN (RM E.4.1(6))
10258 while Present (S) loop
10259 Formal := Defining_Identifier (S);
10261 if Nkind (Formal) = N_Defining_Identifier
10262 and then Ekind (Formal) /= E_In_Parameter
10265 ("pragma% procedure can only have IN parameter",
10272 Set_Is_Asynchronous (Nm);
10273 end Process_Async_Pragma;
10275 -- Start of processing for pragma Asynchronous
10278 Check_Ada_83_Warning;
10279 Check_No_Identifiers;
10280 Check_Arg_Count (1);
10281 Check_Arg_Is_Local_Name (Arg1);
10283 if Debug_Flag_U then
10287 C_Ent := Cunit_Entity (Current_Sem_Unit);
10288 Analyze (Get_Pragma_Arg (Arg1));
10289 Nm := Entity (Get_Pragma_Arg (Arg1));
10291 if not Is_Remote_Call_Interface (C_Ent)
10292 and then not Is_Remote_Types (C_Ent)
10294 -- This pragma should only appear in an RCI or Remote Types
10295 -- unit (RM E.4.1(4)).
10298 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
10301 if Ekind (Nm) = E_Procedure
10302 and then Nkind (Parent (Nm)) = N_Procedure_Specification
10304 if not Is_Remote_Call_Interface (Nm) then
10306 ("pragma% cannot be applied on non-remote procedure",
10310 L := Parameter_Specifications (Parent (Nm));
10311 Process_Async_Pragma;
10314 elsif Ekind (Nm) = E_Function then
10316 ("pragma% cannot be applied to function", Arg1);
10318 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
10319 if Is_Record_Type (Nm) then
10321 -- A record type that is the Equivalent_Type for a remote
10322 -- access-to-subprogram type.
10324 N := Declaration_Node (Corresponding_Remote_Type (Nm));
10327 -- A non-expanded RAS type (distribution is not enabled)
10329 N := Declaration_Node (Nm);
10332 if Nkind (N) = N_Full_Type_Declaration
10333 and then Nkind (Type_Definition (N)) =
10334 N_Access_Procedure_Definition
10336 L := Parameter_Specifications (Type_Definition (N));
10337 Process_Async_Pragma;
10339 if Is_Asynchronous (Nm)
10340 and then Expander_Active
10341 and then Get_PCS_Name /= Name_No_DSA
10343 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
10348 ("pragma% cannot reference access-to-function type",
10352 -- Only other possibility is Access-to-class-wide type
10354 elsif Is_Access_Type (Nm)
10355 and then Is_Class_Wide_Type (Designated_Type (Nm))
10357 Check_First_Subtype (Arg1);
10358 Set_Is_Asynchronous (Nm);
10359 if Expander_Active then
10360 RACW_Type_Is_Asynchronous (Nm);
10364 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
10372 -- pragma Atomic (LOCAL_NAME);
10374 when Pragma_Atomic =>
10375 Process_Atomic_Shared_Volatile;
10377 -----------------------
10378 -- Atomic_Components --
10379 -----------------------
10381 -- pragma Atomic_Components (array_LOCAL_NAME);
10383 -- This processing is shared by Volatile_Components
10385 when Pragma_Atomic_Components |
10386 Pragma_Volatile_Components =>
10388 Atomic_Components : declare
10395 Check_Ada_83_Warning;
10396 Check_No_Identifiers;
10397 Check_Arg_Count (1);
10398 Check_Arg_Is_Local_Name (Arg1);
10399 E_Id := Get_Pragma_Arg (Arg1);
10401 if Etype (E_Id) = Any_Type then
10405 E := Entity (E_Id);
10407 Check_Duplicate_Pragma (E);
10409 if Rep_Item_Too_Early (E, N)
10411 Rep_Item_Too_Late (E, N)
10416 D := Declaration_Node (E);
10419 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
10421 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10422 and then Nkind (D) = N_Object_Declaration
10423 and then Nkind (Object_Definition (D)) =
10424 N_Constrained_Array_Definition)
10426 -- The flag is set on the object, or on the base type
10428 if Nkind (D) /= N_Object_Declaration then
10429 E := Base_Type (E);
10432 Set_Has_Volatile_Components (E);
10434 if Prag_Id = Pragma_Atomic_Components then
10435 Set_Has_Atomic_Components (E);
10439 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
10441 end Atomic_Components;
10443 --------------------
10444 -- Attach_Handler --
10445 --------------------
10447 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
10449 when Pragma_Attach_Handler =>
10450 Check_Ada_83_Warning;
10451 Check_No_Identifiers;
10452 Check_Arg_Count (2);
10454 if No_Run_Time_Mode then
10455 Error_Msg_CRT ("Attach_Handler pragma", N);
10457 Check_Interrupt_Or_Attach_Handler;
10459 -- The expression that designates the attribute may depend on a
10460 -- discriminant, and is therefore a per-object expression, to
10461 -- be expanded in the init proc. If expansion is enabled, then
10462 -- perform semantic checks on a copy only.
10464 if Expander_Active then
10466 Temp : constant Node_Id :=
10467 New_Copy_Tree (Get_Pragma_Arg (Arg2));
10469 Set_Parent (Temp, N);
10470 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
10474 Analyze (Get_Pragma_Arg (Arg2));
10475 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
10478 Process_Interrupt_Or_Attach_Handler;
10481 --------------------
10482 -- C_Pass_By_Copy --
10483 --------------------
10485 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
10487 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
10493 Check_Valid_Configuration_Pragma;
10494 Check_Arg_Count (1);
10495 Check_Optional_Identifier (Arg1, "max_size");
10497 Arg := Get_Pragma_Arg (Arg1);
10498 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
10500 Val := Expr_Value (Arg);
10504 ("maximum size for pragma% must be positive", Arg1);
10506 elsif UI_Is_In_Int_Range (Val) then
10507 Default_C_Record_Mechanism := UI_To_Int (Val);
10509 -- If a giant value is given, Int'Last will do well enough.
10510 -- If sometime someone complains that a record larger than
10511 -- two gigabytes is not copied, we will worry about it then!
10514 Default_C_Record_Mechanism := Mechanism_Type'Last;
10516 end C_Pass_By_Copy;
10522 -- pragma Check ([Name =>] CHECK_KIND,
10523 -- [Check =>] Boolean_EXPRESSION
10524 -- [,[Message =>] String_EXPRESSION]);
10526 -- CHECK_KIND ::= IDENTIFIER |
10529 -- Invariant'Class |
10530 -- Type_Invariant'Class
10532 -- The identifiers Assertions and Statement_Assertions are not
10533 -- allowed, since they have special meaning for Check_Policy.
10535 when Pragma_Check => Check : declare
10543 Check_At_Least_N_Arguments (2);
10544 Check_At_Most_N_Arguments (3);
10545 Check_Optional_Identifier (Arg1, Name_Name);
10546 Check_Optional_Identifier (Arg2, Name_Check);
10548 if Arg_Count = 3 then
10549 Check_Optional_Identifier (Arg3, Name_Message);
10550 Str := Get_Pragma_Arg (Arg3);
10553 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
10554 Check_Arg_Is_Identifier (Arg1);
10555 Cname := Chars (Get_Pragma_Arg (Arg1));
10557 -- Check forbidden name Assertions or Statement_Assertions
10560 when Name_Assertions =>
10562 ("""Assertions"" is not allowed as a check kind "
10563 & "for pragma%", Arg1);
10565 when Name_Statement_Assertions =>
10567 ("""Statement_Assertions"" is not allowed as a check kind "
10568 & "for pragma%", Arg1);
10574 -- Check applicable policy. We skip this if Checked/Ignored status
10575 -- is already set (e.g. in the casse of a pragma from an aspect).
10577 if Is_Checked (N) or else Is_Ignored (N) then
10580 -- For a non-source pragma that is a rewriting of another pragma,
10581 -- copy the Is_Checked/Ignored status from the rewritten pragma.
10583 elsif Is_Rewrite_Substitution (N)
10584 and then Nkind (Original_Node (N)) = N_Pragma
10585 and then Original_Node (N) /= N
10587 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10588 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10590 -- Otherwise query the applicable policy at this point
10593 case Check_Kind (Cname) is
10594 when Name_Ignore =>
10595 Set_Is_Ignored (N, True);
10596 Set_Is_Checked (N, False);
10599 Set_Is_Ignored (N, False);
10600 Set_Is_Checked (N, True);
10602 -- For disable, rewrite pragma as null statement and skip
10603 -- rest of the analysis of the pragma.
10605 when Name_Disable =>
10606 Rewrite (N, Make_Null_Statement (Loc));
10610 -- No other possibilities
10613 raise Program_Error;
10617 -- If check kind was not Disable, then continue pragma analysis
10619 Expr := Get_Pragma_Arg (Arg2);
10621 -- Deal with SCO generation
10624 when Name_Predicate |
10627 -- Nothing to do: since checks occur in client units,
10628 -- the SCO for the aspect in the declaration unit is
10629 -- conservatively always enabled.
10635 if Is_Checked (N) and then not Split_PPC (N) then
10637 -- Mark aspect/pragma SCO as enabled
10639 Set_SCO_Pragma_Enabled (Loc);
10643 -- Deal with analyzing the string argument.
10645 if Arg_Count = 3 then
10647 -- If checks are not on we don't want any expansion (since
10648 -- such expansion would not get properly deleted) but
10649 -- we do want to analyze (to get proper references).
10650 -- The Preanalyze_And_Resolve routine does just what we want
10652 if Is_Ignored (N) then
10653 Preanalyze_And_Resolve (Str, Standard_String);
10655 -- Otherwise we need a proper analysis and expansion
10658 Analyze_And_Resolve (Str, Standard_String);
10662 -- Now you might think we could just do the same with the Boolean
10663 -- expression if checks are off (and expansion is on) and then
10664 -- rewrite the check as a null statement. This would work but we
10665 -- would lose the useful warnings about an assertion being bound
10666 -- to fail even if assertions are turned off.
10668 -- So instead we wrap the boolean expression in an if statement
10669 -- that looks like:
10671 -- if False and then condition then
10675 -- The reason we do this rewriting during semantic analysis rather
10676 -- than as part of normal expansion is that we cannot analyze and
10677 -- expand the code for the boolean expression directly, or it may
10678 -- cause insertion of actions that would escape the attempt to
10679 -- suppress the check code.
10681 -- Note that the Sloc for the if statement corresponds to the
10682 -- argument condition, not the pragma itself. The reason for
10683 -- this is that we may generate a warning if the condition is
10684 -- False at compile time, and we do not want to delete this
10685 -- warning when we delete the if statement.
10687 if Expander_Active and Is_Ignored (N) then
10688 Eloc := Sloc (Expr);
10691 Make_If_Statement (Eloc,
10693 Make_And_Then (Eloc,
10694 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
10695 Right_Opnd => Expr),
10696 Then_Statements => New_List (
10697 Make_Null_Statement (Eloc))));
10699 In_Assertion_Expr := In_Assertion_Expr + 1;
10701 In_Assertion_Expr := In_Assertion_Expr - 1;
10703 -- Check is active or expansion not active. In these cases we can
10704 -- just go ahead and analyze the boolean with no worries.
10707 In_Assertion_Expr := In_Assertion_Expr + 1;
10708 Analyze_And_Resolve (Expr, Any_Boolean);
10709 In_Assertion_Expr := In_Assertion_Expr - 1;
10713 --------------------------
10714 -- Check_Float_Overflow --
10715 --------------------------
10717 -- pragma Check_Float_Overflow;
10719 when Pragma_Check_Float_Overflow =>
10721 Check_Valid_Configuration_Pragma;
10722 Check_Arg_Count (0);
10723 Check_Float_Overflow := True;
10729 -- pragma Check_Name (check_IDENTIFIER);
10731 when Pragma_Check_Name =>
10733 Check_No_Identifiers;
10734 Check_Valid_Configuration_Pragma;
10735 Check_Arg_Count (1);
10736 Check_Arg_Is_Identifier (Arg1);
10739 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10742 for J in Check_Names.First .. Check_Names.Last loop
10743 if Check_Names.Table (J) = Nam then
10748 Check_Names.Append (Nam);
10755 -- This is the old style syntax, which is still allowed in all modes:
10757 -- pragma Check_Policy ([Name =>] CHECK_KIND
10758 -- [Policy =>] POLICY_IDENTIFIER);
10760 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
10762 -- CHECK_KIND ::= IDENTIFIER |
10765 -- Type_Invariant'Class |
10768 -- This is the new style syntax, compatible with Assertion_Policy
10769 -- and also allowed in all modes.
10771 -- Pragma Check_Policy (
10772 -- CHECK_KIND => POLICY_IDENTIFIER
10773 -- {, CHECK_KIND => POLICY_IDENTIFIER});
10775 -- Note: the identifiers Name and Policy are not allowed as
10776 -- Check_Kind values. This avoids ambiguities between the old and
10777 -- new form syntax.
10779 when Pragma_Check_Policy => Check_Policy : declare
10784 Check_At_Least_N_Arguments (1);
10786 -- A Check_Policy pragma can appear either as a configuration
10787 -- pragma, or in a declarative part or a package spec (see RM
10788 -- 11.5(5) for rules for Suppress/Unsuppress which are also
10789 -- followed for Check_Policy).
10791 if not Is_Configuration_Pragma then
10792 Check_Is_In_Decl_Part_Or_Package_Spec;
10795 -- Figure out if we have the old or new syntax. We have the
10796 -- old syntax if the first argument has no identifier, or the
10797 -- identifier is Name.
10799 if Nkind (Arg1) /= N_Pragma_Argument_Association
10800 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
10804 Check_Arg_Count (2);
10805 Check_Optional_Identifier (Arg1, Name_Name);
10806 Kind := Get_Pragma_Arg (Arg1);
10807 Rewrite_Assertion_Kind (Kind);
10808 Check_Arg_Is_Identifier (Arg1);
10810 -- Check forbidden check kind
10812 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
10813 Error_Msg_Name_2 := Chars (Kind);
10815 ("pragma% does not allow% as check name", Arg1);
10820 Check_Optional_Identifier (Arg2, Name_Policy);
10821 Check_Arg_Is_One_Of
10823 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
10825 -- And chain pragma on the Check_Policy_List for search
10827 Set_Next_Pragma (N, Opt.Check_Policy_List);
10828 Opt.Check_Policy_List := N;
10830 -- For the new syntax, what we do is to convert each argument to
10831 -- an old syntax equivalent. We do that because we want to chain
10832 -- old style Check_Policy pragmas for the search (we don't want
10833 -- to have to deal with multiple arguments in the search).
10843 while Present (Arg) loop
10844 LocP := Sloc (Arg);
10845 Argx := Get_Pragma_Arg (Arg);
10847 -- Kind must be specified
10849 if Nkind (Arg) /= N_Pragma_Argument_Association
10850 or else Chars (Arg) = No_Name
10853 ("missing assertion kind for pragma%", Arg);
10856 -- Construct equivalent old form syntax Check_Policy
10857 -- pragma and insert it to get remaining checks.
10861 Chars => Name_Check_Policy,
10862 Pragma_Argument_Associations => New_List (
10863 Make_Pragma_Argument_Association (LocP,
10865 Make_Identifier (LocP, Chars (Arg))),
10866 Make_Pragma_Argument_Association (Sloc (Argx),
10867 Expression => Argx))));
10872 -- Rewrite original Check_Policy pragma to null, since we
10873 -- have converted it into a series of old syntax pragmas.
10875 Rewrite (N, Make_Null_Statement (Loc));
10881 ---------------------
10882 -- CIL_Constructor --
10883 ---------------------
10885 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
10887 -- Processing for this pragma is shared with Java_Constructor
10893 -- pragma Comment (static_string_EXPRESSION)
10895 -- Processing for pragma Comment shares the circuitry for pragma
10896 -- Ident. The only differences are that Ident enforces a limit of 31
10897 -- characters on its argument, and also enforces limitations on
10898 -- placement for DEC compatibility. Pragma Comment shares neither of
10899 -- these restrictions.
10901 -------------------
10902 -- Common_Object --
10903 -------------------
10905 -- pragma Common_Object (
10906 -- [Internal =>] LOCAL_NAME
10907 -- [, [External =>] EXTERNAL_SYMBOL]
10908 -- [, [Size =>] EXTERNAL_SYMBOL]);
10910 -- Processing for this pragma is shared with Psect_Object
10912 ------------------------
10913 -- Compile_Time_Error --
10914 ------------------------
10916 -- pragma Compile_Time_Error
10917 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10919 when Pragma_Compile_Time_Error =>
10921 Process_Compile_Time_Warning_Or_Error;
10923 --------------------------
10924 -- Compile_Time_Warning --
10925 --------------------------
10927 -- pragma Compile_Time_Warning
10928 -- (boolean_EXPRESSION, static_string_EXPRESSION);
10930 when Pragma_Compile_Time_Warning =>
10932 Process_Compile_Time_Warning_Or_Error;
10934 -------------------
10935 -- Compiler_Unit --
10936 -------------------
10938 when Pragma_Compiler_Unit =>
10940 Check_Arg_Count (0);
10941 Set_Is_Compiler_Unit (Get_Source_Unit (N));
10943 -----------------------------
10944 -- Complete_Representation --
10945 -----------------------------
10947 -- pragma Complete_Representation;
10949 when Pragma_Complete_Representation =>
10951 Check_Arg_Count (0);
10953 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
10955 ("pragma & must appear within record representation clause");
10958 ----------------------------
10959 -- Complex_Representation --
10960 ----------------------------
10962 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
10964 when Pragma_Complex_Representation => Complex_Representation : declare
10971 Check_Arg_Count (1);
10972 Check_Optional_Identifier (Arg1, Name_Entity);
10973 Check_Arg_Is_Local_Name (Arg1);
10974 E_Id := Get_Pragma_Arg (Arg1);
10976 if Etype (E_Id) = Any_Type then
10980 E := Entity (E_Id);
10982 if not Is_Record_Type (E) then
10984 ("argument for pragma% must be record type", Arg1);
10987 Ent := First_Entity (E);
10990 or else No (Next_Entity (Ent))
10991 or else Present (Next_Entity (Next_Entity (Ent)))
10992 or else not Is_Floating_Point_Type (Etype (Ent))
10993 or else Etype (Ent) /= Etype (Next_Entity (Ent))
10996 ("record for pragma% must have two fields of the same "
10997 & "floating-point type", Arg1);
11000 Set_Has_Complex_Representation (Base_Type (E));
11002 -- We need to treat the type has having a non-standard
11003 -- representation, for back-end purposes, even though in
11004 -- general a complex will have the default representation
11005 -- of a record with two real components.
11007 Set_Has_Non_Standard_Rep (Base_Type (E));
11009 end Complex_Representation;
11011 -------------------------
11012 -- Component_Alignment --
11013 -------------------------
11015 -- pragma Component_Alignment (
11016 -- [Form =>] ALIGNMENT_CHOICE
11017 -- [, [Name =>] type_LOCAL_NAME]);
11019 -- ALIGNMENT_CHOICE ::=
11021 -- | Component_Size_4
11025 when Pragma_Component_Alignment => Component_AlignmentP : declare
11026 Args : Args_List (1 .. 2);
11027 Names : constant Name_List (1 .. 2) := (
11031 Form : Node_Id renames Args (1);
11032 Name : Node_Id renames Args (2);
11034 Atype : Component_Alignment_Kind;
11039 Gather_Associations (Names, Args);
11042 Error_Pragma ("missing Form argument for pragma%");
11045 Check_Arg_Is_Identifier (Form);
11047 -- Get proper alignment, note that Default = Component_Size on all
11048 -- machines we have so far, and we want to set this value rather
11049 -- than the default value to indicate that it has been explicitly
11050 -- set (and thus will not get overridden by the default component
11051 -- alignment for the current scope)
11053 if Chars (Form) = Name_Component_Size then
11054 Atype := Calign_Component_Size;
11056 elsif Chars (Form) = Name_Component_Size_4 then
11057 Atype := Calign_Component_Size_4;
11059 elsif Chars (Form) = Name_Default then
11060 Atype := Calign_Component_Size;
11062 elsif Chars (Form) = Name_Storage_Unit then
11063 Atype := Calign_Storage_Unit;
11067 ("invalid Form parameter for pragma%", Form);
11070 -- Case with no name, supplied, affects scope table entry
11074 (Scope_Stack.Last).Component_Alignment_Default := Atype;
11076 -- Case of name supplied
11079 Check_Arg_Is_Local_Name (Name);
11081 Typ := Entity (Name);
11084 or else Rep_Item_Too_Early (Typ, N)
11088 Typ := Underlying_Type (Typ);
11091 if not Is_Record_Type (Typ)
11092 and then not Is_Array_Type (Typ)
11095 ("Name parameter of pragma% must identify record or "
11096 & "array type", Name);
11099 -- An explicit Component_Alignment pragma overrides an
11100 -- implicit pragma Pack, but not an explicit one.
11102 if not Has_Pragma_Pack (Base_Type (Typ)) then
11103 Set_Is_Packed (Base_Type (Typ), False);
11104 Set_Component_Alignment (Base_Type (Typ), Atype);
11107 end Component_AlignmentP;
11109 --------------------
11110 -- Contract_Cases --
11111 --------------------
11113 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
11115 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
11117 -- CASE_GUARD ::= boolean_EXPRESSION | others
11119 -- CONSEQUENCE ::= boolean_EXPRESSION
11121 when Pragma_Contract_Cases => Contract_Cases : declare
11122 Subp_Decl : Node_Id;
11126 Check_Arg_Count (1);
11128 -- The pragma is analyzed at the end of the declarative part which
11129 -- contains the related subprogram. Reset the analyzed flag.
11131 Set_Analyzed (N, False);
11133 -- Ensure the proper placement of the pragma. Contract_Cases must
11134 -- be associated with a subprogram declaration or a body that acts
11138 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
11140 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11141 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11142 or else not Acts_As_Spec (Subp_Decl))
11148 -- When the pragma appears on a subprogram body, perform the full
11151 if Nkind (Subp_Decl) = N_Subprogram_Body then
11152 Analyze_Contract_Cases_In_Decl_Part (N);
11154 -- When Contract_Cases applies to a subprogram compilation unit,
11155 -- the corresponding pragma is placed after the unit's declaration
11156 -- node and needs to be analyzed immediately.
11158 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11159 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11161 Analyze_Contract_Cases_In_Decl_Part (N);
11164 -- Chain the pragma on the contract for further processing
11166 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
11167 end Contract_Cases;
11173 -- pragma Controlled (first_subtype_LOCAL_NAME);
11175 when Pragma_Controlled => Controlled : declare
11179 Check_No_Identifiers;
11180 Check_Arg_Count (1);
11181 Check_Arg_Is_Local_Name (Arg1);
11182 Arg := Get_Pragma_Arg (Arg1);
11184 if not Is_Entity_Name (Arg)
11185 or else not Is_Access_Type (Entity (Arg))
11187 Error_Pragma_Arg ("pragma% requires access type", Arg1);
11189 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
11197 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
11198 -- [Entity =>] LOCAL_NAME);
11200 when Pragma_Convention => Convention : declare
11203 pragma Warnings (Off, C);
11204 pragma Warnings (Off, E);
11206 Check_Arg_Order ((Name_Convention, Name_Entity));
11207 Check_Ada_83_Warning;
11208 Check_Arg_Count (2);
11209 Process_Convention (C, E);
11212 ---------------------------
11213 -- Convention_Identifier --
11214 ---------------------------
11216 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
11217 -- [Convention =>] convention_IDENTIFIER);
11219 when Pragma_Convention_Identifier => Convention_Identifier : declare
11225 Check_Arg_Order ((Name_Name, Name_Convention));
11226 Check_Arg_Count (2);
11227 Check_Optional_Identifier (Arg1, Name_Name);
11228 Check_Optional_Identifier (Arg2, Name_Convention);
11229 Check_Arg_Is_Identifier (Arg1);
11230 Check_Arg_Is_Identifier (Arg2);
11231 Idnam := Chars (Get_Pragma_Arg (Arg1));
11232 Cname := Chars (Get_Pragma_Arg (Arg2));
11234 if Is_Convention_Name (Cname) then
11235 Record_Convention_Identifier
11236 (Idnam, Get_Convention_Id (Cname));
11239 ("second arg for % pragma must be convention", Arg2);
11241 end Convention_Identifier;
11247 -- pragma CPP_Class ([Entity =>] local_NAME)
11249 when Pragma_CPP_Class => CPP_Class : declare
11253 if Warn_On_Obsolescent_Feature then
11255 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
11256 & "effect; replace it by pragma import?j?", N);
11259 Check_Arg_Count (1);
11263 Chars => Name_Import,
11264 Pragma_Argument_Associations => New_List (
11265 Make_Pragma_Argument_Association (Loc,
11266 Expression => Make_Identifier (Loc, Name_CPP)),
11267 New_Copy (First (Pragma_Argument_Associations (N))))));
11271 ---------------------
11272 -- CPP_Constructor --
11273 ---------------------
11275 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
11276 -- [, [External_Name =>] static_string_EXPRESSION ]
11277 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11279 when Pragma_CPP_Constructor => CPP_Constructor : declare
11282 Def_Id : Entity_Id;
11283 Tag_Typ : Entity_Id;
11287 Check_At_Least_N_Arguments (1);
11288 Check_At_Most_N_Arguments (3);
11289 Check_Optional_Identifier (Arg1, Name_Entity);
11290 Check_Arg_Is_Local_Name (Arg1);
11292 Id := Get_Pragma_Arg (Arg1);
11293 Find_Program_Unit_Name (Id);
11295 -- If we did not find the name, we are done
11297 if Etype (Id) = Any_Type then
11301 Def_Id := Entity (Id);
11303 -- Check if already defined as constructor
11305 if Is_Constructor (Def_Id) then
11307 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
11311 if Ekind (Def_Id) = E_Function
11312 and then (Is_CPP_Class (Etype (Def_Id))
11313 or else (Is_Class_Wide_Type (Etype (Def_Id))
11315 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
11317 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
11319 ("'C'P'P constructor must be defined in the scope of "
11320 & "its returned type", Arg1);
11323 if Arg_Count >= 2 then
11324 Set_Imported (Def_Id);
11325 Set_Is_Public (Def_Id);
11326 Process_Interface_Name (Def_Id, Arg2, Arg3);
11329 Set_Has_Completion (Def_Id);
11330 Set_Is_Constructor (Def_Id);
11331 Set_Convention (Def_Id, Convention_CPP);
11333 -- Imported C++ constructors are not dispatching primitives
11334 -- because in C++ they don't have a dispatch table slot.
11335 -- However, in Ada the constructor has the profile of a
11336 -- function that returns a tagged type and therefore it has
11337 -- been treated as a primitive operation during semantic
11338 -- analysis. We now remove it from the list of primitive
11339 -- operations of the type.
11341 if Is_Tagged_Type (Etype (Def_Id))
11342 and then not Is_Class_Wide_Type (Etype (Def_Id))
11343 and then Is_Dispatching_Operation (Def_Id)
11345 Tag_Typ := Etype (Def_Id);
11347 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
11348 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
11352 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
11353 Set_Is_Dispatching_Operation (Def_Id, False);
11356 -- For backward compatibility, if the constructor returns a
11357 -- class wide type, and we internally change the return type to
11358 -- the corresponding root type.
11360 if Is_Class_Wide_Type (Etype (Def_Id)) then
11361 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
11365 ("pragma% requires function returning a 'C'P'P_Class type",
11368 end CPP_Constructor;
11374 when Pragma_CPP_Virtual => CPP_Virtual : declare
11378 if Warn_On_Obsolescent_Feature then
11380 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
11389 when Pragma_CPP_Vtable => CPP_Vtable : declare
11393 if Warn_On_Obsolescent_Feature then
11395 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
11404 -- pragma CPU (EXPRESSION);
11406 when Pragma_CPU => CPU : declare
11407 P : constant Node_Id := Parent (N);
11413 Check_No_Identifiers;
11414 Check_Arg_Count (1);
11418 if Nkind (P) = N_Subprogram_Body then
11419 Check_In_Main_Program;
11421 Arg := Get_Pragma_Arg (Arg1);
11422 Analyze_And_Resolve (Arg, Any_Integer);
11424 Ent := Defining_Unit_Name (Specification (P));
11426 if Nkind (Ent) = N_Defining_Program_Unit_Name then
11427 Ent := Defining_Identifier (Ent);
11432 if not Is_Static_Expression (Arg) then
11433 Flag_Non_Static_Expr
11434 ("main subprogram affinity is not static!", Arg);
11437 -- If constraint error, then we already signalled an error
11439 elsif Raises_Constraint_Error (Arg) then
11442 -- Otherwise check in range
11446 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
11447 -- This is the entity System.Multiprocessors.CPU_Range;
11449 Val : constant Uint := Expr_Value (Arg);
11452 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
11454 Val > Expr_Value (Type_High_Bound (CPU_Id))
11457 ("main subprogram CPU is out of range", Arg1);
11463 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11467 elsif Nkind (P) = N_Task_Definition then
11468 Arg := Get_Pragma_Arg (Arg1);
11469 Ent := Defining_Identifier (Parent (P));
11471 -- The expression must be analyzed in the special manner
11472 -- described in "Handling of Default and Per-Object
11473 -- Expressions" in sem.ads.
11475 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
11477 -- Anything else is incorrect
11483 -- Check duplicate pragma before we chain the pragma in the Rep
11484 -- Item chain of Ent.
11486 Check_Duplicate_Pragma (Ent);
11487 Record_Rep_Item (Ent, N);
11494 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
11496 when Pragma_Debug => Debug : declare
11503 -- The condition for executing the call is that the expander
11504 -- is active and that we are not ignoring this debug pragma.
11509 (Expander_Active and then not Is_Ignored (N)),
11512 if not Is_Ignored (N) then
11513 Set_SCO_Pragma_Enabled (Loc);
11516 if Arg_Count = 2 then
11518 Make_And_Then (Loc,
11519 Left_Opnd => Relocate_Node (Cond),
11520 Right_Opnd => Get_Pragma_Arg (Arg1));
11521 Call := Get_Pragma_Arg (Arg2);
11523 Call := Get_Pragma_Arg (Arg1);
11527 N_Indexed_Component,
11531 N_Selected_Component)
11533 -- If this pragma Debug comes from source, its argument was
11534 -- parsed as a name form (which is syntactically identical).
11535 -- In a generic context a parameterless call will be left as
11536 -- an expanded name (if global) or selected_component if local.
11537 -- Change it to a procedure call statement now.
11539 Change_Name_To_Procedure_Call_Statement (Call);
11541 elsif Nkind (Call) = N_Procedure_Call_Statement then
11543 -- Already in the form of a procedure call statement: nothing
11544 -- to do (could happen in case of an internally generated
11550 -- All other cases: diagnose error
11553 ("argument of pragma ""Debug"" is not procedure call",
11558 -- Rewrite into a conditional with an appropriate condition. We
11559 -- wrap the procedure call in a block so that overhead from e.g.
11560 -- use of the secondary stack does not generate execution overhead
11561 -- for suppressed conditions.
11563 -- Normally the analysis that follows will freeze the subprogram
11564 -- being called. However, if the call is to a null procedure,
11565 -- we want to freeze it before creating the block, because the
11566 -- analysis that follows may be done with expansion disabled, in
11567 -- which case the body will not be generated, leading to spurious
11570 if Nkind (Call) = N_Procedure_Call_Statement
11571 and then Is_Entity_Name (Name (Call))
11573 Analyze (Name (Call));
11574 Freeze_Before (N, Entity (Name (Call)));
11577 Rewrite (N, Make_Implicit_If_Statement (N,
11579 Then_Statements => New_List (
11580 Make_Block_Statement (Loc,
11581 Handled_Statement_Sequence =>
11582 Make_Handled_Sequence_Of_Statements (Loc,
11583 Statements => New_List (Relocate_Node (Call)))))));
11591 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
11593 when Pragma_Debug_Policy =>
11595 Check_Arg_Count (1);
11596 Check_No_Identifiers;
11597 Check_Arg_Is_Identifier (Arg1);
11599 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
11600 -- rewrite it that way, and let the rest of the checking come
11601 -- from analyzing the rewritten pragma.
11605 Chars => Name_Check_Policy,
11606 Pragma_Argument_Associations => New_List (
11607 Make_Pragma_Argument_Association (Loc,
11608 Expression => Make_Identifier (Loc, Name_Debug)),
11610 Make_Pragma_Argument_Association (Loc,
11611 Expression => Get_Pragma_Arg (Arg1)))));
11618 -- pragma Depends (DEPENDENCY_RELATION);
11620 -- DEPENDENCY_RELATION ::=
11622 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
11624 -- DEPENDENCY_CLAUSE ::=
11625 -- OUTPUT_LIST =>[+] INPUT_LIST
11626 -- | NULL_DEPENDENCY_CLAUSE
11628 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
11630 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
11632 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
11634 -- OUTPUT ::= NAME | FUNCTION_RESULT
11637 -- where FUNCTION_RESULT is a function Result attribute_reference
11639 when Pragma_Depends => Depends : declare
11640 Subp_Decl : Node_Id;
11645 Check_Arg_Count (1);
11647 -- Ensure the proper placement of the pragma. Depends must be
11648 -- associated with a subprogram declaration or a body that acts
11652 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
11654 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
11655 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
11656 or else not Acts_As_Spec (Subp_Decl))
11662 -- When the pragma appears on a subprogram body, perform the full
11665 if Nkind (Subp_Decl) = N_Subprogram_Body then
11666 Analyze_Depends_In_Decl_Part (N);
11668 -- When Depends applies to a subprogram compilation unit, the
11669 -- corresponding pragma is placed after the unit's declaration
11670 -- node and needs to be analyzed immediately.
11672 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
11673 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
11675 Analyze_Depends_In_Decl_Part (N);
11678 -- Chain the pragma on the contract for further processing
11680 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
11683 ---------------------
11684 -- Detect_Blocking --
11685 ---------------------
11687 -- pragma Detect_Blocking;
11689 when Pragma_Detect_Blocking =>
11691 Check_Arg_Count (0);
11692 Check_Valid_Configuration_Pragma;
11693 Detect_Blocking := True;
11695 --------------------------
11696 -- Default_Storage_Pool --
11697 --------------------------
11699 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
11701 when Pragma_Default_Storage_Pool =>
11703 Check_Arg_Count (1);
11705 -- Default_Storage_Pool can appear as a configuration pragma, or
11706 -- in a declarative part or a package spec.
11708 if not Is_Configuration_Pragma then
11709 Check_Is_In_Decl_Part_Or_Package_Spec;
11712 -- Case of Default_Storage_Pool (null);
11714 if Nkind (Expression (Arg1)) = N_Null then
11715 Analyze (Expression (Arg1));
11717 -- This is an odd case, this is not really an expression, so
11718 -- we don't have a type for it. So just set the type to Empty.
11720 Set_Etype (Expression (Arg1), Empty);
11722 -- Case of Default_Storage_Pool (storage_pool_NAME);
11725 -- If it's a configuration pragma, then the only allowed
11726 -- argument is "null".
11728 if Is_Configuration_Pragma then
11729 Error_Pragma_Arg ("NULL expected", Arg1);
11732 -- The expected type for a non-"null" argument is
11733 -- Root_Storage_Pool'Class.
11735 Analyze_And_Resolve
11736 (Get_Pragma_Arg (Arg1),
11737 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
11740 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
11741 -- for an access type will use this information to set the
11742 -- appropriate attributes of the access type.
11744 Default_Pool := Expression (Arg1);
11746 ------------------------------------
11747 -- Disable_Atomic_Synchronization --
11748 ------------------------------------
11750 -- pragma Disable_Atomic_Synchronization [(Entity)];
11752 when Pragma_Disable_Atomic_Synchronization =>
11754 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
11756 -------------------
11757 -- Discard_Names --
11758 -------------------
11760 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
11762 when Pragma_Discard_Names => Discard_Names : declare
11767 Check_Ada_83_Warning;
11769 -- Deal with configuration pragma case
11771 if Arg_Count = 0 and then Is_Configuration_Pragma then
11772 Global_Discard_Names := True;
11775 -- Otherwise, check correct appropriate context
11778 Check_Is_In_Decl_Part_Or_Package_Spec;
11780 if Arg_Count = 0 then
11782 -- If there is no parameter, then from now on this pragma
11783 -- applies to any enumeration, exception or tagged type
11784 -- defined in the current declarative part, and recursively
11785 -- to any nested scope.
11787 Set_Discard_Names (Current_Scope);
11791 Check_Arg_Count (1);
11792 Check_Optional_Identifier (Arg1, Name_On);
11793 Check_Arg_Is_Local_Name (Arg1);
11795 E_Id := Get_Pragma_Arg (Arg1);
11797 if Etype (E_Id) = Any_Type then
11800 E := Entity (E_Id);
11803 if (Is_First_Subtype (E)
11805 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
11806 or else Ekind (E) = E_Exception
11808 Set_Discard_Names (E);
11809 Record_Rep_Item (E, N);
11813 ("inappropriate entity for pragma%", Arg1);
11820 ------------------------
11821 -- Dispatching_Domain --
11822 ------------------------
11824 -- pragma Dispatching_Domain (EXPRESSION);
11826 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
11827 P : constant Node_Id := Parent (N);
11833 Check_No_Identifiers;
11834 Check_Arg_Count (1);
11836 -- This pragma is born obsolete, but not the aspect
11838 if not From_Aspect_Specification (N) then
11840 (No_Obsolescent_Features, Pragma_Identifier (N));
11843 if Nkind (P) = N_Task_Definition then
11844 Arg := Get_Pragma_Arg (Arg1);
11845 Ent := Defining_Identifier (Parent (P));
11847 -- The expression must be analyzed in the special manner
11848 -- described in "Handling of Default and Per-Object
11849 -- Expressions" in sem.ads.
11851 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
11853 -- Check duplicate pragma before we chain the pragma in the Rep
11854 -- Item chain of Ent.
11856 Check_Duplicate_Pragma (Ent);
11857 Record_Rep_Item (Ent, N);
11859 -- Anything else is incorrect
11864 end Dispatching_Domain;
11870 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
11872 when Pragma_Elaborate => Elaborate : declare
11877 -- Pragma must be in context items list of a compilation unit
11879 if not Is_In_Context_Clause then
11883 -- Must be at least one argument
11885 if Arg_Count = 0 then
11886 Error_Pragma ("pragma% requires at least one argument");
11889 -- In Ada 83 mode, there can be no items following it in the
11890 -- context list except other pragmas and implicit with clauses
11891 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
11892 -- placement rule does not apply.
11894 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
11896 while Present (Citem) loop
11897 if Nkind (Citem) = N_Pragma
11898 or else (Nkind (Citem) = N_With_Clause
11899 and then Implicit_With (Citem))
11904 ("(Ada 83) pragma% must be at end of context clause");
11911 -- Finally, the arguments must all be units mentioned in a with
11912 -- clause in the same context clause. Note we already checked (in
11913 -- Par.Prag) that the arguments are all identifiers or selected
11917 Outer : while Present (Arg) loop
11918 Citem := First (List_Containing (N));
11919 Inner : while Citem /= N loop
11920 if Nkind (Citem) = N_With_Clause
11921 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
11923 Set_Elaborate_Present (Citem, True);
11924 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
11925 Generate_Reference (Entity (Name (Citem)), Citem);
11927 -- With the pragma present, elaboration calls on
11928 -- subprograms from the named unit need no further
11929 -- checks, as long as the pragma appears in the current
11930 -- compilation unit. If the pragma appears in some unit
11931 -- in the context, there might still be a need for an
11932 -- Elaborate_All_Desirable from the current compilation
11933 -- to the named unit, so we keep the check enabled.
11935 if In_Extended_Main_Source_Unit (N) then
11936 Set_Suppress_Elaboration_Warnings
11937 (Entity (Name (Citem)));
11948 ("argument of pragma% is not withed unit", Arg);
11954 -- Give a warning if operating in static mode with -gnatwl
11955 -- (elaboration warnings enabled) switch set.
11957 if Elab_Warnings and not Dynamic_Elaboration_Checks then
11959 ("?l?use of pragma Elaborate may not be safe", N);
11961 ("?l?use pragma Elaborate_All instead if possible", N);
11965 -------------------
11966 -- Elaborate_All --
11967 -------------------
11969 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
11971 when Pragma_Elaborate_All => Elaborate_All : declare
11976 Check_Ada_83_Warning;
11978 -- Pragma must be in context items list of a compilation unit
11980 if not Is_In_Context_Clause then
11984 -- Must be at least one argument
11986 if Arg_Count = 0 then
11987 Error_Pragma ("pragma% requires at least one argument");
11990 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
11991 -- have to appear at the end of the context clause, but may
11992 -- appear mixed in with other items, even in Ada 83 mode.
11994 -- Final check: the arguments must all be units mentioned in
11995 -- a with clause in the same context clause. Note that we
11996 -- already checked (in Par.Prag) that all the arguments are
11997 -- either identifiers or selected components.
12000 Outr : while Present (Arg) loop
12001 Citem := First (List_Containing (N));
12002 Innr : while Citem /= N loop
12003 if Nkind (Citem) = N_With_Clause
12004 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
12006 Set_Elaborate_All_Present (Citem, True);
12007 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
12009 -- Suppress warnings and elaboration checks on the named
12010 -- unit if the pragma is in the current compilation, as
12011 -- for pragma Elaborate.
12013 if In_Extended_Main_Source_Unit (N) then
12014 Set_Suppress_Elaboration_Warnings
12015 (Entity (Name (Citem)));
12024 Set_Error_Posted (N);
12026 ("argument of pragma% is not withed unit", Arg);
12033 --------------------
12034 -- Elaborate_Body --
12035 --------------------
12037 -- pragma Elaborate_Body [( library_unit_NAME )];
12039 when Pragma_Elaborate_Body => Elaborate_Body : declare
12040 Cunit_Node : Node_Id;
12041 Cunit_Ent : Entity_Id;
12044 Check_Ada_83_Warning;
12045 Check_Valid_Library_Unit_Pragma;
12047 if Nkind (N) = N_Null_Statement then
12051 Cunit_Node := Cunit (Current_Sem_Unit);
12052 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12054 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
12057 Error_Pragma ("pragma% must refer to a spec, not a body");
12059 Set_Body_Required (Cunit_Node, True);
12060 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
12062 -- If we are in dynamic elaboration mode, then we suppress
12063 -- elaboration warnings for the unit, since it is definitely
12064 -- fine NOT to do dynamic checks at the first level (and such
12065 -- checks will be suppressed because no elaboration boolean
12066 -- is created for Elaborate_Body packages).
12068 -- But in the static model of elaboration, Elaborate_Body is
12069 -- definitely NOT good enough to ensure elaboration safety on
12070 -- its own, since the body may WITH other units that are not
12071 -- safe from an elaboration point of view, so a client must
12072 -- still do an Elaborate_All on such units.
12074 -- Debug flag -gnatdD restores the old behavior of 3.13, where
12075 -- Elaborate_Body always suppressed elab warnings.
12077 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
12078 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
12081 end Elaborate_Body;
12083 ------------------------
12084 -- Elaboration_Checks --
12085 ------------------------
12087 -- pragma Elaboration_Checks (Static | Dynamic);
12089 when Pragma_Elaboration_Checks =>
12091 Check_Arg_Count (1);
12092 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
12093 Dynamic_Elaboration_Checks :=
12094 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
12100 -- pragma Eliminate (
12101 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
12102 -- [,[Entity =>] IDENTIFIER |
12103 -- SELECTED_COMPONENT |
12105 -- [, OVERLOADING_RESOLUTION]);
12107 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
12110 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
12111 -- FUNCTION_PROFILE
12113 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
12115 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
12116 -- Result_Type => result_SUBTYPE_NAME]
12118 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
12119 -- SUBTYPE_NAME ::= STRING_LITERAL
12121 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
12122 -- SOURCE_TRACE ::= STRING_LITERAL
12124 when Pragma_Eliminate => Eliminate : declare
12125 Args : Args_List (1 .. 5);
12126 Names : constant Name_List (1 .. 5) := (
12129 Name_Parameter_Types,
12131 Name_Source_Location);
12133 Unit_Name : Node_Id renames Args (1);
12134 Entity : Node_Id renames Args (2);
12135 Parameter_Types : Node_Id renames Args (3);
12136 Result_Type : Node_Id renames Args (4);
12137 Source_Location : Node_Id renames Args (5);
12141 Check_Valid_Configuration_Pragma;
12142 Gather_Associations (Names, Args);
12144 if No (Unit_Name) then
12145 Error_Pragma ("missing Unit_Name argument for pragma%");
12149 and then (Present (Parameter_Types)
12151 Present (Result_Type)
12153 Present (Source_Location))
12155 Error_Pragma ("missing Entity argument for pragma%");
12158 if (Present (Parameter_Types)
12160 Present (Result_Type))
12162 Present (Source_Location)
12165 ("parameter profile and source location cannot be used "
12166 & "together in pragma%");
12169 Process_Eliminate_Pragma
12178 -----------------------------------
12179 -- Enable_Atomic_Synchronization --
12180 -----------------------------------
12182 -- pragma Enable_Atomic_Synchronization [(Entity)];
12184 when Pragma_Enable_Atomic_Synchronization =>
12186 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
12193 -- [ Convention =>] convention_IDENTIFIER,
12194 -- [ Entity =>] local_NAME
12195 -- [, [External_Name =>] static_string_EXPRESSION ]
12196 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12198 when Pragma_Export => Export : declare
12200 Def_Id : Entity_Id;
12202 pragma Warnings (Off, C);
12205 Check_Ada_83_Warning;
12209 Name_External_Name,
12212 Check_At_Least_N_Arguments (2);
12213 Check_At_Most_N_Arguments (4);
12214 Process_Convention (C, Def_Id);
12216 if Ekind (Def_Id) /= E_Constant then
12217 Note_Possible_Modification
12218 (Get_Pragma_Arg (Arg2), Sure => False);
12221 Process_Interface_Name (Def_Id, Arg3, Arg4);
12222 Set_Exported (Def_Id, Arg2);
12224 -- If the entity is a deferred constant, propagate the information
12225 -- to the full view, because gigi elaborates the full view only.
12227 if Ekind (Def_Id) = E_Constant
12228 and then Present (Full_View (Def_Id))
12231 Id2 : constant Entity_Id := Full_View (Def_Id);
12233 Set_Is_Exported (Id2, Is_Exported (Def_Id));
12234 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
12235 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
12240 ----------------------
12241 -- Export_Exception --
12242 ----------------------
12244 -- pragma Export_Exception (
12245 -- [Internal =>] LOCAL_NAME
12246 -- [, [External =>] EXTERNAL_SYMBOL]
12247 -- [, [Form =>] Ada | VMS]
12248 -- [, [Code =>] static_integer_EXPRESSION]);
12250 when Pragma_Export_Exception => Export_Exception : declare
12251 Args : Args_List (1 .. 4);
12252 Names : constant Name_List (1 .. 4) := (
12258 Internal : Node_Id renames Args (1);
12259 External : Node_Id renames Args (2);
12260 Form : Node_Id renames Args (3);
12261 Code : Node_Id renames Args (4);
12266 if Inside_A_Generic then
12267 Error_Pragma ("pragma% cannot be used for generic entities");
12270 Gather_Associations (Names, Args);
12271 Process_Extended_Import_Export_Exception_Pragma (
12272 Arg_Internal => Internal,
12273 Arg_External => External,
12277 if not Is_VMS_Exception (Entity (Internal)) then
12278 Set_Exported (Entity (Internal), Internal);
12280 end Export_Exception;
12282 ---------------------
12283 -- Export_Function --
12284 ---------------------
12286 -- pragma Export_Function (
12287 -- [Internal =>] LOCAL_NAME
12288 -- [, [External =>] EXTERNAL_SYMBOL]
12289 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12290 -- [, [Result_Type =>] TYPE_DESIGNATOR]
12291 -- [, [Mechanism =>] MECHANISM]
12292 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
12294 -- EXTERNAL_SYMBOL ::=
12296 -- | static_string_EXPRESSION
12298 -- PARAMETER_TYPES ::=
12300 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12302 -- TYPE_DESIGNATOR ::=
12304 -- | subtype_Name ' Access
12308 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12310 -- MECHANISM_ASSOCIATION ::=
12311 -- [formal_parameter_NAME =>] MECHANISM_NAME
12313 -- MECHANISM_NAME ::=
12316 -- | Descriptor [([Class =>] CLASS_NAME)]
12318 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12320 when Pragma_Export_Function => Export_Function : declare
12321 Args : Args_List (1 .. 6);
12322 Names : constant Name_List (1 .. 6) := (
12325 Name_Parameter_Types,
12328 Name_Result_Mechanism);
12330 Internal : Node_Id renames Args (1);
12331 External : Node_Id renames Args (2);
12332 Parameter_Types : Node_Id renames Args (3);
12333 Result_Type : Node_Id renames Args (4);
12334 Mechanism : Node_Id renames Args (5);
12335 Result_Mechanism : Node_Id renames Args (6);
12339 Gather_Associations (Names, Args);
12340 Process_Extended_Import_Export_Subprogram_Pragma (
12341 Arg_Internal => Internal,
12342 Arg_External => External,
12343 Arg_Parameter_Types => Parameter_Types,
12344 Arg_Result_Type => Result_Type,
12345 Arg_Mechanism => Mechanism,
12346 Arg_Result_Mechanism => Result_Mechanism);
12347 end Export_Function;
12349 -------------------
12350 -- Export_Object --
12351 -------------------
12353 -- pragma Export_Object (
12354 -- [Internal =>] LOCAL_NAME
12355 -- [, [External =>] EXTERNAL_SYMBOL]
12356 -- [, [Size =>] EXTERNAL_SYMBOL]);
12358 -- EXTERNAL_SYMBOL ::=
12360 -- | static_string_EXPRESSION
12362 -- PARAMETER_TYPES ::=
12364 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12366 -- TYPE_DESIGNATOR ::=
12368 -- | subtype_Name ' Access
12372 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12374 -- MECHANISM_ASSOCIATION ::=
12375 -- [formal_parameter_NAME =>] MECHANISM_NAME
12377 -- MECHANISM_NAME ::=
12380 -- | Descriptor [([Class =>] CLASS_NAME)]
12382 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12384 when Pragma_Export_Object => Export_Object : declare
12385 Args : Args_List (1 .. 3);
12386 Names : constant Name_List (1 .. 3) := (
12391 Internal : Node_Id renames Args (1);
12392 External : Node_Id renames Args (2);
12393 Size : Node_Id renames Args (3);
12397 Gather_Associations (Names, Args);
12398 Process_Extended_Import_Export_Object_Pragma (
12399 Arg_Internal => Internal,
12400 Arg_External => External,
12404 ----------------------
12405 -- Export_Procedure --
12406 ----------------------
12408 -- pragma Export_Procedure (
12409 -- [Internal =>] LOCAL_NAME
12410 -- [, [External =>] EXTERNAL_SYMBOL]
12411 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12412 -- [, [Mechanism =>] MECHANISM]);
12414 -- EXTERNAL_SYMBOL ::=
12416 -- | static_string_EXPRESSION
12418 -- PARAMETER_TYPES ::=
12420 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12422 -- TYPE_DESIGNATOR ::=
12424 -- | subtype_Name ' Access
12428 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12430 -- MECHANISM_ASSOCIATION ::=
12431 -- [formal_parameter_NAME =>] MECHANISM_NAME
12433 -- MECHANISM_NAME ::=
12436 -- | Descriptor [([Class =>] CLASS_NAME)]
12438 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12440 when Pragma_Export_Procedure => Export_Procedure : declare
12441 Args : Args_List (1 .. 4);
12442 Names : constant Name_List (1 .. 4) := (
12445 Name_Parameter_Types,
12448 Internal : Node_Id renames Args (1);
12449 External : Node_Id renames Args (2);
12450 Parameter_Types : Node_Id renames Args (3);
12451 Mechanism : Node_Id renames Args (4);
12455 Gather_Associations (Names, Args);
12456 Process_Extended_Import_Export_Subprogram_Pragma (
12457 Arg_Internal => Internal,
12458 Arg_External => External,
12459 Arg_Parameter_Types => Parameter_Types,
12460 Arg_Mechanism => Mechanism);
12461 end Export_Procedure;
12467 -- pragma Export_Value (
12468 -- [Value =>] static_integer_EXPRESSION,
12469 -- [Link_Name =>] static_string_EXPRESSION);
12471 when Pragma_Export_Value =>
12473 Check_Arg_Order ((Name_Value, Name_Link_Name));
12474 Check_Arg_Count (2);
12476 Check_Optional_Identifier (Arg1, Name_Value);
12477 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
12479 Check_Optional_Identifier (Arg2, Name_Link_Name);
12480 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
12482 -----------------------------
12483 -- Export_Valued_Procedure --
12484 -----------------------------
12486 -- pragma Export_Valued_Procedure (
12487 -- [Internal =>] LOCAL_NAME
12488 -- [, [External =>] EXTERNAL_SYMBOL,]
12489 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12490 -- [, [Mechanism =>] MECHANISM]);
12492 -- EXTERNAL_SYMBOL ::=
12494 -- | static_string_EXPRESSION
12496 -- PARAMETER_TYPES ::=
12498 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12500 -- TYPE_DESIGNATOR ::=
12502 -- | subtype_Name ' Access
12506 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12508 -- MECHANISM_ASSOCIATION ::=
12509 -- [formal_parameter_NAME =>] MECHANISM_NAME
12511 -- MECHANISM_NAME ::=
12514 -- | Descriptor [([Class =>] CLASS_NAME)]
12516 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12518 when Pragma_Export_Valued_Procedure =>
12519 Export_Valued_Procedure : declare
12520 Args : Args_List (1 .. 4);
12521 Names : constant Name_List (1 .. 4) := (
12524 Name_Parameter_Types,
12527 Internal : Node_Id renames Args (1);
12528 External : Node_Id renames Args (2);
12529 Parameter_Types : Node_Id renames Args (3);
12530 Mechanism : Node_Id renames Args (4);
12534 Gather_Associations (Names, Args);
12535 Process_Extended_Import_Export_Subprogram_Pragma (
12536 Arg_Internal => Internal,
12537 Arg_External => External,
12538 Arg_Parameter_Types => Parameter_Types,
12539 Arg_Mechanism => Mechanism);
12540 end Export_Valued_Procedure;
12542 -------------------
12543 -- Extend_System --
12544 -------------------
12546 -- pragma Extend_System ([Name =>] Identifier);
12548 when Pragma_Extend_System => Extend_System : declare
12551 Check_Valid_Configuration_Pragma;
12552 Check_Arg_Count (1);
12553 Check_Optional_Identifier (Arg1, Name_Name);
12554 Check_Arg_Is_Identifier (Arg1);
12556 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12559 and then Name_Buffer (1 .. 4) = "aux_"
12561 if Present (System_Extend_Pragma_Arg) then
12562 if Chars (Get_Pragma_Arg (Arg1)) =
12563 Chars (Expression (System_Extend_Pragma_Arg))
12567 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
12568 Error_Pragma ("pragma% conflicts with that #");
12572 System_Extend_Pragma_Arg := Arg1;
12574 if not GNAT_Mode then
12575 System_Extend_Unit := Arg1;
12579 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
12583 ------------------------
12584 -- Extensions_Allowed --
12585 ------------------------
12587 -- pragma Extensions_Allowed (ON | OFF);
12589 when Pragma_Extensions_Allowed =>
12591 Check_Arg_Count (1);
12592 Check_No_Identifiers;
12593 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12595 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12596 Extensions_Allowed := True;
12597 Ada_Version := Ada_Version_Type'Last;
12600 Extensions_Allowed := False;
12601 Ada_Version := Ada_Version_Explicit;
12602 Ada_Version_Pragma := Empty;
12609 -- pragma External (
12610 -- [ Convention =>] convention_IDENTIFIER,
12611 -- [ Entity =>] local_NAME
12612 -- [, [External_Name =>] static_string_EXPRESSION ]
12613 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12615 when Pragma_External => External : declare
12616 Def_Id : Entity_Id;
12619 pragma Warnings (Off, C);
12626 Name_External_Name,
12628 Check_At_Least_N_Arguments (2);
12629 Check_At_Most_N_Arguments (4);
12630 Process_Convention (C, Def_Id);
12631 Note_Possible_Modification
12632 (Get_Pragma_Arg (Arg2), Sure => False);
12633 Process_Interface_Name (Def_Id, Arg3, Arg4);
12634 Set_Exported (Def_Id, Arg2);
12637 --------------------------
12638 -- External_Name_Casing --
12639 --------------------------
12641 -- pragma External_Name_Casing (
12642 -- UPPERCASE | LOWERCASE
12643 -- [, AS_IS | UPPERCASE | LOWERCASE]);
12645 when Pragma_External_Name_Casing => External_Name_Casing : declare
12648 Check_No_Identifiers;
12650 if Arg_Count = 2 then
12651 Check_Arg_Is_One_Of
12652 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
12654 case Chars (Get_Pragma_Arg (Arg2)) is
12656 Opt.External_Name_Exp_Casing := As_Is;
12658 when Name_Uppercase =>
12659 Opt.External_Name_Exp_Casing := Uppercase;
12661 when Name_Lowercase =>
12662 Opt.External_Name_Exp_Casing := Lowercase;
12669 Check_Arg_Count (1);
12672 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
12674 case Chars (Get_Pragma_Arg (Arg1)) is
12675 when Name_Uppercase =>
12676 Opt.External_Name_Imp_Casing := Uppercase;
12678 when Name_Lowercase =>
12679 Opt.External_Name_Imp_Casing := Lowercase;
12684 end External_Name_Casing;
12690 -- pragma Fast_Math;
12692 when Pragma_Fast_Math =>
12694 Check_No_Identifiers;
12695 Check_Valid_Configuration_Pragma;
12698 --------------------------
12699 -- Favor_Top_Level --
12700 --------------------------
12702 -- pragma Favor_Top_Level (type_NAME);
12704 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
12705 Named_Entity : Entity_Id;
12709 Check_No_Identifiers;
12710 Check_Arg_Count (1);
12711 Check_Arg_Is_Local_Name (Arg1);
12712 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
12714 -- If it's an access-to-subprogram type (in particular, not a
12715 -- subtype), set the flag on that type.
12717 if Is_Access_Subprogram_Type (Named_Entity) then
12718 Set_Can_Use_Internal_Rep (Named_Entity, False);
12720 -- Otherwise it's an error (name denotes the wrong sort of entity)
12724 ("access-to-subprogram type expected",
12725 Get_Pragma_Arg (Arg1));
12727 end Favor_Top_Level;
12729 ---------------------------
12730 -- Finalize_Storage_Only --
12731 ---------------------------
12733 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
12735 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
12736 Assoc : constant Node_Id := Arg1;
12737 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12742 Check_No_Identifiers;
12743 Check_Arg_Count (1);
12744 Check_Arg_Is_Local_Name (Arg1);
12746 Find_Type (Type_Id);
12747 Typ := Entity (Type_Id);
12750 or else Rep_Item_Too_Early (Typ, N)
12754 Typ := Underlying_Type (Typ);
12757 if not Is_Controlled (Typ) then
12758 Error_Pragma ("pragma% must specify controlled type");
12761 Check_First_Subtype (Arg1);
12763 if Finalize_Storage_Only (Typ) then
12764 Error_Pragma ("duplicate pragma%, only one allowed");
12766 elsif not Rep_Item_Too_Late (Typ, N) then
12767 Set_Finalize_Storage_Only (Base_Type (Typ), True);
12769 end Finalize_Storage;
12771 --------------------------
12772 -- Float_Representation --
12773 --------------------------
12775 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
12777 -- FLOAT_REP ::= VAX_Float | IEEE_Float
12779 when Pragma_Float_Representation => Float_Representation : declare
12787 if Arg_Count = 1 then
12788 Check_Valid_Configuration_Pragma;
12790 Check_Arg_Count (2);
12791 Check_Optional_Identifier (Arg2, Name_Entity);
12792 Check_Arg_Is_Local_Name (Arg2);
12795 Check_No_Identifier (Arg1);
12796 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
12798 if not OpenVMS_On_Target then
12799 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12801 ("??pragma% ignored (applies only to Open'V'M'S)");
12807 -- One argument case
12809 if Arg_Count = 1 then
12810 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12811 if Opt.Float_Format = 'I' then
12812 Error_Pragma ("'I'E'E'E format previously specified");
12815 Opt.Float_Format := 'V';
12818 if Opt.Float_Format = 'V' then
12819 Error_Pragma ("'V'A'X format previously specified");
12822 Opt.Float_Format := 'I';
12825 Set_Standard_Fpt_Formats;
12827 -- Two argument case
12830 Argx := Get_Pragma_Arg (Arg2);
12832 if not Is_Entity_Name (Argx)
12833 or else not Is_Floating_Point_Type (Entity (Argx))
12836 ("second argument of% pragma must be floating-point type",
12840 Ent := Entity (Argx);
12841 Digs := UI_To_Int (Digits_Value (Ent));
12843 -- Two arguments, VAX_Float case
12845 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
12847 when 6 => Set_F_Float (Ent);
12848 when 9 => Set_D_Float (Ent);
12849 when 15 => Set_G_Float (Ent);
12853 ("wrong digits value, must be 6,9 or 15", Arg2);
12856 -- Two arguments, IEEE_Float case
12860 when 6 => Set_IEEE_Short (Ent);
12861 when 15 => Set_IEEE_Long (Ent);
12865 ("wrong digits value, must be 6 or 15", Arg2);
12869 end Float_Representation;
12875 -- pragma Global (GLOBAL_SPECIFICATION);
12877 -- GLOBAL_SPECIFICATION ::=
12880 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
12882 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
12884 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
12885 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
12886 -- GLOBAL_ITEM ::= NAME
12888 when Pragma_Global => Global : declare
12889 Subp_Decl : Node_Id;
12894 Check_Arg_Count (1);
12896 -- Ensure the proper placement of the pragma. Global must be
12897 -- associated with a subprogram declaration or a body that acts
12901 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12903 if Nkind (Subp_Decl) /= N_Subprogram_Declaration
12904 and then (Nkind (Subp_Decl) /= N_Subprogram_Body
12905 or else not Acts_As_Spec (Subp_Decl))
12911 -- When the pragma appears on a subprogram body, perform the full
12914 if Nkind (Subp_Decl) = N_Subprogram_Body then
12915 Analyze_Global_In_Decl_Part (N);
12917 -- When Global applies to a subprogram compilation unit, the
12918 -- corresponding pragma is placed after the unit's declaration
12919 -- node and needs to be analyzed immediately.
12921 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
12922 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
12924 Analyze_Global_In_Decl_Part (N);
12927 -- Chain the pragma on the contract for further processing
12929 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12936 -- pragma Ident (static_string_EXPRESSION)
12938 -- Note: pragma Comment shares this processing. Pragma Comment is
12939 -- identical to Ident, except that the restriction of the argument to
12940 -- 31 characters and the placement restrictions are not enforced for
12943 when Pragma_Ident | Pragma_Comment => Ident : declare
12948 Check_Arg_Count (1);
12949 Check_No_Identifiers;
12950 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12953 -- For pragma Ident, preserve DEC compatibility by requiring the
12954 -- pragma to appear in a declarative part or package spec.
12956 if Prag_Id = Pragma_Ident then
12957 Check_Is_In_Decl_Part_Or_Package_Spec;
12960 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
12967 GP := Parent (Parent (N));
12969 if Nkind_In (GP, N_Package_Declaration,
12970 N_Generic_Package_Declaration)
12975 -- If we have a compilation unit, then record the ident value,
12976 -- checking for improper duplication.
12978 if Nkind (GP) = N_Compilation_Unit then
12979 CS := Ident_String (Current_Sem_Unit);
12981 if Present (CS) then
12983 -- For Ident, we do not permit multiple instances
12985 if Prag_Id = Pragma_Ident then
12986 Error_Pragma ("duplicate% pragma not permitted");
12988 -- For Comment, we concatenate the string, unless we want
12989 -- to preserve the tree structure for ASIS.
12991 elsif not ASIS_Mode then
12992 Start_String (Strval (CS));
12993 Store_String_Char (' ');
12994 Store_String_Chars (Strval (Str));
12995 Set_Strval (CS, End_String);
12999 -- In VMS, the effect of IDENT is achieved by passing
13000 -- --identification=name as a --for-linker switch.
13002 if OpenVMS_On_Target then
13005 ("--for-linker=--identification=");
13006 String_To_Name_Buffer (Strval (Str));
13007 Store_String_Chars (Name_Buffer (1 .. Name_Len));
13009 -- Only the last processed IDENT is saved. The main
13010 -- purpose is so an IDENT associated with a main
13011 -- procedure will be used in preference to an IDENT
13012 -- associated with a with'd package.
13014 Replace_Linker_Option_String
13015 (End_String, "--for-linker=--identification=");
13018 Set_Ident_String (Current_Sem_Unit, Str);
13021 -- For subunits, we just ignore the Ident, since in GNAT these
13022 -- are not separate object files, and hence not separate units
13023 -- in the unit table.
13025 elsif Nkind (GP) = N_Subunit then
13028 -- Otherwise we have a misplaced pragma Ident, but we ignore
13029 -- this if we are in an instantiation, since it comes from
13030 -- a generic, and has no relevance to the instantiation.
13032 elsif Prag_Id = Pragma_Ident then
13033 if Instantiation_Location (Loc) = No_Location then
13034 Error_Pragma ("pragma% only allowed at outer level");
13040 ----------------------------
13041 -- Implementation_Defined --
13042 ----------------------------
13044 -- pragma Implementation_Defined (local_NAME);
13046 -- Marks previously declared entity as implementation defined. For
13047 -- an overloaded entity, applies to the most recent homonym.
13049 -- pragma Implementation_Defined;
13051 -- The form with no arguments appears anywhere within a scope, most
13052 -- typically a package spec, and indicates that all entities that are
13053 -- defined within the package spec are Implementation_Defined.
13055 when Pragma_Implementation_Defined => Implementation_Defined : declare
13060 Check_No_Identifiers;
13062 -- Form with no arguments
13064 if Arg_Count = 0 then
13065 Set_Is_Implementation_Defined (Current_Scope);
13067 -- Form with one argument
13070 Check_Arg_Count (1);
13071 Check_Arg_Is_Local_Name (Arg1);
13072 Ent := Entity (Get_Pragma_Arg (Arg1));
13073 Set_Is_Implementation_Defined (Ent);
13075 end Implementation_Defined;
13081 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
13083 -- IMPLEMENTATION_KIND ::=
13084 -- By_Entry | By_Protected_Procedure | By_Any | Optional
13086 -- "By_Any" and "Optional" are treated as synonyms in order to
13087 -- support Ada 2012 aspect Synchronization.
13089 when Pragma_Implemented => Implemented : declare
13090 Proc_Id : Entity_Id;
13095 Check_Arg_Count (2);
13096 Check_No_Identifiers;
13097 Check_Arg_Is_Identifier (Arg1);
13098 Check_Arg_Is_Local_Name (Arg1);
13099 Check_Arg_Is_One_Of (Arg2,
13102 Name_By_Protected_Procedure,
13105 -- Extract the name of the local procedure
13107 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
13109 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
13110 -- primitive procedure of a synchronized tagged type.
13112 if Ekind (Proc_Id) = E_Procedure
13113 and then Is_Primitive (Proc_Id)
13114 and then Present (First_Formal (Proc_Id))
13116 Typ := Etype (First_Formal (Proc_Id));
13118 if Is_Tagged_Type (Typ)
13121 -- Check for a protected, a synchronized or a task interface
13123 ((Is_Interface (Typ)
13124 and then Is_Synchronized_Interface (Typ))
13126 -- Check for a protected type or a task type that implements
13130 (Is_Concurrent_Record_Type (Typ)
13131 and then Present (Interfaces (Typ)))
13133 -- Check for a private record extension with keyword
13137 (Ekind_In (Typ, E_Record_Type_With_Private,
13138 E_Record_Subtype_With_Private)
13139 and then Synchronized_Present (Parent (Typ))))
13144 ("controlling formal must be of synchronized tagged type",
13149 -- Procedures declared inside a protected type must be accepted
13151 elsif Ekind (Proc_Id) = E_Procedure
13152 and then Is_Protected_Type (Scope (Proc_Id))
13156 -- The first argument is not a primitive procedure
13160 ("pragma % must be applied to a primitive procedure", Arg1);
13164 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
13165 -- By_Protected_Procedure to the primitive procedure of a task
13168 if Chars (Arg2) = Name_By_Protected_Procedure
13169 and then Is_Interface (Typ)
13170 and then Is_Task_Interface (Typ)
13173 ("implementation kind By_Protected_Procedure cannot be "
13174 & "applied to a task interface primitive", Arg2);
13178 Record_Rep_Item (Proc_Id, N);
13181 ----------------------
13182 -- Implicit_Packing --
13183 ----------------------
13185 -- pragma Implicit_Packing;
13187 when Pragma_Implicit_Packing =>
13189 Check_Arg_Count (0);
13190 Implicit_Packing := True;
13197 -- [Convention =>] convention_IDENTIFIER,
13198 -- [Entity =>] local_NAME
13199 -- [, [External_Name =>] static_string_EXPRESSION ]
13200 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13202 when Pragma_Import =>
13203 Check_Ada_83_Warning;
13207 Name_External_Name,
13210 Check_At_Least_N_Arguments (2);
13211 Check_At_Most_N_Arguments (4);
13212 Process_Import_Or_Interface;
13214 ----------------------
13215 -- Import_Exception --
13216 ----------------------
13218 -- pragma Import_Exception (
13219 -- [Internal =>] LOCAL_NAME
13220 -- [, [External =>] EXTERNAL_SYMBOL]
13221 -- [, [Form =>] Ada | VMS]
13222 -- [, [Code =>] static_integer_EXPRESSION]);
13224 when Pragma_Import_Exception => Import_Exception : declare
13225 Args : Args_List (1 .. 4);
13226 Names : constant Name_List (1 .. 4) := (
13232 Internal : Node_Id renames Args (1);
13233 External : Node_Id renames Args (2);
13234 Form : Node_Id renames Args (3);
13235 Code : Node_Id renames Args (4);
13239 Gather_Associations (Names, Args);
13241 if Present (External) and then Present (Code) then
13243 ("cannot give both External and Code options for pragma%");
13246 Process_Extended_Import_Export_Exception_Pragma (
13247 Arg_Internal => Internal,
13248 Arg_External => External,
13252 if not Is_VMS_Exception (Entity (Internal)) then
13253 Set_Imported (Entity (Internal));
13255 end Import_Exception;
13257 ---------------------
13258 -- Import_Function --
13259 ---------------------
13261 -- pragma Import_Function (
13262 -- [Internal =>] LOCAL_NAME,
13263 -- [, [External =>] EXTERNAL_SYMBOL]
13264 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13265 -- [, [Result_Type =>] SUBTYPE_MARK]
13266 -- [, [Mechanism =>] MECHANISM]
13267 -- [, [Result_Mechanism =>] MECHANISM_NAME]
13268 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13270 -- EXTERNAL_SYMBOL ::=
13272 -- | static_string_EXPRESSION
13274 -- PARAMETER_TYPES ::=
13276 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13278 -- TYPE_DESIGNATOR ::=
13280 -- | subtype_Name ' Access
13284 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13286 -- MECHANISM_ASSOCIATION ::=
13287 -- [formal_parameter_NAME =>] MECHANISM_NAME
13289 -- MECHANISM_NAME ::=
13292 -- | Descriptor [([Class =>] CLASS_NAME)]
13294 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13296 when Pragma_Import_Function => Import_Function : declare
13297 Args : Args_List (1 .. 7);
13298 Names : constant Name_List (1 .. 7) := (
13301 Name_Parameter_Types,
13304 Name_Result_Mechanism,
13305 Name_First_Optional_Parameter);
13307 Internal : Node_Id renames Args (1);
13308 External : Node_Id renames Args (2);
13309 Parameter_Types : Node_Id renames Args (3);
13310 Result_Type : Node_Id renames Args (4);
13311 Mechanism : Node_Id renames Args (5);
13312 Result_Mechanism : Node_Id renames Args (6);
13313 First_Optional_Parameter : Node_Id renames Args (7);
13317 Gather_Associations (Names, Args);
13318 Process_Extended_Import_Export_Subprogram_Pragma (
13319 Arg_Internal => Internal,
13320 Arg_External => External,
13321 Arg_Parameter_Types => Parameter_Types,
13322 Arg_Result_Type => Result_Type,
13323 Arg_Mechanism => Mechanism,
13324 Arg_Result_Mechanism => Result_Mechanism,
13325 Arg_First_Optional_Parameter => First_Optional_Parameter);
13326 end Import_Function;
13328 -------------------
13329 -- Import_Object --
13330 -------------------
13332 -- pragma Import_Object (
13333 -- [Internal =>] LOCAL_NAME
13334 -- [, [External =>] EXTERNAL_SYMBOL]
13335 -- [, [Size =>] EXTERNAL_SYMBOL]);
13337 -- EXTERNAL_SYMBOL ::=
13339 -- | static_string_EXPRESSION
13341 when Pragma_Import_Object => Import_Object : declare
13342 Args : Args_List (1 .. 3);
13343 Names : constant Name_List (1 .. 3) := (
13348 Internal : Node_Id renames Args (1);
13349 External : Node_Id renames Args (2);
13350 Size : Node_Id renames Args (3);
13354 Gather_Associations (Names, Args);
13355 Process_Extended_Import_Export_Object_Pragma (
13356 Arg_Internal => Internal,
13357 Arg_External => External,
13361 ----------------------
13362 -- Import_Procedure --
13363 ----------------------
13365 -- pragma Import_Procedure (
13366 -- [Internal =>] LOCAL_NAME
13367 -- [, [External =>] EXTERNAL_SYMBOL]
13368 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13369 -- [, [Mechanism =>] MECHANISM]
13370 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13372 -- EXTERNAL_SYMBOL ::=
13374 -- | static_string_EXPRESSION
13376 -- PARAMETER_TYPES ::=
13378 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13380 -- TYPE_DESIGNATOR ::=
13382 -- | subtype_Name ' Access
13386 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13388 -- MECHANISM_ASSOCIATION ::=
13389 -- [formal_parameter_NAME =>] MECHANISM_NAME
13391 -- MECHANISM_NAME ::=
13394 -- | Descriptor [([Class =>] CLASS_NAME)]
13396 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13398 when Pragma_Import_Procedure => Import_Procedure : declare
13399 Args : Args_List (1 .. 5);
13400 Names : constant Name_List (1 .. 5) := (
13403 Name_Parameter_Types,
13405 Name_First_Optional_Parameter);
13407 Internal : Node_Id renames Args (1);
13408 External : Node_Id renames Args (2);
13409 Parameter_Types : Node_Id renames Args (3);
13410 Mechanism : Node_Id renames Args (4);
13411 First_Optional_Parameter : Node_Id renames Args (5);
13415 Gather_Associations (Names, Args);
13416 Process_Extended_Import_Export_Subprogram_Pragma (
13417 Arg_Internal => Internal,
13418 Arg_External => External,
13419 Arg_Parameter_Types => Parameter_Types,
13420 Arg_Mechanism => Mechanism,
13421 Arg_First_Optional_Parameter => First_Optional_Parameter);
13422 end Import_Procedure;
13424 -----------------------------
13425 -- Import_Valued_Procedure --
13426 -----------------------------
13428 -- pragma Import_Valued_Procedure (
13429 -- [Internal =>] LOCAL_NAME
13430 -- [, [External =>] EXTERNAL_SYMBOL]
13431 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13432 -- [, [Mechanism =>] MECHANISM]
13433 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
13435 -- EXTERNAL_SYMBOL ::=
13437 -- | static_string_EXPRESSION
13439 -- PARAMETER_TYPES ::=
13441 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13443 -- TYPE_DESIGNATOR ::=
13445 -- | subtype_Name ' Access
13449 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13451 -- MECHANISM_ASSOCIATION ::=
13452 -- [formal_parameter_NAME =>] MECHANISM_NAME
13454 -- MECHANISM_NAME ::=
13457 -- | Descriptor [([Class =>] CLASS_NAME)]
13459 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13461 when Pragma_Import_Valued_Procedure =>
13462 Import_Valued_Procedure : declare
13463 Args : Args_List (1 .. 5);
13464 Names : constant Name_List (1 .. 5) := (
13467 Name_Parameter_Types,
13469 Name_First_Optional_Parameter);
13471 Internal : Node_Id renames Args (1);
13472 External : Node_Id renames Args (2);
13473 Parameter_Types : Node_Id renames Args (3);
13474 Mechanism : Node_Id renames Args (4);
13475 First_Optional_Parameter : Node_Id renames Args (5);
13479 Gather_Associations (Names, Args);
13480 Process_Extended_Import_Export_Subprogram_Pragma (
13481 Arg_Internal => Internal,
13482 Arg_External => External,
13483 Arg_Parameter_Types => Parameter_Types,
13484 Arg_Mechanism => Mechanism,
13485 Arg_First_Optional_Parameter => First_Optional_Parameter);
13486 end Import_Valued_Procedure;
13492 -- pragma Independent (LOCAL_NAME);
13494 when Pragma_Independent => Independent : declare
13501 Check_Ada_83_Warning;
13503 Check_No_Identifiers;
13504 Check_Arg_Count (1);
13505 Check_Arg_Is_Local_Name (Arg1);
13506 E_Id := Get_Pragma_Arg (Arg1);
13508 if Etype (E_Id) = Any_Type then
13512 E := Entity (E_Id);
13513 D := Declaration_Node (E);
13516 -- Check duplicate before we chain ourselves!
13518 Check_Duplicate_Pragma (E);
13520 -- Check appropriate entity
13522 if Is_Type (E) then
13523 if Rep_Item_Too_Early (E, N)
13525 Rep_Item_Too_Late (E, N)
13529 Check_First_Subtype (Arg1);
13532 elsif K = N_Object_Declaration
13533 or else (K = N_Component_Declaration
13534 and then Original_Record_Component (E) = E)
13536 if Rep_Item_Too_Late (E, N) then
13542 ("inappropriate entity for pragma%", Arg1);
13545 Independence_Checks.Append ((N, E));
13548 ----------------------------
13549 -- Independent_Components --
13550 ----------------------------
13552 -- pragma Atomic_Components (array_LOCAL_NAME);
13554 -- This processing is shared by Volatile_Components
13556 when Pragma_Independent_Components => Independent_Components : declare
13563 Check_Ada_83_Warning;
13565 Check_No_Identifiers;
13566 Check_Arg_Count (1);
13567 Check_Arg_Is_Local_Name (Arg1);
13568 E_Id := Get_Pragma_Arg (Arg1);
13570 if Etype (E_Id) = Any_Type then
13574 E := Entity (E_Id);
13576 -- Check duplicate before we chain ourselves!
13578 Check_Duplicate_Pragma (E);
13580 -- Check appropriate entity
13582 if Rep_Item_Too_Early (E, N)
13584 Rep_Item_Too_Late (E, N)
13589 D := Declaration_Node (E);
13592 if K = N_Full_Type_Declaration
13593 and then (Is_Array_Type (E) or else Is_Record_Type (E))
13595 Independence_Checks.Append ((N, E));
13596 Set_Has_Independent_Components (Base_Type (E));
13598 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13599 and then Nkind (D) = N_Object_Declaration
13600 and then Nkind (Object_Definition (D)) =
13601 N_Constrained_Array_Definition
13603 Independence_Checks.Append ((N, E));
13604 Set_Has_Independent_Components (E);
13607 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13609 end Independent_Components;
13611 -----------------------
13612 -- Initial_Condition --
13613 -----------------------
13615 -- pragma Initial_Condition (boolean_EXPRESSION);
13617 when Pragma_Initial_Condition => Initial_Condition : declare
13618 Context : constant Node_Id := Parent (Parent (N));
13619 Pack_Id : Entity_Id;
13625 Check_Arg_Count (1);
13627 -- Ensure the proper placement of the pragma. Initial_Condition
13628 -- must be associated with a package declaration.
13630 if not Nkind_In (Context, N_Generic_Package_Declaration,
13631 N_Package_Declaration)
13638 while Present (Stmt) loop
13640 -- Skip prior pragmas, but check for duplicates
13642 if Nkind (Stmt) = N_Pragma then
13643 if Pragma_Name (Stmt) = Pname then
13644 Error_Msg_Name_1 := Pname;
13645 Error_Msg_Sloc := Sloc (Stmt);
13646 Error_Msg_N ("pragma % duplicates pragma declared #", N);
13649 -- Skip internally generated code
13651 elsif not Comes_From_Source (Stmt) then
13654 -- The pragma does not apply to a legal construct, issue an
13655 -- error and stop the analysis.
13662 Stmt := Prev (Stmt);
13665 -- The pragma must be analyzed at the end of the visible
13666 -- declarations of the related package. Save the pragma for later
13667 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
13668 -- the contract of the package.
13670 Pack_Id := Defining_Entity (Context);
13671 Add_Contract_Item (N, Pack_Id);
13673 -- Verify the declaration order of pragma Initial_Condition with
13674 -- respect to pragmas Abstract_State and Initializes.
13676 Check_Declaration_Order
13677 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
13680 Check_Declaration_Order
13681 (First => Get_Pragma (Pack_Id, Pragma_Initializes),
13683 end Initial_Condition;
13685 ------------------------
13686 -- Initialize_Scalars --
13687 ------------------------
13689 -- pragma Initialize_Scalars;
13691 when Pragma_Initialize_Scalars =>
13693 Check_Arg_Count (0);
13694 Check_Valid_Configuration_Pragma;
13695 Check_Restriction (No_Initialize_Scalars, N);
13697 -- Initialize_Scalars creates false positives in CodePeer, and
13698 -- incorrect negative results in SPARK mode, so ignore this pragma
13701 if not Restriction_Active (No_Initialize_Scalars)
13702 and then not (CodePeer_Mode or SPARK_Mode)
13704 Init_Or_Norm_Scalars := True;
13705 Initialize_Scalars := True;
13712 -- pragma Initializes (INITIALIZATION_SPEC);
13714 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
13716 -- INITIALIZATION_LIST ::=
13717 -- INITIALIZATION_ITEM
13718 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
13720 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
13725 -- | (INPUT {, INPUT})
13729 when Pragma_Initializes => Initializes : declare
13730 Context : constant Node_Id := Parent (Parent (N));
13731 Pack_Id : Entity_Id;
13737 Check_Arg_Count (1);
13739 -- Ensure the proper placement of the pragma. Initializes must be
13740 -- associated with a package declaration.
13742 if not Nkind_In (Context, N_Generic_Package_Declaration,
13743 N_Package_Declaration)
13750 while Present (Stmt) loop
13752 -- Skip prior pragmas, but check for duplicates
13754 if Nkind (Stmt) = N_Pragma then
13755 if Pragma_Name (Stmt) = Pname then
13756 Error_Msg_Name_1 := Pname;
13757 Error_Msg_Sloc := Sloc (Stmt);
13758 Error_Msg_N ("pragma % duplicates pragma declared #", N);
13761 -- Skip internally generated code
13763 elsif not Comes_From_Source (Stmt) then
13766 -- The pragma does not apply to a legal construct, issue an
13767 -- error and stop the analysis.
13774 Stmt := Prev (Stmt);
13777 -- The pragma must be analyzed at the end of the visible
13778 -- declarations of the related package. Save the pragma for later
13779 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
13780 -- contract of the package.
13782 Pack_Id := Defining_Entity (Context);
13783 Add_Contract_Item (N, Pack_Id);
13785 -- Verify the declaration order of pragmas Abstract_State and
13788 Check_Declaration_Order
13789 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
13797 -- pragma Inline ( NAME {, NAME} );
13799 when Pragma_Inline =>
13801 -- Inline status is Enabled if inlining option is active
13803 if Inline_Active then
13804 Process_Inline (Enabled);
13806 Process_Inline (Disabled);
13809 -------------------
13810 -- Inline_Always --
13811 -------------------
13813 -- pragma Inline_Always ( NAME {, NAME} );
13815 when Pragma_Inline_Always =>
13818 -- Pragma always active unless in CodePeer or SPARK mode, since
13819 -- this causes walk order issues.
13821 if not (CodePeer_Mode or SPARK_Mode) then
13822 Process_Inline (Enabled);
13825 --------------------
13826 -- Inline_Generic --
13827 --------------------
13829 -- pragma Inline_Generic (NAME {, NAME});
13831 when Pragma_Inline_Generic =>
13833 Process_Generic_List;
13835 ----------------------
13836 -- Inspection_Point --
13837 ----------------------
13839 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
13841 when Pragma_Inspection_Point => Inspection_Point : declare
13846 if Arg_Count > 0 then
13849 Exp := Get_Pragma_Arg (Arg);
13852 if not Is_Entity_Name (Exp)
13853 or else not Is_Object (Entity (Exp))
13855 Error_Pragma_Arg ("object name required", Arg);
13859 exit when No (Arg);
13862 end Inspection_Point;
13868 -- pragma Interface (
13869 -- [ Convention =>] convention_IDENTIFIER,
13870 -- [ Entity =>] local_NAME
13871 -- [, [External_Name =>] static_string_EXPRESSION ]
13872 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13874 when Pragma_Interface =>
13879 Name_External_Name,
13881 Check_At_Least_N_Arguments (2);
13882 Check_At_Most_N_Arguments (4);
13883 Process_Import_Or_Interface;
13885 -- In Ada 2005, the permission to use Interface (a reserved word)
13886 -- as a pragma name is considered an obsolescent feature, and this
13887 -- pragma was already obsolescent in Ada 95.
13889 if Ada_Version >= Ada_95 then
13891 (No_Obsolescent_Features, Pragma_Identifier (N));
13893 if Warn_On_Obsolescent_Feature then
13895 ("pragma Interface is an obsolescent feature?j?", N);
13897 ("|use pragma Import instead?j?", N);
13901 --------------------
13902 -- Interface_Name --
13903 --------------------
13905 -- pragma Interface_Name (
13906 -- [ Entity =>] local_NAME
13907 -- [,[External_Name =>] static_string_EXPRESSION ]
13908 -- [,[Link_Name =>] static_string_EXPRESSION ]);
13910 when Pragma_Interface_Name => Interface_Name : declare
13912 Def_Id : Entity_Id;
13913 Hom_Id : Entity_Id;
13919 ((Name_Entity, Name_External_Name, Name_Link_Name));
13920 Check_At_Least_N_Arguments (2);
13921 Check_At_Most_N_Arguments (3);
13922 Id := Get_Pragma_Arg (Arg1);
13925 -- This is obsolete from Ada 95 on, but it is an implementation
13926 -- defined pragma, so we do not consider that it violates the
13927 -- restriction (No_Obsolescent_Features).
13929 if Ada_Version >= Ada_95 then
13930 if Warn_On_Obsolescent_Feature then
13932 ("pragma Interface_Name is an obsolescent feature?j?", N);
13934 ("|use pragma Import instead?j?", N);
13938 if not Is_Entity_Name (Id) then
13940 ("first argument for pragma% must be entity name", Arg1);
13941 elsif Etype (Id) = Any_Type then
13944 Def_Id := Entity (Id);
13947 -- Special DEC-compatible processing for the object case, forces
13948 -- object to be imported.
13950 if Ekind (Def_Id) = E_Variable then
13951 Kill_Size_Check_Code (Def_Id);
13952 Note_Possible_Modification (Id, Sure => False);
13954 -- Initialization is not allowed for imported variable
13956 if Present (Expression (Parent (Def_Id)))
13957 and then Comes_From_Source (Expression (Parent (Def_Id)))
13959 Error_Msg_Sloc := Sloc (Def_Id);
13961 ("no initialization allowed for declaration of& #",
13965 -- For compatibility, support VADS usage of providing both
13966 -- pragmas Interface and Interface_Name to obtain the effect
13967 -- of a single Import pragma.
13969 if Is_Imported (Def_Id)
13970 and then Present (First_Rep_Item (Def_Id))
13971 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
13973 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
13977 Set_Imported (Def_Id);
13980 Set_Is_Public (Def_Id);
13981 Process_Interface_Name (Def_Id, Arg2, Arg3);
13984 -- Otherwise must be subprogram
13986 elsif not Is_Subprogram (Def_Id) then
13988 ("argument of pragma% is not subprogram", Arg1);
13991 Check_At_Most_N_Arguments (3);
13995 -- Loop through homonyms
13998 Def_Id := Get_Base_Subprogram (Hom_Id);
14000 if Is_Imported (Def_Id) then
14001 Process_Interface_Name (Def_Id, Arg2, Arg3);
14005 exit when From_Aspect_Specification (N);
14006 Hom_Id := Homonym (Hom_Id);
14008 exit when No (Hom_Id)
14009 or else Scope (Hom_Id) /= Current_Scope;
14014 ("argument of pragma% is not imported subprogram",
14018 end Interface_Name;
14020 -----------------------
14021 -- Interrupt_Handler --
14022 -----------------------
14024 -- pragma Interrupt_Handler (handler_NAME);
14026 when Pragma_Interrupt_Handler =>
14027 Check_Ada_83_Warning;
14028 Check_Arg_Count (1);
14029 Check_No_Identifiers;
14031 if No_Run_Time_Mode then
14032 Error_Msg_CRT ("Interrupt_Handler pragma", N);
14034 Check_Interrupt_Or_Attach_Handler;
14035 Process_Interrupt_Or_Attach_Handler;
14038 ------------------------
14039 -- Interrupt_Priority --
14040 ------------------------
14042 -- pragma Interrupt_Priority [(EXPRESSION)];
14044 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
14045 P : constant Node_Id := Parent (N);
14050 Check_Ada_83_Warning;
14052 if Arg_Count /= 0 then
14053 Arg := Get_Pragma_Arg (Arg1);
14054 Check_Arg_Count (1);
14055 Check_No_Identifiers;
14057 -- The expression must be analyzed in the special manner
14058 -- described in "Handling of Default and Per-Object
14059 -- Expressions" in sem.ads.
14061 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
14064 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
14069 Ent := Defining_Identifier (Parent (P));
14071 -- Check duplicate pragma before we chain the pragma in the Rep
14072 -- Item chain of Ent.
14074 Check_Duplicate_Pragma (Ent);
14075 Record_Rep_Item (Ent, N);
14077 end Interrupt_Priority;
14079 ---------------------
14080 -- Interrupt_State --
14081 ---------------------
14083 -- pragma Interrupt_State (
14084 -- [Name =>] INTERRUPT_ID,
14085 -- [State =>] INTERRUPT_STATE);
14087 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
14088 -- INTERRUPT_STATE => System | Runtime | User
14090 -- Note: if the interrupt id is given as an identifier, then it must
14091 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
14092 -- given as a static integer expression which must be in the range of
14093 -- Ada.Interrupts.Interrupt_ID.
14095 when Pragma_Interrupt_State => Interrupt_State : declare
14097 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
14098 -- This is the entity Ada.Interrupts.Interrupt_ID;
14100 State_Type : Character;
14101 -- Set to 's'/'r'/'u' for System/Runtime/User
14104 -- Index to entry in Interrupt_States table
14107 -- Value of interrupt
14109 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
14110 -- The first argument to the pragma
14112 Int_Ent : Entity_Id;
14113 -- Interrupt entity in Ada.Interrupts.Names
14117 Check_Arg_Order ((Name_Name, Name_State));
14118 Check_Arg_Count (2);
14120 Check_Optional_Identifier (Arg1, Name_Name);
14121 Check_Optional_Identifier (Arg2, Name_State);
14122 Check_Arg_Is_Identifier (Arg2);
14124 -- First argument is identifier
14126 if Nkind (Arg1X) = N_Identifier then
14128 -- Search list of names in Ada.Interrupts.Names
14130 Int_Ent := First_Entity (RTE (RE_Names));
14132 if No (Int_Ent) then
14133 Error_Pragma_Arg ("invalid interrupt name", Arg1);
14135 elsif Chars (Int_Ent) = Chars (Arg1X) then
14136 Int_Val := Expr_Value (Constant_Value (Int_Ent));
14140 Next_Entity (Int_Ent);
14143 -- First argument is not an identifier, so it must be a static
14144 -- expression of type Ada.Interrupts.Interrupt_ID.
14147 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
14148 Int_Val := Expr_Value (Arg1X);
14150 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
14152 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
14155 ("value not in range of type "
14156 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
14162 case Chars (Get_Pragma_Arg (Arg2)) is
14163 when Name_Runtime => State_Type := 'r';
14164 when Name_System => State_Type := 's';
14165 when Name_User => State_Type := 'u';
14168 Error_Pragma_Arg ("invalid interrupt state", Arg2);
14171 -- Check if entry is already stored
14173 IST_Num := Interrupt_States.First;
14175 -- If entry not found, add it
14177 if IST_Num > Interrupt_States.Last then
14178 Interrupt_States.Append
14179 ((Interrupt_Number => UI_To_Int (Int_Val),
14180 Interrupt_State => State_Type,
14181 Pragma_Loc => Loc));
14184 -- Case of entry for the same entry
14186 elsif Int_Val = Interrupt_States.Table (IST_Num).
14189 -- If state matches, done, no need to make redundant entry
14192 State_Type = Interrupt_States.Table (IST_Num).
14195 -- Otherwise if state does not match, error
14198 Interrupt_States.Table (IST_Num).Pragma_Loc;
14200 ("state conflicts with that given #", Arg2);
14204 IST_Num := IST_Num + 1;
14206 end Interrupt_State;
14212 -- pragma Invariant
14213 -- ([Entity =>] type_LOCAL_NAME,
14214 -- [Check =>] EXPRESSION
14215 -- [,[Message =>] String_Expression]);
14217 when Pragma_Invariant => Invariant : declare
14223 pragma Unreferenced (Discard);
14227 Check_At_Least_N_Arguments (2);
14228 Check_At_Most_N_Arguments (3);
14229 Check_Optional_Identifier (Arg1, Name_Entity);
14230 Check_Optional_Identifier (Arg2, Name_Check);
14232 if Arg_Count = 3 then
14233 Check_Optional_Identifier (Arg3, Name_Message);
14234 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
14237 Check_Arg_Is_Local_Name (Arg1);
14239 Type_Id := Get_Pragma_Arg (Arg1);
14240 Find_Type (Type_Id);
14241 Typ := Entity (Type_Id);
14243 if Typ = Any_Type then
14246 -- An invariant must apply to a private type, or appear in the
14247 -- private part of a package spec and apply to a completion.
14249 elsif Ekind_In (Typ, E_Private_Type,
14250 E_Record_Type_With_Private,
14251 E_Limited_Private_Type)
14255 elsif In_Private_Part (Current_Scope)
14256 and then Has_Private_Declaration (Typ)
14260 elsif In_Private_Part (Current_Scope) then
14262 ("pragma% only allowed for private type declared in "
14263 & "visible part", Arg1);
14267 ("pragma% only allowed for private type", Arg1);
14270 -- Note that the type has at least one invariant, and also that
14271 -- it has inheritable invariants if we have Invariant'Class
14272 -- or Type_Invariant'Class. Build the corresponding invariant
14273 -- procedure declaration, so that calls to it can be generated
14274 -- before the body is built (e.g. within an expression function).
14276 PDecl := Build_Invariant_Procedure_Declaration (Typ);
14278 Insert_After (N, PDecl);
14281 if Class_Present (N) then
14282 Set_Has_Inheritable_Invariants (Typ);
14285 -- The remaining processing is simply to link the pragma on to
14286 -- the rep item chain, for processing when the type is frozen.
14287 -- This is accomplished by a call to Rep_Item_Too_Late.
14289 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
14292 ----------------------
14293 -- Java_Constructor --
14294 ----------------------
14296 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
14298 -- Also handles pragma CIL_Constructor
14300 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
14301 Java_Constructor : declare
14302 Convention : Convention_Id;
14303 Def_Id : Entity_Id;
14304 Hom_Id : Entity_Id;
14306 This_Formal : Entity_Id;
14310 Check_Arg_Count (1);
14311 Check_Optional_Identifier (Arg1, Name_Entity);
14312 Check_Arg_Is_Local_Name (Arg1);
14314 Id := Get_Pragma_Arg (Arg1);
14315 Find_Program_Unit_Name (Id);
14317 -- If we did not find the name, we are done
14319 if Etype (Id) = Any_Type then
14323 -- Check wrong use of pragma in wrong VM target
14325 if VM_Target = No_VM then
14328 elsif VM_Target = CLI_Target
14329 and then Prag_Id = Pragma_Java_Constructor
14331 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
14333 elsif VM_Target = JVM_Target
14334 and then Prag_Id = Pragma_CIL_Constructor
14336 Error_Pragma ("must use pragma 'Java_'Constructor");
14340 when Pragma_CIL_Constructor => Convention := Convention_CIL;
14341 when Pragma_Java_Constructor => Convention := Convention_Java;
14342 when others => null;
14345 Hom_Id := Entity (Id);
14347 -- Loop through homonyms
14350 Def_Id := Get_Base_Subprogram (Hom_Id);
14352 -- The constructor is required to be a function
14354 if Ekind (Def_Id) /= E_Function then
14355 if VM_Target = JVM_Target then
14357 ("pragma% requires function returning a 'Java access "
14361 ("pragma% requires function returning a 'C'I'L access "
14366 -- Check arguments: For tagged type the first formal must be
14367 -- named "this" and its type must be a named access type
14368 -- designating a class-wide tagged type that has convention
14369 -- CIL/Java. The first formal must also have a null default
14370 -- value. For example:
14372 -- type Typ is tagged ...
14373 -- type Ref is access all Typ;
14374 -- pragma Convention (CIL, Typ);
14376 -- function New_Typ (This : Ref) return Ref;
14377 -- function New_Typ (This : Ref; I : Integer) return Ref;
14378 -- pragma Cil_Constructor (New_Typ);
14380 -- Reason: The first formal must NOT be a primitive of the
14383 -- This rule also applies to constructors of delegates used
14384 -- to interface with standard target libraries. For example:
14386 -- type Delegate is access procedure ...
14387 -- pragma Import (CIL, Delegate, ...);
14389 -- function new_Delegate
14390 -- (This : Delegate := null; ... ) return Delegate;
14392 -- For value-types this rule does not apply.
14394 if not Is_Value_Type (Etype (Def_Id)) then
14395 if No (First_Formal (Def_Id)) then
14396 Error_Msg_Name_1 := Pname;
14397 Error_Msg_N ("% function must have parameters", Def_Id);
14401 -- In the JRE library we have several occurrences in which
14402 -- the "this" parameter is not the first formal.
14404 This_Formal := First_Formal (Def_Id);
14406 -- In the JRE library we have several occurrences in which
14407 -- the "this" parameter is not the first formal. Search for
14410 if VM_Target = JVM_Target then
14411 while Present (This_Formal)
14412 and then Get_Name_String (Chars (This_Formal)) /= "this"
14414 Next_Formal (This_Formal);
14417 if No (This_Formal) then
14418 This_Formal := First_Formal (Def_Id);
14422 -- Warning: The first parameter should be named "this".
14423 -- We temporarily allow it because we have the following
14424 -- case in the Java runtime (file s-osinte.ads) ???
14426 -- function new_Thread
14427 -- (Self_Id : System.Address) return Thread_Id;
14428 -- pragma Java_Constructor (new_Thread);
14430 if VM_Target = JVM_Target
14431 and then Get_Name_String (Chars (First_Formal (Def_Id)))
14433 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
14437 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
14438 Error_Msg_Name_1 := Pname;
14440 ("first formal of % function must be named `this`",
14441 Parent (This_Formal));
14443 elsif not Is_Access_Type (Etype (This_Formal)) then
14444 Error_Msg_Name_1 := Pname;
14446 ("first formal of % function must be an access type",
14447 Parameter_Type (Parent (This_Formal)));
14449 -- For delegates the type of the first formal must be a
14450 -- named access-to-subprogram type (see previous example)
14452 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
14453 and then Ekind (Etype (This_Formal))
14454 /= E_Access_Subprogram_Type
14456 Error_Msg_Name_1 := Pname;
14458 ("first formal of % function must be a named access "
14459 & "to subprogram type",
14460 Parameter_Type (Parent (This_Formal)));
14462 -- Warning: We should reject anonymous access types because
14463 -- the constructor must not be handled as a primitive of the
14464 -- tagged type. We temporarily allow it because this profile
14465 -- is currently generated by cil2ada???
14467 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
14468 and then not Ekind_In (Etype (This_Formal),
14470 E_General_Access_Type,
14471 E_Anonymous_Access_Type)
14473 Error_Msg_Name_1 := Pname;
14475 ("first formal of % function must be a named access "
14476 & "type", Parameter_Type (Parent (This_Formal)));
14478 elsif Atree.Convention
14479 (Designated_Type (Etype (This_Formal))) /= Convention
14481 Error_Msg_Name_1 := Pname;
14483 if Convention = Convention_Java then
14485 ("pragma% requires convention 'Cil in designated "
14486 & "type", Parameter_Type (Parent (This_Formal)));
14489 ("pragma% requires convention 'Java in designated "
14490 & "type", Parameter_Type (Parent (This_Formal)));
14493 elsif No (Expression (Parent (This_Formal)))
14494 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
14496 Error_Msg_Name_1 := Pname;
14498 ("pragma% requires first formal with default `null`",
14499 Parameter_Type (Parent (This_Formal)));
14503 -- Check result type: the constructor must be a function
14505 -- * a value type (only allowed in the CIL compiler)
14506 -- * an access-to-subprogram type with convention Java/CIL
14507 -- * an access-type designating a type that has convention
14510 if Is_Value_Type (Etype (Def_Id)) then
14513 -- Access-to-subprogram type with convention Java/CIL
14515 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
14516 if Atree.Convention (Etype (Def_Id)) /= Convention then
14517 if Convention = Convention_Java then
14519 ("pragma% requires function returning a 'Java "
14520 & "access type", Arg1);
14522 pragma Assert (Convention = Convention_CIL);
14524 ("pragma% requires function returning a 'C'I'L "
14525 & "access type", Arg1);
14529 elsif Ekind (Etype (Def_Id)) in Access_Kind then
14530 if not Ekind_In (Etype (Def_Id), E_Access_Type,
14531 E_General_Access_Type)
14534 (Designated_Type (Etype (Def_Id))) /= Convention
14536 Error_Msg_Name_1 := Pname;
14538 if Convention = Convention_Java then
14540 ("pragma% requires function returning a named "
14541 & "'Java access type", Arg1);
14544 ("pragma% requires function returning a named "
14545 & "'C'I'L access type", Arg1);
14550 Set_Is_Constructor (Def_Id);
14551 Set_Convention (Def_Id, Convention);
14552 Set_Is_Imported (Def_Id);
14554 exit when From_Aspect_Specification (N);
14555 Hom_Id := Homonym (Hom_Id);
14557 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
14559 end Java_Constructor;
14561 ----------------------
14562 -- Java_Interface --
14563 ----------------------
14565 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
14567 when Pragma_Java_Interface => Java_Interface : declare
14573 Check_Arg_Count (1);
14574 Check_Optional_Identifier (Arg1, Name_Entity);
14575 Check_Arg_Is_Local_Name (Arg1);
14577 Arg := Get_Pragma_Arg (Arg1);
14580 if Etype (Arg) = Any_Type then
14584 if not Is_Entity_Name (Arg)
14585 or else not Is_Type (Entity (Arg))
14587 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
14590 Typ := Underlying_Type (Entity (Arg));
14592 -- For now simply check some of the semantic constraints on the
14593 -- type. This currently leaves out some restrictions on interface
14594 -- types, namely that the parent type must be java.lang.Object.Typ
14595 -- and that all primitives of the type should be declared
14598 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
14600 ("pragma% requires an abstract tagged type", Arg1);
14602 elsif not Has_Discriminants (Typ)
14603 or else Ekind (Etype (First_Discriminant (Typ)))
14604 /= E_Anonymous_Access_Type
14606 not Is_Class_Wide_Type
14607 (Designated_Type (Etype (First_Discriminant (Typ))))
14610 ("type must have a class-wide access discriminant", Arg1);
14612 end Java_Interface;
14618 -- pragma Keep_Names ([On => ] local_NAME);
14620 when Pragma_Keep_Names => Keep_Names : declare
14625 Check_Arg_Count (1);
14626 Check_Optional_Identifier (Arg1, Name_On);
14627 Check_Arg_Is_Local_Name (Arg1);
14629 Arg := Get_Pragma_Arg (Arg1);
14632 if Etype (Arg) = Any_Type then
14636 if not Is_Entity_Name (Arg)
14637 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
14640 ("pragma% requires a local enumeration type", Arg1);
14643 Set_Discard_Names (Entity (Arg), False);
14650 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
14652 when Pragma_License =>
14654 Check_Arg_Count (1);
14655 Check_No_Identifiers;
14656 Check_Valid_Configuration_Pragma;
14657 Check_Arg_Is_Identifier (Arg1);
14660 Sind : constant Source_File_Index :=
14661 Source_Index (Current_Sem_Unit);
14664 case Chars (Get_Pragma_Arg (Arg1)) is
14666 Set_License (Sind, GPL);
14668 when Name_Modified_GPL =>
14669 Set_License (Sind, Modified_GPL);
14671 when Name_Restricted =>
14672 Set_License (Sind, Restricted);
14674 when Name_Unrestricted =>
14675 Set_License (Sind, Unrestricted);
14678 Error_Pragma_Arg ("invalid license name", Arg1);
14686 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
14688 when Pragma_Link_With => Link_With : declare
14694 if Operating_Mode = Generate_Code
14695 and then In_Extended_Main_Source_Unit (N)
14697 Check_At_Least_N_Arguments (1);
14698 Check_No_Identifiers;
14699 Check_Is_In_Decl_Part_Or_Package_Spec;
14700 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14704 while Present (Arg) loop
14705 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14707 -- Store argument, converting sequences of spaces to a
14708 -- single null character (this is one of the differences
14709 -- in processing between Link_With and Linker_Options).
14711 Arg_Store : declare
14712 C : constant Char_Code := Get_Char_Code (' ');
14713 S : constant String_Id :=
14714 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
14715 L : constant Nat := String_Length (S);
14718 procedure Skip_Spaces;
14719 -- Advance F past any spaces
14725 procedure Skip_Spaces is
14727 while F <= L and then Get_String_Char (S, F) = C loop
14732 -- Start of processing for Arg_Store
14735 Skip_Spaces; -- skip leading spaces
14737 -- Loop through characters, changing any embedded
14738 -- sequence of spaces to a single null character (this
14739 -- is how Link_With/Linker_Options differ)
14742 if Get_String_Char (S, F) = C then
14745 Store_String_Char (ASCII.NUL);
14748 Store_String_Char (Get_String_Char (S, F));
14756 if Present (Arg) then
14757 Store_String_Char (ASCII.NUL);
14761 Store_Linker_Option_String (End_String);
14769 -- pragma Linker_Alias (
14770 -- [Entity =>] LOCAL_NAME
14771 -- [Target =>] static_string_EXPRESSION);
14773 when Pragma_Linker_Alias =>
14775 Check_Arg_Order ((Name_Entity, Name_Target));
14776 Check_Arg_Count (2);
14777 Check_Optional_Identifier (Arg1, Name_Entity);
14778 Check_Optional_Identifier (Arg2, Name_Target);
14779 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14780 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14782 -- The only processing required is to link this item on to the
14783 -- list of rep items for the given entity. This is accomplished
14784 -- by the call to Rep_Item_Too_Late (when no error is detected
14785 -- and False is returned).
14787 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14790 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14793 ------------------------
14794 -- Linker_Constructor --
14795 ------------------------
14797 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
14799 -- Code is shared with Linker_Destructor
14801 -----------------------
14802 -- Linker_Destructor --
14803 -----------------------
14805 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
14807 when Pragma_Linker_Constructor |
14808 Pragma_Linker_Destructor =>
14809 Linker_Constructor : declare
14815 Check_Arg_Count (1);
14816 Check_No_Identifiers;
14817 Check_Arg_Is_Local_Name (Arg1);
14818 Arg1_X := Get_Pragma_Arg (Arg1);
14820 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
14822 if not Is_Library_Level_Entity (Proc) then
14824 ("argument for pragma% must be library level entity", Arg1);
14827 -- The only processing required is to link this item on to the
14828 -- list of rep items for the given entity. This is accomplished
14829 -- by the call to Rep_Item_Too_Late (when no error is detected
14830 -- and False is returned).
14832 if Rep_Item_Too_Late (Proc, N) then
14835 Set_Has_Gigi_Rep_Item (Proc);
14837 end Linker_Constructor;
14839 --------------------
14840 -- Linker_Options --
14841 --------------------
14843 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
14845 when Pragma_Linker_Options => Linker_Options : declare
14849 Check_Ada_83_Warning;
14850 Check_No_Identifiers;
14851 Check_Arg_Count (1);
14852 Check_Is_In_Decl_Part_Or_Package_Spec;
14853 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
14854 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
14857 while Present (Arg) loop
14858 Check_Arg_Is_Static_Expression (Arg, Standard_String);
14859 Store_String_Char (ASCII.NUL);
14861 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
14865 if Operating_Mode = Generate_Code
14866 and then In_Extended_Main_Source_Unit (N)
14868 Store_Linker_Option_String (End_String);
14870 end Linker_Options;
14872 --------------------
14873 -- Linker_Section --
14874 --------------------
14876 -- pragma Linker_Section (
14877 -- [Entity =>] LOCAL_NAME
14878 -- [Section =>] static_string_EXPRESSION);
14880 when Pragma_Linker_Section =>
14882 Check_Arg_Order ((Name_Entity, Name_Section));
14883 Check_Arg_Count (2);
14884 Check_Optional_Identifier (Arg1, Name_Entity);
14885 Check_Optional_Identifier (Arg2, Name_Section);
14886 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14887 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
14889 -- This pragma applies to objects and types
14891 if not Is_Object (Entity (Get_Pragma_Arg (Arg1)))
14892 and then not Is_Type (Entity (Get_Pragma_Arg (Arg1)))
14895 ("pragma% applies only to objects and types", Arg1);
14898 -- The only processing required is to link this item on to the
14899 -- list of rep items for the given entity. This is accomplished
14900 -- by the call to Rep_Item_Too_Late (when no error is detected
14901 -- and False is returned).
14903 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
14906 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
14913 -- pragma List (On | Off)
14915 -- There is nothing to do here, since we did all the processing for
14916 -- this pragma in Par.Prag (so that it works properly even in syntax
14919 when Pragma_List =>
14926 -- pragma Lock_Free [(Boolean_EXPRESSION)];
14928 when Pragma_Lock_Free => Lock_Free : declare
14929 P : constant Node_Id := Parent (N);
14935 Check_No_Identifiers;
14936 Check_At_Most_N_Arguments (1);
14938 -- Protected definition case
14940 if Nkind (P) = N_Protected_Definition then
14941 Ent := Defining_Identifier (Parent (P));
14945 if Arg_Count = 1 then
14946 Arg := Get_Pragma_Arg (Arg1);
14947 Val := Is_True (Static_Boolean (Arg));
14949 -- No arguments (expression is considered to be True)
14955 -- Check duplicate pragma before we chain the pragma in the Rep
14956 -- Item chain of Ent.
14958 Check_Duplicate_Pragma (Ent);
14959 Record_Rep_Item (Ent, N);
14960 Set_Uses_Lock_Free (Ent, Val);
14962 -- Anything else is incorrect placement
14969 --------------------
14970 -- Locking_Policy --
14971 --------------------
14973 -- pragma Locking_Policy (policy_IDENTIFIER);
14975 when Pragma_Locking_Policy => declare
14976 subtype LP_Range is Name_Id
14977 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
14982 Check_Ada_83_Warning;
14983 Check_Arg_Count (1);
14984 Check_No_Identifiers;
14985 Check_Arg_Is_Locking_Policy (Arg1);
14986 Check_Valid_Configuration_Pragma;
14987 LP_Val := Chars (Get_Pragma_Arg (Arg1));
14990 when Name_Ceiling_Locking =>
14992 when Name_Inheritance_Locking =>
14994 when Name_Concurrent_Readers_Locking =>
14998 if Locking_Policy /= ' '
14999 and then Locking_Policy /= LP
15001 Error_Msg_Sloc := Locking_Policy_Sloc;
15002 Error_Pragma ("locking policy incompatible with policy#");
15004 -- Set new policy, but always preserve System_Location since we
15005 -- like the error message with the run time name.
15008 Locking_Policy := LP;
15010 if Locking_Policy_Sloc /= System_Location then
15011 Locking_Policy_Sloc := Loc;
15020 -- pragma Long_Float (D_Float | G_Float);
15022 when Pragma_Long_Float => Long_Float : declare
15025 Check_Valid_Configuration_Pragma;
15026 Check_Arg_Count (1);
15027 Check_No_Identifier (Arg1);
15028 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
15030 if not OpenVMS_On_Target then
15031 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
15036 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
15037 if Opt.Float_Format_Long = 'G' then
15039 ("G_Float previously specified", Arg1);
15041 elsif Current_Sem_Unit /= Main_Unit
15042 and then Opt.Float_Format_Long /= 'D'
15045 ("main unit not compiled with pragma Long_Float (D_Float)",
15046 "\pragma% must be used consistently for whole partition",
15050 Opt.Float_Format_Long := 'D';
15053 -- G_Float case (this is the default, does not need overriding)
15056 if Opt.Float_Format_Long = 'D' then
15057 Error_Pragma ("D_Float previously specified");
15059 elsif Current_Sem_Unit /= Main_Unit
15060 and then Opt.Float_Format_Long /= 'G'
15063 ("main unit not compiled with pragma Long_Float (G_Float)",
15064 "\pragma% must be used consistently for whole partition",
15068 Opt.Float_Format_Long := 'G';
15072 Set_Standard_Fpt_Formats;
15075 -------------------
15076 -- Loop_Optimize --
15077 -------------------
15079 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
15081 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
15083 when Pragma_Loop_Optimize => Loop_Optimize : declare
15088 Check_At_Least_N_Arguments (1);
15089 Check_No_Identifiers;
15091 Hint := First (Pragma_Argument_Associations (N));
15092 while Present (Hint) loop
15093 Check_Arg_Is_One_Of (Hint,
15094 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector);
15098 Check_Loop_Pragma_Placement;
15105 -- pragma Loop_Variant
15106 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
15108 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
15110 -- CHANGE_DIRECTION ::= Increases | Decreases
15112 when Pragma_Loop_Variant => Loop_Variant : declare
15117 Check_At_Least_N_Arguments (1);
15118 Check_Loop_Pragma_Placement;
15120 -- Process all increasing / decreasing expressions
15122 Variant := First (Pragma_Argument_Associations (N));
15123 while Present (Variant) loop
15124 if not Nam_In (Chars (Variant), Name_Decreases,
15127 Error_Pragma_Arg ("wrong change modifier", Variant);
15130 Preanalyze_Assert_Expression
15131 (Expression (Variant), Any_Discrete);
15137 -----------------------
15138 -- Machine_Attribute --
15139 -----------------------
15141 -- pragma Machine_Attribute (
15142 -- [Entity =>] LOCAL_NAME,
15143 -- [Attribute_Name =>] static_string_EXPRESSION
15144 -- [, [Info =>] static_EXPRESSION] );
15146 when Pragma_Machine_Attribute => Machine_Attribute : declare
15147 Def_Id : Entity_Id;
15151 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
15153 if Arg_Count = 3 then
15154 Check_Optional_Identifier (Arg3, Name_Info);
15155 Check_Arg_Is_Static_Expression (Arg3);
15157 Check_Arg_Count (2);
15160 Check_Optional_Identifier (Arg1, Name_Entity);
15161 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
15162 Check_Arg_Is_Local_Name (Arg1);
15163 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
15164 Def_Id := Entity (Get_Pragma_Arg (Arg1));
15166 if Is_Access_Type (Def_Id) then
15167 Def_Id := Designated_Type (Def_Id);
15170 if Rep_Item_Too_Early (Def_Id, N) then
15174 Def_Id := Underlying_Type (Def_Id);
15176 -- The only processing required is to link this item on to the
15177 -- list of rep items for the given entity. This is accomplished
15178 -- by the call to Rep_Item_Too_Late (when no error is detected
15179 -- and False is returned).
15181 if Rep_Item_Too_Late (Def_Id, N) then
15184 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
15186 end Machine_Attribute;
15193 -- (MAIN_OPTION [, MAIN_OPTION]);
15196 -- [STACK_SIZE =>] static_integer_EXPRESSION
15197 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
15198 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
15200 when Pragma_Main => Main : declare
15201 Args : Args_List (1 .. 3);
15202 Names : constant Name_List (1 .. 3) := (
15204 Name_Task_Stack_Size_Default,
15205 Name_Time_Slicing_Enabled);
15211 Gather_Associations (Names, Args);
15213 for J in 1 .. 2 loop
15214 if Present (Args (J)) then
15215 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
15219 if Present (Args (3)) then
15220 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
15224 while Present (Nod) loop
15225 if Nkind (Nod) = N_Pragma
15226 and then Pragma_Name (Nod) = Name_Main
15228 Error_Msg_Name_1 := Pname;
15229 Error_Msg_N ("duplicate pragma% not permitted", Nod);
15240 -- pragma Main_Storage
15241 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
15243 -- MAIN_STORAGE_OPTION ::=
15244 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
15245 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
15247 when Pragma_Main_Storage => Main_Storage : declare
15248 Args : Args_List (1 .. 2);
15249 Names : constant Name_List (1 .. 2) := (
15250 Name_Working_Storage,
15257 Gather_Associations (Names, Args);
15259 for J in 1 .. 2 loop
15260 if Present (Args (J)) then
15261 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
15265 Check_In_Main_Program;
15268 while Present (Nod) loop
15269 if Nkind (Nod) = N_Pragma
15270 and then Pragma_Name (Nod) = Name_Main_Storage
15272 Error_Msg_Name_1 := Pname;
15273 Error_Msg_N ("duplicate pragma% not permitted", Nod);
15284 -- pragma Memory_Size (NUMERIC_LITERAL)
15286 when Pragma_Memory_Size =>
15289 -- Memory size is simply ignored
15291 Check_No_Identifiers;
15292 Check_Arg_Count (1);
15293 Check_Arg_Is_Integer_Literal (Arg1);
15301 -- The only correct use of this pragma is on its own in a file, in
15302 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
15303 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
15304 -- check for a file containing nothing but a No_Body pragma). If we
15305 -- attempt to process it during normal semantics processing, it means
15306 -- it was misplaced.
15308 when Pragma_No_Body =>
15316 -- pragma No_Inline ( NAME {, NAME} );
15318 when Pragma_No_Inline =>
15320 Process_Inline (Suppressed);
15326 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
15328 when Pragma_No_Return => No_Return : declare
15336 Check_At_Least_N_Arguments (1);
15338 -- Loop through arguments of pragma
15341 while Present (Arg) loop
15342 Check_Arg_Is_Local_Name (Arg);
15343 Id := Get_Pragma_Arg (Arg);
15346 if not Is_Entity_Name (Id) then
15347 Error_Pragma_Arg ("entity name required", Arg);
15350 if Etype (Id) = Any_Type then
15354 -- Loop to find matching procedures
15359 and then Scope (E) = Current_Scope
15361 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
15364 -- Set flag on any alias as well
15366 if Is_Overloadable (E) and then Present (Alias (E)) then
15367 Set_No_Return (Alias (E));
15373 exit when From_Aspect_Specification (N);
15378 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
15389 -- pragma No_Run_Time;
15391 -- Note: this pragma is retained for backwards compatibility. See
15392 -- body of Rtsfind for full details on its handling.
15394 when Pragma_No_Run_Time =>
15396 Check_Valid_Configuration_Pragma;
15397 Check_Arg_Count (0);
15399 No_Run_Time_Mode := True;
15400 Configurable_Run_Time_Mode := True;
15402 -- Set Duration to 32 bits if word size is 32
15404 if Ttypes.System_Word_Size = 32 then
15405 Duration_32_Bits_On_Target := True;
15408 -- Set appropriate restrictions
15410 Set_Restriction (No_Finalization, N);
15411 Set_Restriction (No_Exception_Handlers, N);
15412 Set_Restriction (Max_Tasks, N, 0);
15413 Set_Restriction (No_Tasking, N);
15415 ------------------------
15416 -- No_Strict_Aliasing --
15417 ------------------------
15419 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
15421 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
15426 Check_At_Most_N_Arguments (1);
15428 if Arg_Count = 0 then
15429 Check_Valid_Configuration_Pragma;
15430 Opt.No_Strict_Aliasing := True;
15433 Check_Optional_Identifier (Arg2, Name_Entity);
15434 Check_Arg_Is_Local_Name (Arg1);
15435 E_Id := Entity (Get_Pragma_Arg (Arg1));
15437 if E_Id = Any_Type then
15439 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
15440 Error_Pragma_Arg ("pragma% requires access type", Arg1);
15443 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
15445 end No_Strict_Aliasing;
15447 -----------------------
15448 -- Normalize_Scalars --
15449 -----------------------
15451 -- pragma Normalize_Scalars;
15453 when Pragma_Normalize_Scalars =>
15454 Check_Ada_83_Warning;
15455 Check_Arg_Count (0);
15456 Check_Valid_Configuration_Pragma;
15458 -- Normalize_Scalars creates false positives in CodePeer, and
15459 -- incorrect negative results in SPARK mode, so ignore this pragma
15462 if not (CodePeer_Mode or SPARK_Mode) then
15463 Normalize_Scalars := True;
15464 Init_Or_Norm_Scalars := True;
15471 -- pragma Obsolescent;
15473 -- pragma Obsolescent (
15474 -- [Message =>] static_string_EXPRESSION
15475 -- [,[Version =>] Ada_05]]);
15477 -- pragma Obsolescent (
15478 -- [Entity =>] NAME
15479 -- [,[Message =>] static_string_EXPRESSION
15480 -- [,[Version =>] Ada_05]] );
15482 when Pragma_Obsolescent => Obsolescent : declare
15486 procedure Set_Obsolescent (E : Entity_Id);
15487 -- Given an entity Ent, mark it as obsolescent if appropriate
15489 ---------------------
15490 -- Set_Obsolescent --
15491 ---------------------
15493 procedure Set_Obsolescent (E : Entity_Id) is
15502 -- Entity name was given
15504 if Present (Ename) then
15506 -- If entity name matches, we are fine. Save entity in
15507 -- pragma argument, for ASIS use.
15509 if Chars (Ename) = Chars (Ent) then
15510 Set_Entity (Ename, Ent);
15511 Generate_Reference (Ent, Ename);
15513 -- If entity name does not match, only possibility is an
15514 -- enumeration literal from an enumeration type declaration.
15516 elsif Ekind (Ent) /= E_Enumeration_Type then
15518 ("pragma % entity name does not match declaration");
15521 Ent := First_Literal (E);
15525 ("pragma % entity name does not match any "
15526 & "enumeration literal");
15528 elsif Chars (Ent) = Chars (Ename) then
15529 Set_Entity (Ename, Ent);
15530 Generate_Reference (Ent, Ename);
15534 Ent := Next_Literal (Ent);
15540 -- Ent points to entity to be marked
15542 if Arg_Count >= 1 then
15544 -- Deal with static string argument
15546 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
15547 S := Strval (Get_Pragma_Arg (Arg1));
15549 for J in 1 .. String_Length (S) loop
15550 if not In_Character_Range (Get_String_Char (S, J)) then
15552 ("pragma% argument does not allow wide characters",
15557 Obsolescent_Warnings.Append
15558 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
15560 -- Check for Ada_05 parameter
15562 if Arg_Count /= 1 then
15563 Check_Arg_Count (2);
15566 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
15569 Check_Arg_Is_Identifier (Argx);
15571 if Chars (Argx) /= Name_Ada_05 then
15572 Error_Msg_Name_2 := Name_Ada_05;
15574 ("only allowed argument for pragma% is %", Argx);
15577 if Ada_Version_Explicit < Ada_2005
15578 or else not Warn_On_Ada_2005_Compatibility
15586 -- Set flag if pragma active
15589 Set_Is_Obsolescent (Ent);
15593 end Set_Obsolescent;
15595 -- Start of processing for pragma Obsolescent
15600 Check_At_Most_N_Arguments (3);
15602 -- See if first argument specifies an entity name
15606 (Chars (Arg1) = Name_Entity
15608 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
15610 N_Operator_Symbol))
15612 Ename := Get_Pragma_Arg (Arg1);
15614 -- Eliminate first argument, so we can share processing
15618 Arg_Count := Arg_Count - 1;
15620 -- No Entity name argument given
15626 if Arg_Count >= 1 then
15627 Check_Optional_Identifier (Arg1, Name_Message);
15629 if Arg_Count = 2 then
15630 Check_Optional_Identifier (Arg2, Name_Version);
15634 -- Get immediately preceding declaration
15637 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
15641 -- Cases where we do not follow anything other than another pragma
15645 -- First case: library level compilation unit declaration with
15646 -- the pragma immediately following the declaration.
15648 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
15650 (Defining_Entity (Unit (Parent (Parent (N)))));
15653 -- Case 2: library unit placement for package
15657 Ent : constant Entity_Id := Find_Lib_Unit_Name;
15659 if Is_Package_Or_Generic_Package (Ent) then
15660 Set_Obsolescent (Ent);
15666 -- Cases where we must follow a declaration
15669 if Nkind (Decl) not in N_Declaration
15670 and then Nkind (Decl) not in N_Later_Decl_Item
15671 and then Nkind (Decl) not in N_Generic_Declaration
15672 and then Nkind (Decl) not in N_Renaming_Declaration
15675 ("pragma% misplaced, "
15676 & "must immediately follow a declaration");
15679 Set_Obsolescent (Defining_Entity (Decl));
15689 -- pragma Optimize (Time | Space | Off);
15691 -- The actual check for optimize is done in Gigi. Note that this
15692 -- pragma does not actually change the optimization setting, it
15693 -- simply checks that it is consistent with the pragma.
15695 when Pragma_Optimize =>
15696 Check_No_Identifiers;
15697 Check_Arg_Count (1);
15698 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
15700 ------------------------
15701 -- Optimize_Alignment --
15702 ------------------------
15704 -- pragma Optimize_Alignment (Time | Space | Off);
15706 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
15708 Check_No_Identifiers;
15709 Check_Arg_Count (1);
15710 Check_Valid_Configuration_Pragma;
15713 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
15717 Opt.Optimize_Alignment := 'T';
15719 Opt.Optimize_Alignment := 'S';
15721 Opt.Optimize_Alignment := 'O';
15723 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
15727 -- Set indication that mode is set locally. If we are in fact in a
15728 -- configuration pragma file, this setting is harmless since the
15729 -- switch will get reset anyway at the start of each unit.
15731 Optimize_Alignment_Local := True;
15732 end Optimize_Alignment;
15738 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
15740 when Pragma_Ordered => Ordered : declare
15741 Assoc : constant Node_Id := Arg1;
15747 Check_No_Identifiers;
15748 Check_Arg_Count (1);
15749 Check_Arg_Is_Local_Name (Arg1);
15751 Type_Id := Get_Pragma_Arg (Assoc);
15752 Find_Type (Type_Id);
15753 Typ := Entity (Type_Id);
15755 if Typ = Any_Type then
15758 Typ := Underlying_Type (Typ);
15761 if not Is_Enumeration_Type (Typ) then
15762 Error_Pragma ("pragma% must specify enumeration type");
15765 Check_First_Subtype (Arg1);
15766 Set_Has_Pragma_Ordered (Base_Type (Typ));
15769 -------------------
15770 -- Overflow_Mode --
15771 -------------------
15773 -- pragma Overflow_Mode
15774 -- ([General => ] MODE [, [Assertions => ] MODE]);
15776 -- MODE := STRICT | MINIMIZED | ELIMINATED
15778 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
15779 -- since System.Bignums makes this assumption. This is true of nearly
15780 -- all (all?) targets.
15782 when Pragma_Overflow_Mode => Overflow_Mode : declare
15783 function Get_Overflow_Mode
15785 Arg : Node_Id) return Overflow_Mode_Type;
15786 -- Function to process one pragma argument, Arg. If an identifier
15787 -- is present, it must be Name. Mode type is returned if a valid
15788 -- argument exists, otherwise an error is signalled.
15790 -----------------------
15791 -- Get_Overflow_Mode --
15792 -----------------------
15794 function Get_Overflow_Mode
15796 Arg : Node_Id) return Overflow_Mode_Type
15798 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
15801 Check_Optional_Identifier (Arg, Name);
15802 Check_Arg_Is_Identifier (Argx);
15804 if Chars (Argx) = Name_Strict then
15807 elsif Chars (Argx) = Name_Minimized then
15810 elsif Chars (Argx) = Name_Eliminated then
15811 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
15813 ("Eliminated not implemented on this target", Argx);
15819 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
15821 end Get_Overflow_Mode;
15823 -- Start of processing for Overflow_Mode
15827 Check_At_Least_N_Arguments (1);
15828 Check_At_Most_N_Arguments (2);
15830 -- Process first argument
15832 Scope_Suppress.Overflow_Mode_General :=
15833 Get_Overflow_Mode (Name_General, Arg1);
15835 -- Case of only one argument
15837 if Arg_Count = 1 then
15838 Scope_Suppress.Overflow_Mode_Assertions :=
15839 Scope_Suppress.Overflow_Mode_General;
15841 -- Case of two arguments present
15844 Scope_Suppress.Overflow_Mode_Assertions :=
15845 Get_Overflow_Mode (Name_Assertions, Arg2);
15849 --------------------------
15850 -- Overriding Renamings --
15851 --------------------------
15853 -- pragma Overriding_Renamings;
15855 when Pragma_Overriding_Renamings =>
15857 Check_Arg_Count (0);
15858 Check_Valid_Configuration_Pragma;
15859 Overriding_Renamings := True;
15865 -- pragma Pack (first_subtype_LOCAL_NAME);
15867 when Pragma_Pack => Pack : declare
15868 Assoc : constant Node_Id := Arg1;
15872 Ignore : Boolean := False;
15875 Check_No_Identifiers;
15876 Check_Arg_Count (1);
15877 Check_Arg_Is_Local_Name (Arg1);
15879 Type_Id := Get_Pragma_Arg (Assoc);
15880 Find_Type (Type_Id);
15881 Typ := Entity (Type_Id);
15884 or else Rep_Item_Too_Early (Typ, N)
15888 Typ := Underlying_Type (Typ);
15891 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
15892 Error_Pragma ("pragma% must specify array or record type");
15895 Check_First_Subtype (Arg1);
15896 Check_Duplicate_Pragma (Typ);
15900 if Is_Array_Type (Typ) then
15901 Ctyp := Component_Type (Typ);
15903 -- Ignore pack that does nothing
15905 if Known_Static_Esize (Ctyp)
15906 and then Known_Static_RM_Size (Ctyp)
15907 and then Esize (Ctyp) = RM_Size (Ctyp)
15908 and then Addressable (Esize (Ctyp))
15913 -- Process OK pragma Pack. Note that if there is a separate
15914 -- component clause present, the Pack will be cancelled. This
15915 -- processing is in Freeze.
15917 if not Rep_Item_Too_Late (Typ, N) then
15919 -- In the context of static code analysis, we do not need
15920 -- complex front-end expansions related to pragma Pack,
15921 -- so disable handling of pragma Pack in these cases.
15923 if CodePeer_Mode or SPARK_Mode then
15926 -- Don't attempt any packing for VM targets. We possibly
15927 -- could deal with some cases of array bit-packing, but we
15928 -- don't bother, since this is not a typical kind of
15929 -- representation in the VM context anyway (and would not
15930 -- for example work nicely with the debugger).
15932 elsif VM_Target /= No_VM then
15933 if not GNAT_Mode then
15935 ("??pragma% ignored in this configuration");
15938 -- Normal case where we do the pack action
15942 Set_Is_Packed (Base_Type (Typ));
15943 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15946 Set_Has_Pragma_Pack (Base_Type (Typ));
15950 -- For record types, the pack is always effective
15952 else pragma Assert (Is_Record_Type (Typ));
15953 if not Rep_Item_Too_Late (Typ, N) then
15955 -- Ignore pack request with warning in VM mode (skip warning
15956 -- if we are compiling GNAT run time library).
15958 if VM_Target /= No_VM then
15959 if not GNAT_Mode then
15961 ("??pragma% ignored in this configuration");
15964 -- Normal case of pack request active
15967 Set_Is_Packed (Base_Type (Typ));
15968 Set_Has_Pragma_Pack (Base_Type (Typ));
15969 Set_Has_Non_Standard_Rep (Base_Type (Typ));
15981 -- There is nothing to do here, since we did all the processing for
15982 -- this pragma in Par.Prag (so that it works properly even in syntax
15985 when Pragma_Page =>
15988 ----------------------------------
15989 -- Partition_Elaboration_Policy --
15990 ----------------------------------
15992 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
15994 when Pragma_Partition_Elaboration_Policy => declare
15995 subtype PEP_Range is Name_Id
15996 range First_Partition_Elaboration_Policy_Name
15997 .. Last_Partition_Elaboration_Policy_Name;
15998 PEP_Val : PEP_Range;
16003 Check_Arg_Count (1);
16004 Check_No_Identifiers;
16005 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
16006 Check_Valid_Configuration_Pragma;
16007 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
16010 when Name_Concurrent =>
16012 when Name_Sequential =>
16016 if Partition_Elaboration_Policy /= ' '
16017 and then Partition_Elaboration_Policy /= PEP
16019 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
16021 ("partition elaboration policy incompatible with policy#");
16023 -- Set new policy, but always preserve System_Location since we
16024 -- like the error message with the run time name.
16027 Partition_Elaboration_Policy := PEP;
16029 if Partition_Elaboration_Policy_Sloc /= System_Location then
16030 Partition_Elaboration_Policy_Sloc := Loc;
16039 -- pragma Passive [(PASSIVE_FORM)];
16041 -- PASSIVE_FORM ::= Semaphore | No
16043 when Pragma_Passive =>
16046 if Nkind (Parent (N)) /= N_Task_Definition then
16047 Error_Pragma ("pragma% must be within task definition");
16050 if Arg_Count /= 0 then
16051 Check_Arg_Count (1);
16052 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
16055 ----------------------------------
16056 -- Preelaborable_Initialization --
16057 ----------------------------------
16059 -- pragma Preelaborable_Initialization (DIRECT_NAME);
16061 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
16066 Check_Arg_Count (1);
16067 Check_No_Identifiers;
16068 Check_Arg_Is_Identifier (Arg1);
16069 Check_Arg_Is_Local_Name (Arg1);
16070 Check_First_Subtype (Arg1);
16071 Ent := Entity (Get_Pragma_Arg (Arg1));
16073 -- The pragma may come from an aspect on a private declaration,
16074 -- even if the freeze point at which this is analyzed in the
16075 -- private part after the full view.
16077 if Has_Private_Declaration (Ent)
16078 and then From_Aspect_Specification (N)
16082 elsif Is_Private_Type (Ent)
16083 or else Is_Protected_Type (Ent)
16084 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
16090 ("pragma % can only be applied to private, formal derived or "
16091 & "protected type",
16095 -- Give an error if the pragma is applied to a protected type that
16096 -- does not qualify (due to having entries, or due to components
16097 -- that do not qualify).
16099 if Is_Protected_Type (Ent)
16100 and then not Has_Preelaborable_Initialization (Ent)
16103 ("protected type & does not have preelaborable "
16104 & "initialization", Ent);
16106 -- Otherwise mark the type as definitely having preelaborable
16110 Set_Known_To_Have_Preelab_Init (Ent);
16113 if Has_Pragma_Preelab_Init (Ent)
16114 and then Warn_On_Redundant_Constructs
16116 Error_Pragma ("?r?duplicate pragma%!");
16118 Set_Has_Pragma_Preelab_Init (Ent);
16122 --------------------
16123 -- Persistent_BSS --
16124 --------------------
16126 -- pragma Persistent_BSS [(object_NAME)];
16128 when Pragma_Persistent_BSS => Persistent_BSS : declare
16135 Check_At_Most_N_Arguments (1);
16137 -- Case of application to specific object (one argument)
16139 if Arg_Count = 1 then
16140 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16142 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
16144 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
16147 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
16150 Ent := Entity (Get_Pragma_Arg (Arg1));
16151 Decl := Parent (Ent);
16153 -- Check for duplication before inserting in list of
16154 -- representation items.
16156 Check_Duplicate_Pragma (Ent);
16158 if Rep_Item_Too_Late (Ent, N) then
16162 if Present (Expression (Decl)) then
16164 ("object for pragma% cannot have initialization", Arg1);
16167 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
16169 ("object type for pragma% is not potentially persistent",
16174 Make_Linker_Section_Pragma
16175 (Ent, Sloc (N), ".persistent.bss");
16176 Insert_After (N, Prag);
16179 -- Case of use as configuration pragma with no arguments
16182 Check_Valid_Configuration_Pragma;
16183 Persistent_BSS_Mode := True;
16185 end Persistent_BSS;
16191 -- pragma Polling (ON | OFF);
16193 when Pragma_Polling =>
16195 Check_Arg_Count (1);
16196 Check_No_Identifiers;
16197 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16198 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
16204 -- pragma Post (Boolean_EXPRESSION);
16205 -- pragma Post_Class (Boolean_EXPRESSION);
16207 when Pragma_Post | Pragma_Post_Class => Post : declare
16208 PC_Pragma : Node_Id;
16212 Check_Arg_Count (1);
16213 Check_No_Identifiers;
16216 -- Rewrite Post[_Class] pragma as Precondition pragma setting the
16217 -- flag Class_Present to True for the Post_Class case.
16219 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
16220 PC_Pragma := New_Copy (N);
16221 Set_Pragma_Identifier
16222 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition));
16223 Rewrite (N, PC_Pragma);
16224 Set_Analyzed (N, False);
16228 -------------------
16229 -- Postcondition --
16230 -------------------
16232 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
16233 -- [,[Message =>] String_EXPRESSION]);
16235 when Pragma_Postcondition => Postcondition : declare
16240 Check_At_Least_N_Arguments (1);
16241 Check_At_Most_N_Arguments (2);
16242 Check_Optional_Identifier (Arg1, Name_Check);
16244 -- Verify the proper placement of the pragma. The remainder of the
16245 -- processing is found in Sem_Ch6/Sem_Ch7.
16247 Check_Precondition_Postcondition (In_Body);
16249 -- When the pragma is a source construct appearing inside a body,
16250 -- preanalyze the boolean_expression to detect illegal forward
16254 -- pragma Postcondition (X'Old ...);
16257 if Comes_From_Source (N) and then In_Body then
16258 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
16266 -- pragma Pre (Boolean_EXPRESSION);
16267 -- pragma Pre_Class (Boolean_EXPRESSION);
16269 when Pragma_Pre | Pragma_Pre_Class => Pre : declare
16270 PC_Pragma : Node_Id;
16274 Check_Arg_Count (1);
16275 Check_No_Identifiers;
16278 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
16279 -- flag Class_Present to True for the Pre_Class case.
16281 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
16282 PC_Pragma := New_Copy (N);
16283 Set_Pragma_Identifier
16284 (PC_Pragma, Make_Identifier (Loc, Name_Precondition));
16285 Rewrite (N, PC_Pragma);
16286 Set_Analyzed (N, False);
16294 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
16295 -- [,[Message =>] String_EXPRESSION]);
16297 when Pragma_Precondition => Precondition : declare
16302 Check_At_Least_N_Arguments (1);
16303 Check_At_Most_N_Arguments (2);
16304 Check_Optional_Identifier (Arg1, Name_Check);
16305 Check_Precondition_Postcondition (In_Body);
16307 -- If in spec, nothing more to do. If in body, then we convert
16308 -- the pragma to an equivalent pragma Check. That works fine since
16309 -- pragma Check will analyze the condition in the proper context.
16311 -- The form of the pragma Check is either:
16313 -- pragma Check (Precondition, cond [, msg])
16315 -- pragma Check (Pre, cond [, msg])
16317 -- We use the Pre form if this pragma derived from a Pre aspect.
16318 -- This is needed to make sure that the right set of Policy
16319 -- pragmas are checked.
16323 -- Rewrite as Check pragma
16327 Chars => Name_Check,
16328 Pragma_Argument_Associations => New_List (
16329 Make_Pragma_Argument_Association (Loc,
16330 Expression => Make_Identifier (Loc, Pname)),
16332 Make_Pragma_Argument_Association (Sloc (Arg1),
16334 Relocate_Node (Get_Pragma_Arg (Arg1))))));
16336 if Arg_Count = 2 then
16337 Append_To (Pragma_Argument_Associations (N),
16338 Make_Pragma_Argument_Association (Sloc (Arg2),
16340 Relocate_Node (Get_Pragma_Arg (Arg2))));
16351 -- pragma Predicate
16352 -- ([Entity =>] type_LOCAL_NAME,
16353 -- [Check =>] boolean_EXPRESSION);
16355 when Pragma_Predicate => Predicate : declare
16360 pragma Unreferenced (Discard);
16364 Check_Arg_Count (2);
16365 Check_Optional_Identifier (Arg1, Name_Entity);
16366 Check_Optional_Identifier (Arg2, Name_Check);
16368 Check_Arg_Is_Local_Name (Arg1);
16370 Type_Id := Get_Pragma_Arg (Arg1);
16371 Find_Type (Type_Id);
16372 Typ := Entity (Type_Id);
16374 if Typ = Any_Type then
16378 -- The remaining processing is simply to link the pragma on to
16379 -- the rep item chain, for processing when the type is frozen.
16380 -- This is accomplished by a call to Rep_Item_Too_Late. We also
16381 -- mark the type as having predicates.
16383 Set_Has_Predicates (Typ);
16384 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16391 -- pragma Preelaborate [(library_unit_NAME)];
16393 -- Set the flag Is_Preelaborated of program unit name entity
16395 when Pragma_Preelaborate => Preelaborate : declare
16396 Pa : constant Node_Id := Parent (N);
16397 Pk : constant Node_Kind := Nkind (Pa);
16401 Check_Ada_83_Warning;
16402 Check_Valid_Library_Unit_Pragma;
16404 if Nkind (N) = N_Null_Statement then
16408 Ent := Find_Lib_Unit_Name;
16409 Check_Duplicate_Pragma (Ent);
16411 -- This filters out pragmas inside generic parents that show up
16412 -- inside instantiations. Pragmas that come from aspects in the
16413 -- unit are not ignored.
16415 if Present (Ent) then
16416 if Pk = N_Package_Specification
16417 and then Present (Generic_Parent (Pa))
16418 and then not From_Aspect_Specification (N)
16423 if not Debug_Flag_U then
16424 Set_Is_Preelaborated (Ent);
16425 Set_Suppress_Elaboration_Warnings (Ent);
16431 ---------------------
16432 -- Preelaborate_05 --
16433 ---------------------
16435 -- pragma Preelaborate_05 [(library_unit_NAME)];
16437 -- This pragma is useable only in GNAT_Mode, where it is used like
16438 -- pragma Preelaborate but it is only effective in Ada 2005 mode
16439 -- (otherwise it is ignored). This is used to implement AI-362 which
16440 -- recategorizes some run-time packages in Ada 2005 mode.
16442 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
16447 Check_Valid_Library_Unit_Pragma;
16449 if not GNAT_Mode then
16450 Error_Pragma ("pragma% only available in GNAT mode");
16453 if Nkind (N) = N_Null_Statement then
16457 -- This is one of the few cases where we need to test the value of
16458 -- Ada_Version_Explicit rather than Ada_Version (which is always
16459 -- set to Ada_2012 in a predefined unit), we need to know the
16460 -- explicit version set to know if this pragma is active.
16462 if Ada_Version_Explicit >= Ada_2005 then
16463 Ent := Find_Lib_Unit_Name;
16464 Set_Is_Preelaborated (Ent);
16465 Set_Suppress_Elaboration_Warnings (Ent);
16467 end Preelaborate_05;
16473 -- pragma Priority (EXPRESSION);
16475 when Pragma_Priority => Priority : declare
16476 P : constant Node_Id := Parent (N);
16481 Check_No_Identifiers;
16482 Check_Arg_Count (1);
16486 if Nkind (P) = N_Subprogram_Body then
16487 Check_In_Main_Program;
16489 Ent := Defining_Unit_Name (Specification (P));
16491 if Nkind (Ent) = N_Defining_Program_Unit_Name then
16492 Ent := Defining_Identifier (Ent);
16495 Arg := Get_Pragma_Arg (Arg1);
16496 Analyze_And_Resolve (Arg, Standard_Integer);
16500 if not Is_Static_Expression (Arg) then
16501 Flag_Non_Static_Expr
16502 ("main subprogram priority is not static!", Arg);
16505 -- If constraint error, then we already signalled an error
16507 elsif Raises_Constraint_Error (Arg) then
16510 -- Otherwise check in range
16514 Val : constant Uint := Expr_Value (Arg);
16518 or else Val > Expr_Value (Expression
16519 (Parent (RTE (RE_Max_Priority))))
16522 ("main subprogram priority is out of range", Arg1);
16528 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
16530 -- Load an arbitrary entity from System.Tasking.Stages or
16531 -- System.Tasking.Restricted.Stages (depending on the
16532 -- supported profile) to make sure that one of these packages
16533 -- is implicitly with'ed, since we need to have the tasking
16534 -- run time active for the pragma Priority to have any effect.
16535 -- Previously with with'ed the package System.Tasking, but
16536 -- this package does not trigger the required initialization
16537 -- of the run-time library.
16540 Discard : Entity_Id;
16541 pragma Warnings (Off, Discard);
16543 if Restricted_Profile then
16544 Discard := RTE (RE_Activate_Restricted_Tasks);
16546 Discard := RTE (RE_Activate_Tasks);
16550 -- Task or Protected, must be of type Integer
16552 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
16553 Arg := Get_Pragma_Arg (Arg1);
16554 Ent := Defining_Identifier (Parent (P));
16556 -- The expression must be analyzed in the special manner
16557 -- described in "Handling of Default and Per-Object
16558 -- Expressions" in sem.ads.
16560 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
16562 if not Is_Static_Expression (Arg) then
16563 Check_Restriction (Static_Priorities, Arg);
16566 -- Anything else is incorrect
16572 -- Check duplicate pragma before we chain the pragma in the Rep
16573 -- Item chain of Ent.
16575 Check_Duplicate_Pragma (Ent);
16576 Record_Rep_Item (Ent, N);
16579 -----------------------------------
16580 -- Priority_Specific_Dispatching --
16581 -----------------------------------
16583 -- pragma Priority_Specific_Dispatching (
16584 -- policy_IDENTIFIER,
16585 -- first_priority_EXPRESSION,
16586 -- last_priority_EXPRESSION);
16588 when Pragma_Priority_Specific_Dispatching =>
16589 Priority_Specific_Dispatching : declare
16590 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
16591 -- This is the entity System.Any_Priority;
16594 Lower_Bound : Node_Id;
16595 Upper_Bound : Node_Id;
16601 Check_Arg_Count (3);
16602 Check_No_Identifiers;
16603 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
16604 Check_Valid_Configuration_Pragma;
16605 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16606 DP := Fold_Upper (Name_Buffer (1));
16608 Lower_Bound := Get_Pragma_Arg (Arg2);
16609 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
16610 Lower_Val := Expr_Value (Lower_Bound);
16612 Upper_Bound := Get_Pragma_Arg (Arg3);
16613 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
16614 Upper_Val := Expr_Value (Upper_Bound);
16616 -- It is not allowed to use Task_Dispatching_Policy and
16617 -- Priority_Specific_Dispatching in the same partition.
16619 if Task_Dispatching_Policy /= ' ' then
16620 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16622 ("pragma% incompatible with Task_Dispatching_Policy#");
16624 -- Check lower bound in range
16626 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16628 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
16631 ("first_priority is out of range", Arg2);
16633 -- Check upper bound in range
16635 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
16637 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
16640 ("last_priority is out of range", Arg3);
16642 -- Check that the priority range is valid
16644 elsif Lower_Val > Upper_Val then
16646 ("last_priority_expression must be greater than or equal to "
16647 & "first_priority_expression");
16649 -- Store the new policy, but always preserve System_Location since
16650 -- we like the error message with the run-time name.
16653 -- Check overlapping in the priority ranges specified in other
16654 -- Priority_Specific_Dispatching pragmas within the same
16655 -- partition. We can only check those we know about!
16658 Specific_Dispatching.First .. Specific_Dispatching.Last
16660 if Specific_Dispatching.Table (J).First_Priority in
16661 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16662 or else Specific_Dispatching.Table (J).Last_Priority in
16663 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
16666 Specific_Dispatching.Table (J).Pragma_Loc;
16668 ("priority range overlaps with "
16669 & "Priority_Specific_Dispatching#");
16673 -- The use of Priority_Specific_Dispatching is incompatible
16674 -- with Task_Dispatching_Policy.
16676 if Task_Dispatching_Policy /= ' ' then
16677 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
16679 ("Priority_Specific_Dispatching incompatible "
16680 & "with Task_Dispatching_Policy#");
16683 -- The use of Priority_Specific_Dispatching forces ceiling
16686 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
16687 Error_Msg_Sloc := Locking_Policy_Sloc;
16689 ("Priority_Specific_Dispatching incompatible "
16690 & "with Locking_Policy#");
16692 -- Set the Ceiling_Locking policy, but preserve System_Location
16693 -- since we like the error message with the run time name.
16696 Locking_Policy := 'C';
16698 if Locking_Policy_Sloc /= System_Location then
16699 Locking_Policy_Sloc := Loc;
16703 -- Add entry in the table
16705 Specific_Dispatching.Append
16706 ((Dispatching_Policy => DP,
16707 First_Priority => UI_To_Int (Lower_Val),
16708 Last_Priority => UI_To_Int (Upper_Val),
16709 Pragma_Loc => Loc));
16711 end Priority_Specific_Dispatching;
16717 -- pragma Profile (profile_IDENTIFIER);
16719 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
16721 when Pragma_Profile =>
16723 Check_Arg_Count (1);
16724 Check_Valid_Configuration_Pragma;
16725 Check_No_Identifiers;
16728 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16731 if Chars (Argx) = Name_Ravenscar then
16732 Set_Ravenscar_Profile (N);
16734 elsif Chars (Argx) = Name_Restricted then
16735 Set_Profile_Restrictions
16737 N, Warn => Treat_Restrictions_As_Warnings);
16739 elsif Chars (Argx) = Name_Rational then
16740 Set_Rational_Profile;
16742 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16743 Set_Profile_Restrictions
16744 (No_Implementation_Extensions,
16745 N, Warn => Treat_Restrictions_As_Warnings);
16748 Error_Pragma_Arg ("& is not a valid profile", Argx);
16752 ----------------------
16753 -- Profile_Warnings --
16754 ----------------------
16756 -- pragma Profile_Warnings (profile_IDENTIFIER);
16758 -- profile_IDENTIFIER => Restricted | Ravenscar
16760 when Pragma_Profile_Warnings =>
16762 Check_Arg_Count (1);
16763 Check_Valid_Configuration_Pragma;
16764 Check_No_Identifiers;
16767 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
16770 if Chars (Argx) = Name_Ravenscar then
16771 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
16773 elsif Chars (Argx) = Name_Restricted then
16774 Set_Profile_Restrictions (Restricted, N, Warn => True);
16776 elsif Chars (Argx) = Name_No_Implementation_Extensions then
16777 Set_Profile_Restrictions
16778 (No_Implementation_Extensions, N, Warn => True);
16781 Error_Pragma_Arg ("& is not a valid profile", Argx);
16785 --------------------------
16786 -- Propagate_Exceptions --
16787 --------------------------
16789 -- pragma Propagate_Exceptions;
16791 -- Note: this pragma is obsolete and has no effect
16793 when Pragma_Propagate_Exceptions =>
16795 Check_Arg_Count (0);
16797 if Warn_On_Obsolescent_Feature then
16799 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
16800 "and has no effect?j?", N);
16807 -- pragma Psect_Object (
16808 -- [Internal =>] LOCAL_NAME,
16809 -- [, [External =>] EXTERNAL_SYMBOL]
16810 -- [, [Size =>] EXTERNAL_SYMBOL]);
16812 when Pragma_Psect_Object | Pragma_Common_Object =>
16813 Psect_Object : declare
16814 Args : Args_List (1 .. 3);
16815 Names : constant Name_List (1 .. 3) := (
16820 Internal : Node_Id renames Args (1);
16821 External : Node_Id renames Args (2);
16822 Size : Node_Id renames Args (3);
16824 Def_Id : Entity_Id;
16826 procedure Check_Too_Long (Arg : Node_Id);
16827 -- Posts message if the argument is an identifier with more
16828 -- than 31 characters, or a string literal with more than
16829 -- 31 characters, and we are operating under VMS
16831 --------------------
16832 -- Check_Too_Long --
16833 --------------------
16835 procedure Check_Too_Long (Arg : Node_Id) is
16836 X : constant Node_Id := Original_Node (Arg);
16839 if not Nkind_In (X, N_String_Literal, N_Identifier) then
16841 ("inappropriate argument for pragma %", Arg);
16844 if OpenVMS_On_Target then
16845 if (Nkind (X) = N_String_Literal
16846 and then String_Length (Strval (X)) > 31)
16848 (Nkind (X) = N_Identifier
16849 and then Length_Of_Name (Chars (X)) > 31)
16852 ("argument for pragma % is longer than 31 characters",
16856 end Check_Too_Long;
16858 -- Start of processing for Common_Object/Psect_Object
16862 Gather_Associations (Names, Args);
16863 Process_Extended_Import_Export_Internal_Arg (Internal);
16865 Def_Id := Entity (Internal);
16867 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
16869 ("pragma% must designate an object", Internal);
16872 Check_Too_Long (Internal);
16874 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
16876 ("cannot use pragma% for imported/exported object",
16880 if Is_Concurrent_Type (Etype (Internal)) then
16882 ("cannot specify pragma % for task/protected object",
16886 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
16888 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
16890 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
16893 if Ekind (Def_Id) = E_Constant then
16895 ("cannot specify pragma % for a constant", Internal);
16898 if Is_Record_Type (Etype (Internal)) then
16904 Ent := First_Entity (Etype (Internal));
16905 while Present (Ent) loop
16906 Decl := Declaration_Node (Ent);
16908 if Ekind (Ent) = E_Component
16909 and then Nkind (Decl) = N_Component_Declaration
16910 and then Present (Expression (Decl))
16911 and then Warn_On_Export_Import
16914 ("?x?object for pragma % has defaults", Internal);
16924 if Present (Size) then
16925 Check_Too_Long (Size);
16928 if Present (External) then
16929 Check_Arg_Is_External_Name (External);
16930 Check_Too_Long (External);
16933 -- If all error tests pass, link pragma on to the rep item chain
16935 Record_Rep_Item (Def_Id, N);
16942 -- pragma Pure [(library_unit_NAME)];
16944 when Pragma_Pure => Pure : declare
16948 Check_Ada_83_Warning;
16949 Check_Valid_Library_Unit_Pragma;
16951 if Nkind (N) = N_Null_Statement then
16955 Ent := Find_Lib_Unit_Name;
16957 Set_Has_Pragma_Pure (Ent);
16958 Set_Suppress_Elaboration_Warnings (Ent);
16965 -- pragma Pure_05 [(library_unit_NAME)];
16967 -- This pragma is useable only in GNAT_Mode, where it is used like
16968 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
16969 -- it is ignored). It may be used after a pragma Preelaborate, in
16970 -- which case it overrides the effect of the pragma Preelaborate.
16971 -- This is used to implement AI-362 which recategorizes some run-time
16972 -- packages in Ada 2005 mode.
16974 when Pragma_Pure_05 => Pure_05 : declare
16979 Check_Valid_Library_Unit_Pragma;
16981 if not GNAT_Mode then
16982 Error_Pragma ("pragma% only available in GNAT mode");
16985 if Nkind (N) = N_Null_Statement then
16989 -- This is one of the few cases where we need to test the value of
16990 -- Ada_Version_Explicit rather than Ada_Version (which is always
16991 -- set to Ada_2012 in a predefined unit), we need to know the
16992 -- explicit version set to know if this pragma is active.
16994 if Ada_Version_Explicit >= Ada_2005 then
16995 Ent := Find_Lib_Unit_Name;
16996 Set_Is_Preelaborated (Ent, False);
16998 Set_Suppress_Elaboration_Warnings (Ent);
17006 -- pragma Pure_12 [(library_unit_NAME)];
17008 -- This pragma is useable only in GNAT_Mode, where it is used like
17009 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
17010 -- it is ignored). It may be used after a pragma Preelaborate, in
17011 -- which case it overrides the effect of the pragma Preelaborate.
17012 -- This is used to implement AI05-0212 which recategorizes some
17013 -- run-time packages in Ada 2012 mode.
17015 when Pragma_Pure_12 => Pure_12 : declare
17020 Check_Valid_Library_Unit_Pragma;
17022 if not GNAT_Mode then
17023 Error_Pragma ("pragma% only available in GNAT mode");
17026 if Nkind (N) = N_Null_Statement then
17030 -- This is one of the few cases where we need to test the value of
17031 -- Ada_Version_Explicit rather than Ada_Version (which is always
17032 -- set to Ada_2012 in a predefined unit), we need to know the
17033 -- explicit version set to know if this pragma is active.
17035 if Ada_Version_Explicit >= Ada_2012 then
17036 Ent := Find_Lib_Unit_Name;
17037 Set_Is_Preelaborated (Ent, False);
17039 Set_Suppress_Elaboration_Warnings (Ent);
17043 -------------------
17044 -- Pure_Function --
17045 -------------------
17047 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
17049 when Pragma_Pure_Function => Pure_Function : declare
17052 Def_Id : Entity_Id;
17053 Effective : Boolean := False;
17057 Check_Arg_Count (1);
17058 Check_Optional_Identifier (Arg1, Name_Entity);
17059 Check_Arg_Is_Local_Name (Arg1);
17060 E_Id := Get_Pragma_Arg (Arg1);
17062 if Error_Posted (E_Id) then
17066 -- Loop through homonyms (overloadings) of referenced entity
17068 E := Entity (E_Id);
17070 if Present (E) then
17072 Def_Id := Get_Base_Subprogram (E);
17074 if not Ekind_In (Def_Id, E_Function,
17075 E_Generic_Function,
17079 ("pragma% requires a function name", Arg1);
17082 Set_Is_Pure (Def_Id);
17084 if not Has_Pragma_Pure_Function (Def_Id) then
17085 Set_Has_Pragma_Pure_Function (Def_Id);
17089 exit when From_Aspect_Specification (N);
17091 exit when No (E) or else Scope (E) /= Current_Scope;
17095 and then Warn_On_Redundant_Constructs
17098 ("pragma Pure_Function on& is redundant?r?",
17104 --------------------
17105 -- Queuing_Policy --
17106 --------------------
17108 -- pragma Queuing_Policy (policy_IDENTIFIER);
17110 when Pragma_Queuing_Policy => declare
17114 Check_Ada_83_Warning;
17115 Check_Arg_Count (1);
17116 Check_No_Identifiers;
17117 Check_Arg_Is_Queuing_Policy (Arg1);
17118 Check_Valid_Configuration_Pragma;
17119 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
17120 QP := Fold_Upper (Name_Buffer (1));
17122 if Queuing_Policy /= ' '
17123 and then Queuing_Policy /= QP
17125 Error_Msg_Sloc := Queuing_Policy_Sloc;
17126 Error_Pragma ("queuing policy incompatible with policy#");
17128 -- Set new policy, but always preserve System_Location since we
17129 -- like the error message with the run time name.
17132 Queuing_Policy := QP;
17134 if Queuing_Policy_Sloc /= System_Location then
17135 Queuing_Policy_Sloc := Loc;
17144 -- pragma Rational, for compatibility with foreign compiler
17146 when Pragma_Rational =>
17147 Set_Rational_Profile;
17149 ------------------------------------
17150 -- Refined_Depends/Refined_Global --
17151 ------------------------------------
17153 -- pragma Refined_Depends (DEPENDENCY_RELATION);
17155 -- DEPENDENCY_RELATION ::=
17157 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
17159 -- DEPENDENCY_CLAUSE ::=
17160 -- OUTPUT_LIST =>[+] INPUT_LIST
17161 -- | NULL_DEPENDENCY_CLAUSE
17163 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
17165 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
17167 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
17169 -- OUTPUT ::= NAME | FUNCTION_RESULT
17172 -- where FUNCTION_RESULT is a function Result attribute_reference
17174 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
17176 -- GLOBAL_SPECIFICATION ::=
17179 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
17181 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17183 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17184 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17185 -- GLOBAL_ITEM ::= NAME
17187 when Pragma_Refined_Depends |
17188 Pragma_Refined_Global => Refined_Depends_Global :
17190 Body_Id : Entity_Id;
17192 Spec_Id : Entity_Id;
17195 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
17197 -- Save the pragma in the contract of the subprogram body. The
17198 -- remaining analysis is performed at the end of the enclosing
17202 Add_Contract_Item (N, Body_Id);
17204 end Refined_Depends_Global;
17210 -- pragma Refined_Post (boolean_EXPRESSION);
17212 when Pragma_Refined_Post => Refined_Post : declare
17213 Body_Id : Entity_Id;
17215 Spec_Id : Entity_Id;
17218 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
17220 -- Analyze the boolean expression as a "spec expression"
17223 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
17227 -------------------
17228 -- Refined_State --
17229 -------------------
17231 -- pragma Refined_State (REFINEMENT_LIST);
17233 -- REFINEMENT_LIST ::=
17234 -- REFINEMENT_CLAUSE
17235 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
17237 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
17239 -- CONSTITUENT_LIST ::=
17242 -- | (CONSTITUENT {, CONSTITUENT})
17244 -- CONSTITUENT ::= object_NAME | state_NAME
17246 when Pragma_Refined_State => Refined_State : declare
17247 Context : constant Node_Id := Parent (N);
17248 Spec_Id : Entity_Id;
17254 Check_Arg_Count (1);
17256 -- Ensure the proper placement of the pragma. Refined states must
17257 -- be associated with a package body.
17259 if Nkind (Context) /= N_Package_Body then
17265 while Present (Stmt) loop
17267 -- Skip prior pragmas, but check for duplicates
17269 if Nkind (Stmt) = N_Pragma then
17270 if Pragma_Name (Stmt) = Pname then
17271 Error_Msg_Name_1 := Pname;
17272 Error_Msg_Sloc := Sloc (Stmt);
17273 Error_Msg_N ("pragma % duplicates pragma declared #", N);
17276 -- Skip internally generated code
17278 elsif not Comes_From_Source (Stmt) then
17281 -- The pragma does not apply to a legal construct, issue an
17282 -- error and stop the analysis.
17289 Stmt := Prev (Stmt);
17292 -- State refinement is allowed only when the corresponding package
17293 -- declaration has a non-null pragma Abstract_State.
17295 Spec_Id := Corresponding_Spec (Context);
17297 if No (Abstract_States (Spec_Id))
17298 or else Has_Null_Abstract_State (Spec_Id)
17301 ("useless refinement, package & does not define abstract "
17302 & "states", N, Spec_Id);
17306 -- The pragma must be analyzed at the end of the declarations as
17307 -- it has visibility over the whole declarative region. Save the
17308 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
17309 -- adding it to the contract of the package body.
17311 Add_Contract_Item (N, Defining_Entity (Context));
17314 -----------------------
17315 -- Relative_Deadline --
17316 -----------------------
17318 -- pragma Relative_Deadline (time_span_EXPRESSION);
17320 when Pragma_Relative_Deadline => Relative_Deadline : declare
17321 P : constant Node_Id := Parent (N);
17326 Check_No_Identifiers;
17327 Check_Arg_Count (1);
17329 Arg := Get_Pragma_Arg (Arg1);
17331 -- The expression must be analyzed in the special manner described
17332 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
17334 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
17338 if Nkind (P) = N_Subprogram_Body then
17339 Check_In_Main_Program;
17341 -- Only Task and subprogram cases allowed
17343 elsif Nkind (P) /= N_Task_Definition then
17347 -- Check duplicate pragma before we set the corresponding flag
17349 if Has_Relative_Deadline_Pragma (P) then
17350 Error_Pragma ("duplicate pragma% not allowed");
17353 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
17354 -- Relative_Deadline pragma node cannot be inserted in the Rep
17355 -- Item chain of Ent since it is rewritten by the expander as a
17356 -- procedure call statement that will break the chain.
17358 Set_Has_Relative_Deadline_Pragma (P, True);
17359 end Relative_Deadline;
17361 ------------------------
17362 -- Remote_Access_Type --
17363 ------------------------
17365 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
17367 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
17372 Check_Arg_Count (1);
17373 Check_Optional_Identifier (Arg1, Name_Entity);
17374 Check_Arg_Is_Local_Name (Arg1);
17376 E := Entity (Get_Pragma_Arg (Arg1));
17378 if Nkind (Parent (E)) = N_Formal_Type_Declaration
17379 and then Ekind (E) = E_General_Access_Type
17380 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
17381 and then Scope (Root_Type (Directly_Designated_Type (E)))
17383 and then Is_Valid_Remote_Object_Type
17384 (Root_Type (Directly_Designated_Type (E)))
17386 Set_Is_Remote_Types (E);
17390 ("pragma% applies only to formal access to classwide types",
17393 end Remote_Access_Type;
17395 ---------------------------
17396 -- Remote_Call_Interface --
17397 ---------------------------
17399 -- pragma Remote_Call_Interface [(library_unit_NAME)];
17401 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
17402 Cunit_Node : Node_Id;
17403 Cunit_Ent : Entity_Id;
17407 Check_Ada_83_Warning;
17408 Check_Valid_Library_Unit_Pragma;
17410 if Nkind (N) = N_Null_Statement then
17414 Cunit_Node := Cunit (Current_Sem_Unit);
17415 K := Nkind (Unit (Cunit_Node));
17416 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17418 if K = N_Package_Declaration
17419 or else K = N_Generic_Package_Declaration
17420 or else K = N_Subprogram_Declaration
17421 or else K = N_Generic_Subprogram_Declaration
17422 or else (K = N_Subprogram_Body
17423 and then Acts_As_Spec (Unit (Cunit_Node)))
17428 "pragma% must apply to package or subprogram declaration");
17431 Set_Is_Remote_Call_Interface (Cunit_Ent);
17432 end Remote_Call_Interface;
17438 -- pragma Remote_Types [(library_unit_NAME)];
17440 when Pragma_Remote_Types => Remote_Types : declare
17441 Cunit_Node : Node_Id;
17442 Cunit_Ent : Entity_Id;
17445 Check_Ada_83_Warning;
17446 Check_Valid_Library_Unit_Pragma;
17448 if Nkind (N) = N_Null_Statement then
17452 Cunit_Node := Cunit (Current_Sem_Unit);
17453 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17455 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17456 N_Generic_Package_Declaration)
17459 ("pragma% can only apply to a package declaration");
17462 Set_Is_Remote_Types (Cunit_Ent);
17469 -- pragma Ravenscar;
17471 when Pragma_Ravenscar =>
17473 Check_Arg_Count (0);
17474 Check_Valid_Configuration_Pragma;
17475 Set_Ravenscar_Profile (N);
17477 if Warn_On_Obsolescent_Feature then
17479 ("pragma Ravenscar is an obsolescent feature?j?", N);
17481 ("|use pragma Profile (Ravenscar) instead?j?", N);
17484 -------------------------
17485 -- Restricted_Run_Time --
17486 -------------------------
17488 -- pragma Restricted_Run_Time;
17490 when Pragma_Restricted_Run_Time =>
17492 Check_Arg_Count (0);
17493 Check_Valid_Configuration_Pragma;
17494 Set_Profile_Restrictions
17495 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
17497 if Warn_On_Obsolescent_Feature then
17499 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
17502 ("|use pragma Profile (Restricted) instead?j?", N);
17509 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
17512 -- restriction_IDENTIFIER
17513 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17515 when Pragma_Restrictions =>
17516 Process_Restrictions_Or_Restriction_Warnings
17517 (Warn => Treat_Restrictions_As_Warnings);
17519 --------------------------
17520 -- Restriction_Warnings --
17521 --------------------------
17523 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
17526 -- restriction_IDENTIFIER
17527 -- | restriction_parameter_IDENTIFIER => EXPRESSION
17529 when Pragma_Restriction_Warnings =>
17531 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
17537 -- pragma Reviewable;
17539 when Pragma_Reviewable =>
17540 Check_Ada_83_Warning;
17541 Check_Arg_Count (0);
17543 -- Call dummy debugging function rv. This is done to assist front
17544 -- end debugging. By placing a Reviewable pragma in the source
17545 -- program, a breakpoint on rv catches this place in the source,
17546 -- allowing convenient stepping to the point of interest.
17550 --------------------------
17551 -- Short_Circuit_And_Or --
17552 --------------------------
17554 -- pragma Short_Circuit_And_Or;
17556 when Pragma_Short_Circuit_And_Or =>
17558 Check_Arg_Count (0);
17559 Check_Valid_Configuration_Pragma;
17560 Short_Circuit_And_Or := True;
17562 -------------------
17563 -- Share_Generic --
17564 -------------------
17566 -- pragma Share_Generic (GNAME {, GNAME});
17568 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
17570 when Pragma_Share_Generic =>
17572 Process_Generic_List;
17578 -- pragma Shared (LOCAL_NAME);
17580 when Pragma_Shared =>
17582 Process_Atomic_Shared_Volatile;
17584 --------------------
17585 -- Shared_Passive --
17586 --------------------
17588 -- pragma Shared_Passive [(library_unit_NAME)];
17590 -- Set the flag Is_Shared_Passive of program unit name entity
17592 when Pragma_Shared_Passive => Shared_Passive : declare
17593 Cunit_Node : Node_Id;
17594 Cunit_Ent : Entity_Id;
17597 Check_Ada_83_Warning;
17598 Check_Valid_Library_Unit_Pragma;
17600 if Nkind (N) = N_Null_Statement then
17604 Cunit_Node := Cunit (Current_Sem_Unit);
17605 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
17607 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
17608 N_Generic_Package_Declaration)
17611 ("pragma% can only apply to a package declaration");
17614 Set_Is_Shared_Passive (Cunit_Ent);
17615 end Shared_Passive;
17617 -----------------------
17618 -- Short_Descriptors --
17619 -----------------------
17621 -- pragma Short_Descriptors;
17623 when Pragma_Short_Descriptors =>
17625 Check_Arg_Count (0);
17626 Check_Valid_Configuration_Pragma;
17627 Short_Descriptors := True;
17629 ------------------------------
17630 -- Simple_Storage_Pool_Type --
17631 ------------------------------
17633 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
17635 when Pragma_Simple_Storage_Pool_Type =>
17636 Simple_Storage_Pool_Type : declare
17642 Check_Arg_Count (1);
17643 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17645 Type_Id := Get_Pragma_Arg (Arg1);
17646 Find_Type (Type_Id);
17647 Typ := Entity (Type_Id);
17649 if Typ = Any_Type then
17653 -- We require the pragma to apply to a type declared in a package
17654 -- declaration, but not (immediately) within a package body.
17656 if Ekind (Current_Scope) /= E_Package
17657 or else In_Package_Body (Current_Scope)
17660 ("pragma% can only apply to type declared immediately "
17661 & "within a package declaration");
17664 -- A simple storage pool type must be an immutably limited record
17665 -- or private type. If the pragma is given for a private type,
17666 -- the full type is similarly restricted (which is checked later
17667 -- in Freeze_Entity).
17669 if Is_Record_Type (Typ)
17670 and then not Is_Limited_View (Typ)
17673 ("pragma% can only apply to explicitly limited record type");
17675 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
17677 ("pragma% can only apply to a private type that is limited");
17679 elsif not Is_Record_Type (Typ)
17680 and then not Is_Private_Type (Typ)
17683 ("pragma% can only apply to limited record or private type");
17686 Record_Rep_Item (Typ, N);
17687 end Simple_Storage_Pool_Type;
17689 ----------------------
17690 -- Source_File_Name --
17691 ----------------------
17693 -- There are five forms for this pragma:
17695 -- pragma Source_File_Name (
17696 -- [UNIT_NAME =>] unit_NAME,
17697 -- BODY_FILE_NAME => STRING_LITERAL
17698 -- [, [INDEX =>] INTEGER_LITERAL]);
17700 -- pragma Source_File_Name (
17701 -- [UNIT_NAME =>] unit_NAME,
17702 -- SPEC_FILE_NAME => STRING_LITERAL
17703 -- [, [INDEX =>] INTEGER_LITERAL]);
17705 -- pragma Source_File_Name (
17706 -- BODY_FILE_NAME => STRING_LITERAL
17707 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17708 -- [, CASING => CASING_SPEC]);
17710 -- pragma Source_File_Name (
17711 -- SPEC_FILE_NAME => STRING_LITERAL
17712 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17713 -- [, CASING => CASING_SPEC]);
17715 -- pragma Source_File_Name (
17716 -- SUBUNIT_FILE_NAME => STRING_LITERAL
17717 -- [, DOT_REPLACEMENT => STRING_LITERAL]
17718 -- [, CASING => CASING_SPEC]);
17720 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
17722 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
17723 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
17724 -- only be used when no project file is used, while SFNP can only be
17725 -- used when a project file is used.
17727 -- No processing here. Processing was completed during parsing, since
17728 -- we need to have file names set as early as possible. Units are
17729 -- loaded well before semantic processing starts.
17731 -- The only processing we defer to this point is the check for
17732 -- correct placement.
17734 when Pragma_Source_File_Name =>
17736 Check_Valid_Configuration_Pragma;
17738 ------------------------------
17739 -- Source_File_Name_Project --
17740 ------------------------------
17742 -- See Source_File_Name for syntax
17744 -- No processing here. Processing was completed during parsing, since
17745 -- we need to have file names set as early as possible. Units are
17746 -- loaded well before semantic processing starts.
17748 -- The only processing we defer to this point is the check for
17749 -- correct placement.
17751 when Pragma_Source_File_Name_Project =>
17753 Check_Valid_Configuration_Pragma;
17755 -- Check that a pragma Source_File_Name_Project is used only in a
17756 -- configuration pragmas file.
17758 -- Pragmas Source_File_Name_Project should only be generated by
17759 -- the Project Manager in configuration pragmas files.
17761 -- This is really an ugly test. It seems to depend on some
17762 -- accidental and undocumented property. At the very least it
17763 -- needs to be documented, but it would be better to have a
17764 -- clean way of testing if we are in a configuration file???
17766 if Present (Parent (N)) then
17768 ("pragma% can only appear in a configuration pragmas file");
17771 ----------------------
17772 -- Source_Reference --
17773 ----------------------
17775 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
17777 -- Nothing to do, all processing completed in Par.Prag, since we need
17778 -- the information for possible parser messages that are output.
17780 when Pragma_Source_Reference =>
17787 -- pragma SPARK_Mode [(On | Off | Auto)];
17789 when Pragma_SPARK_Mode => SPARK_Mod : declare
17790 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id);
17791 -- Associate a SPARK_Mode pragma with the context where it lives.
17792 -- If the context is a package spec or a body, the routine checks
17793 -- the consistency between modes of visible/private declarations
17794 -- and body declarations/statements.
17796 procedure Check_Spark_Mode_Conformance
17797 (Governing_Id : Entity_Id;
17798 New_Id : Entity_Id);
17799 -- Verify the "monotonicity" of SPARK modes between two entities.
17800 -- The order of modes is Off < Auto < On. Governing_Id establishes
17801 -- the mode of the context. New_Id attempts to redefine the known
17804 procedure Check_Pragma_Conformance
17805 (Governing_Mode : Node_Id;
17806 New_Mode : Node_Id);
17807 -- Verify the "monotonicity" of two SPARK_Mode pragmas. The order
17808 -- of modes is Off < Auto < On. Governing_Mode is the established
17809 -- mode dictated by the context. New_Mode attempts to redefine the
17812 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id;
17813 -- Convert a value of type SPARK_Mode_Id into a corresponding name
17819 procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id) is
17820 Existing_Prag : constant Node_Id :=
17821 SPARK_Mode_Pragmas (Context);
17823 -- The context does not have a prior mode defined
17825 if No (Existing_Prag) then
17826 Set_SPARK_Mode_Pragmas (Context, Prag);
17828 -- Chain the new mode on the list of SPARK_Mode pragmas. Verify
17829 -- the consistency between the existing mode and the new one.
17832 Set_Next_Pragma (Existing_Prag, Prag);
17834 Check_Pragma_Conformance
17835 (Governing_Mode => Existing_Prag,
17840 ----------------------------------
17841 -- Check_Spark_Mode_Conformance --
17842 ----------------------------------
17844 procedure Check_Spark_Mode_Conformance
17845 (Governing_Id : Entity_Id;
17846 New_Id : Entity_Id)
17848 Gov_Prag : constant Node_Id :=
17849 SPARK_Mode_Pragmas (Governing_Id);
17850 New_Prag : constant Node_Id := SPARK_Mode_Pragmas (New_Id);
17853 -- Nothing to do when one or both entities lack a mode
17855 if No (Gov_Prag) or else No (New_Prag) then
17859 -- Do not compare the modes of a package spec and body when the
17860 -- spec mode appears in the private part. In this case the spec
17861 -- mode does not affect the body.
17863 if Ekind_In (Governing_Id, E_Generic_Package, E_Package)
17864 and then Ekind (New_Id) = E_Package_Body
17865 and then Is_Private_SPARK_Mode (Gov_Prag)
17869 -- Test the pragmas
17872 Check_Pragma_Conformance
17873 (Governing_Mode => Gov_Prag,
17874 New_Mode => New_Prag);
17876 end Check_Spark_Mode_Conformance;
17878 ------------------------------
17879 -- Check_Pragma_Conformance --
17880 ------------------------------
17882 procedure Check_Pragma_Conformance
17883 (Governing_Mode : Node_Id;
17884 New_Mode : Node_Id)
17886 Gov_M : constant SPARK_Mode_Id :=
17887 Get_SPARK_Mode_Id (Governing_Mode);
17888 New_M : constant SPARK_Mode_Id := Get_SPARK_Mode_Id (New_Mode);
17891 -- The new mode is less restrictive than the established mode
17893 if Gov_M < New_M then
17894 Error_Msg_Name_1 := Get_SPARK_Mode_Name (New_M);
17895 Error_Msg_N ("cannot define 'S'P'A'R'K mode %", New_Mode);
17897 Error_Msg_Name_1 := Get_SPARK_Mode_Name (Gov_M);
17898 Error_Msg_Sloc := Sloc (Governing_Mode);
17900 ("\mode is less restrictive than mode % defined #",
17903 end Check_Pragma_Conformance;
17905 -------------------------
17906 -- Get_SPARK_Mode_Name --
17907 -------------------------
17909 function Get_SPARK_Mode_Name (Id : SPARK_Mode_Id) return Name_Id is
17911 if Id = SPARK_On then
17913 elsif Id = SPARK_Off then
17915 elsif Id = SPARK_Auto then
17918 -- Mode "None" should never be used in error message generation
17921 raise Program_Error;
17923 end Get_SPARK_Mode_Name;
17927 Body_Id : Entity_Id;
17930 Mode_Id : SPARK_Mode_Id;
17931 Spec_Id : Entity_Id;
17934 -- Start of processing for SPARK_Mode
17938 Check_No_Identifiers;
17939 Check_At_Most_N_Arguments (1);
17941 -- Check the legality of the mode
17943 if Arg_Count = 1 then
17944 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_Auto);
17945 Mode := Chars (Get_Pragma_Arg (Arg1));
17947 -- A SPARK_Mode without an argument defaults to "On"
17953 Mode_Id := Get_SPARK_Mode_Id (Mode);
17954 Context := Parent (N);
17956 -- The pragma appears in a configuration file
17958 if No (Context) then
17959 Check_Valid_Configuration_Pragma;
17960 Global_SPARK_Mode := Mode_Id;
17962 -- When the pragma is placed before the declaration of a unit, it
17963 -- configures the whole unit.
17965 elsif Nkind (Context) = N_Compilation_Unit then
17966 Check_Valid_Configuration_Pragma;
17967 Set_SPARK_Mode_Pragma (Current_Sem_Unit, N);
17969 -- The pragma applies to a [library unit] subprogram or package
17972 -- Mode "Auto" cannot be used in nested subprograms or packages
17974 if Mode_Id = SPARK_Auto then
17976 ("mode `Auto` can only apply to the configuration variant "
17977 & "of pragma %", Arg1);
17980 -- Verify the placement of the pragma with respect to package
17981 -- or subprogram declarations and detect duplicates.
17984 while Present (Stmt) loop
17986 -- Skip prior pragmas, but check for duplicates
17988 if Nkind (Stmt) = N_Pragma then
17989 if Pragma_Name (Stmt) = Pname then
17990 Error_Msg_Name_1 := Pname;
17991 Error_Msg_Sloc := Sloc (Stmt);
17993 ("pragma % duplicates pragma declared #", N);
17996 -- Skip internally generated code
17998 elsif not Comes_From_Source (Stmt) then
18001 -- The pragma applies to a package or subprogram declaration
18003 elsif Nkind_In (Stmt, N_Generic_Package_Declaration,
18004 N_Generic_Subprogram_Declaration,
18005 N_Package_Declaration,
18006 N_Subprogram_Declaration)
18008 Spec_Id := Defining_Unit_Name (Specification (Stmt));
18009 Chain_Pragma (Spec_Id, N);
18012 -- The pragma does not apply to a legal construct, issue an
18013 -- error and stop the analysis.
18020 Stmt := Prev (Stmt);
18023 -- Handle all cases where the pragma is actually an aspect and
18024 -- applies to a library-level package spec, body or subprogram.
18026 -- function F ... with SPARK_Mode => ...;
18027 -- package P with SPARK_Mode => ...;
18028 -- package body P with SPARK_Mode => ... is
18030 -- The following circuitry simply prepares the proper context
18031 -- for the general pragma processing mechanism below.
18033 if Nkind (Context) = N_Compilation_Unit_Aux then
18034 Context := Unit (Parent (Context));
18036 if Nkind_In (Context, N_Package_Declaration,
18037 N_Subprogram_Declaration)
18039 Context := Specification (Context);
18043 -- The pragma is at the top level of a package spec or appears
18044 -- as an aspect on a subprogram.
18046 -- function F ... with SPARK_Mode => ...;
18049 -- pragma SPARK_Mode;
18051 if Nkind_In (Context, N_Function_Specification,
18052 N_Package_Specification,
18053 N_Procedure_Specification)
18055 Spec_Id := Defining_Unit_Name (Context);
18056 Chain_Pragma (Spec_Id, N);
18058 -- The pragma is immediately within a package or subprogram
18061 -- function F ... is
18062 -- pragma SPARK_Mode;
18064 -- package body P is
18065 -- pragma SPARK_Mode;
18067 elsif Nkind_In (Context, N_Package_Body,
18070 Spec_Id := Corresponding_Spec (Context);
18072 if Nkind (Context) = N_Subprogram_Body then
18073 Context := Specification (Context);
18076 Body_Id := Defining_Unit_Name (Context);
18078 Chain_Pragma (Body_Id, N);
18080 -- Verify that the SPARK modes are consistent between
18081 -- body and spec, if any.
18083 if Present (Spec_Id) then
18084 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
18087 -- The pragma applies to the statements of a package body
18089 -- package body P is
18091 -- pragma SPARK_Mode;
18093 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
18094 and then Nkind (Parent (Context)) = N_Package_Body
18096 Context := Parent (Context);
18097 Spec_Id := Corresponding_Spec (Context);
18098 Body_Id := Defining_Unit_Name (Context);
18100 Chain_Pragma (Body_Id, N);
18101 Check_Spark_Mode_Conformance (Spec_Id, Body_Id);
18103 -- The pragma does not apply to a legal construct, issue error
18111 --------------------------------
18112 -- Static_Elaboration_Desired --
18113 --------------------------------
18115 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
18117 when Pragma_Static_Elaboration_Desired =>
18119 Check_At_Most_N_Arguments (1);
18121 if Is_Compilation_Unit (Current_Scope)
18122 and then Ekind (Current_Scope) = E_Package
18124 Set_Static_Elaboration_Desired (Current_Scope, True);
18126 Error_Pragma ("pragma% must apply to a library-level package");
18133 -- pragma Storage_Size (EXPRESSION);
18135 when Pragma_Storage_Size => Storage_Size : declare
18136 P : constant Node_Id := Parent (N);
18140 Check_No_Identifiers;
18141 Check_Arg_Count (1);
18143 -- The expression must be analyzed in the special manner described
18144 -- in "Handling of Default Expressions" in sem.ads.
18146 Arg := Get_Pragma_Arg (Arg1);
18147 Preanalyze_Spec_Expression (Arg, Any_Integer);
18149 if not Is_Static_Expression (Arg) then
18150 Check_Restriction (Static_Storage_Size, Arg);
18153 if Nkind (P) /= N_Task_Definition then
18158 if Has_Storage_Size_Pragma (P) then
18159 Error_Pragma ("duplicate pragma% not allowed");
18161 Set_Has_Storage_Size_Pragma (P, True);
18164 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
18172 -- pragma Storage_Unit (NUMERIC_LITERAL);
18174 -- Only permitted argument is System'Storage_Unit value
18176 when Pragma_Storage_Unit =>
18177 Check_No_Identifiers;
18178 Check_Arg_Count (1);
18179 Check_Arg_Is_Integer_Literal (Arg1);
18181 if Intval (Get_Pragma_Arg (Arg1)) /=
18182 UI_From_Int (Ttypes.System_Storage_Unit)
18184 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
18186 ("the only allowed argument for pragma% is ^", Arg1);
18189 --------------------
18190 -- Stream_Convert --
18191 --------------------
18193 -- pragma Stream_Convert (
18194 -- [Entity =>] type_LOCAL_NAME,
18195 -- [Read =>] function_NAME,
18196 -- [Write =>] function NAME);
18198 when Pragma_Stream_Convert => Stream_Convert : declare
18200 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
18201 -- Check that the given argument is the name of a local function
18202 -- of one argument that is not overloaded earlier in the current
18203 -- local scope. A check is also made that the argument is a
18204 -- function with one parameter.
18206 --------------------------------------
18207 -- Check_OK_Stream_Convert_Function --
18208 --------------------------------------
18210 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
18214 Check_Arg_Is_Local_Name (Arg);
18215 Ent := Entity (Get_Pragma_Arg (Arg));
18217 if Has_Homonym (Ent) then
18219 ("argument for pragma% may not be overloaded", Arg);
18222 if Ekind (Ent) /= E_Function
18223 or else No (First_Formal (Ent))
18224 or else Present (Next_Formal (First_Formal (Ent)))
18227 ("argument for pragma% must be function of one argument",
18230 end Check_OK_Stream_Convert_Function;
18232 -- Start of processing for Stream_Convert
18236 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
18237 Check_Arg_Count (3);
18238 Check_Optional_Identifier (Arg1, Name_Entity);
18239 Check_Optional_Identifier (Arg2, Name_Read);
18240 Check_Optional_Identifier (Arg3, Name_Write);
18241 Check_Arg_Is_Local_Name (Arg1);
18242 Check_OK_Stream_Convert_Function (Arg2);
18243 Check_OK_Stream_Convert_Function (Arg3);
18246 Typ : constant Entity_Id :=
18247 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
18248 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
18249 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
18252 Check_First_Subtype (Arg1);
18254 -- Check for too early or too late. Note that we don't enforce
18255 -- the rule about primitive operations in this case, since, as
18256 -- is the case for explicit stream attributes themselves, these
18257 -- restrictions are not appropriate. Note that the chaining of
18258 -- the pragma by Rep_Item_Too_Late is actually the critical
18259 -- processing done for this pragma.
18261 if Rep_Item_Too_Early (Typ, N)
18263 Rep_Item_Too_Late (Typ, N, FOnly => True)
18268 -- Return if previous error
18270 if Etype (Typ) = Any_Type
18272 Etype (Read) = Any_Type
18274 Etype (Write) = Any_Type
18281 if Underlying_Type (Etype (Read)) /= Typ then
18283 ("incorrect return type for function&", Arg2);
18286 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
18288 ("incorrect parameter type for function&", Arg3);
18291 if Underlying_Type (Etype (First_Formal (Read))) /=
18292 Underlying_Type (Etype (Write))
18295 ("result type of & does not match Read parameter type",
18299 end Stream_Convert;
18305 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
18307 -- This is processed by the parser since some of the style checks
18308 -- take place during source scanning and parsing. This means that
18309 -- we don't need to issue error messages here.
18311 when Pragma_Style_Checks => Style_Checks : declare
18312 A : constant Node_Id := Get_Pragma_Arg (Arg1);
18318 Check_No_Identifiers;
18320 -- Two argument form
18322 if Arg_Count = 2 then
18323 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18330 E_Id := Get_Pragma_Arg (Arg2);
18333 if not Is_Entity_Name (E_Id) then
18335 ("second argument of pragma% must be entity name",
18339 E := Entity (E_Id);
18341 if not Ignore_Style_Checks_Pragmas then
18346 Set_Suppress_Style_Checks
18347 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
18348 exit when No (Homonym (E));
18355 -- One argument form
18358 Check_Arg_Count (1);
18360 if Nkind (A) = N_String_Literal then
18364 Slen : constant Natural := Natural (String_Length (S));
18365 Options : String (1 .. Slen);
18371 C := Get_String_Char (S, Int (J));
18372 exit when not In_Character_Range (C);
18373 Options (J) := Get_Character (C);
18375 -- If at end of string, set options. As per discussion
18376 -- above, no need to check for errors, since we issued
18377 -- them in the parser.
18380 if not Ignore_Style_Checks_Pragmas then
18381 Set_Style_Check_Options (Options);
18391 elsif Nkind (A) = N_Identifier then
18392 if Chars (A) = Name_All_Checks then
18393 if not Ignore_Style_Checks_Pragmas then
18395 Set_GNAT_Style_Check_Options;
18397 Set_Default_Style_Check_Options;
18401 elsif Chars (A) = Name_On then
18402 if not Ignore_Style_Checks_Pragmas then
18403 Style_Check := True;
18406 elsif Chars (A) = Name_Off then
18407 if not Ignore_Style_Checks_Pragmas then
18408 Style_Check := False;
18419 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
18421 when Pragma_Subtitle =>
18423 Check_Arg_Count (1);
18424 Check_Optional_Identifier (Arg1, Name_Subtitle);
18425 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
18432 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
18434 when Pragma_Suppress =>
18435 Process_Suppress_Unsuppress (True);
18441 -- pragma Suppress_All;
18443 -- The only check made here is that the pragma has no arguments.
18444 -- There are no placement rules, and the processing required (setting
18445 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
18446 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
18447 -- then creates and inserts a pragma Suppress (All_Checks).
18449 when Pragma_Suppress_All =>
18451 Check_Arg_Count (0);
18453 -------------------------
18454 -- Suppress_Debug_Info --
18455 -------------------------
18457 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
18459 when Pragma_Suppress_Debug_Info =>
18461 Check_Arg_Count (1);
18462 Check_Optional_Identifier (Arg1, Name_Entity);
18463 Check_Arg_Is_Local_Name (Arg1);
18464 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
18466 ----------------------------------
18467 -- Suppress_Exception_Locations --
18468 ----------------------------------
18470 -- pragma Suppress_Exception_Locations;
18472 when Pragma_Suppress_Exception_Locations =>
18474 Check_Arg_Count (0);
18475 Check_Valid_Configuration_Pragma;
18476 Exception_Locations_Suppressed := True;
18478 -----------------------------
18479 -- Suppress_Initialization --
18480 -----------------------------
18482 -- pragma Suppress_Initialization ([Entity =>] type_Name);
18484 when Pragma_Suppress_Initialization => Suppress_Init : declare
18490 Check_Arg_Count (1);
18491 Check_Optional_Identifier (Arg1, Name_Entity);
18492 Check_Arg_Is_Local_Name (Arg1);
18494 E_Id := Get_Pragma_Arg (Arg1);
18496 if Etype (E_Id) = Any_Type then
18500 E := Entity (E_Id);
18502 if not Is_Type (E) then
18503 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
18506 if Rep_Item_Too_Early (E, N)
18508 Rep_Item_Too_Late (E, N, FOnly => True)
18513 -- For incomplete/private type, set flag on full view
18515 if Is_Incomplete_Or_Private_Type (E) then
18516 if No (Full_View (Base_Type (E))) then
18518 ("argument of pragma% cannot be an incomplete type", Arg1);
18520 Set_Suppress_Initialization (Full_View (Base_Type (E)));
18523 -- For first subtype, set flag on base type
18525 elsif Is_First_Subtype (E) then
18526 Set_Suppress_Initialization (Base_Type (E));
18528 -- For other than first subtype, set flag on subtype itself
18531 Set_Suppress_Initialization (E);
18539 -- pragma System_Name (DIRECT_NAME);
18541 -- Syntax check: one argument, which must be the identifier GNAT or
18542 -- the identifier GCC, no other identifiers are acceptable.
18544 when Pragma_System_Name =>
18546 Check_No_Identifiers;
18547 Check_Arg_Count (1);
18548 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
18550 -----------------------------
18551 -- Task_Dispatching_Policy --
18552 -----------------------------
18554 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
18556 when Pragma_Task_Dispatching_Policy => declare
18560 Check_Ada_83_Warning;
18561 Check_Arg_Count (1);
18562 Check_No_Identifiers;
18563 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18564 Check_Valid_Configuration_Pragma;
18565 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18566 DP := Fold_Upper (Name_Buffer (1));
18568 if Task_Dispatching_Policy /= ' '
18569 and then Task_Dispatching_Policy /= DP
18571 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18573 ("task dispatching policy incompatible with policy#");
18575 -- Set new policy, but always preserve System_Location since we
18576 -- like the error message with the run time name.
18579 Task_Dispatching_Policy := DP;
18581 if Task_Dispatching_Policy_Sloc /= System_Location then
18582 Task_Dispatching_Policy_Sloc := Loc;
18591 -- pragma Task_Info (EXPRESSION);
18593 when Pragma_Task_Info => Task_Info : declare
18594 P : constant Node_Id := Parent (N);
18600 if Nkind (P) /= N_Task_Definition then
18601 Error_Pragma ("pragma% must appear in task definition");
18604 Check_No_Identifiers;
18605 Check_Arg_Count (1);
18607 Analyze_And_Resolve
18608 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
18610 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
18614 Ent := Defining_Identifier (Parent (P));
18616 -- Check duplicate pragma before we chain the pragma in the Rep
18617 -- Item chain of Ent.
18620 (Ent, Name_Task_Info, Check_Parents => False)
18622 Error_Pragma ("duplicate pragma% not allowed");
18625 Record_Rep_Item (Ent, N);
18632 -- pragma Task_Name (string_EXPRESSION);
18634 when Pragma_Task_Name => Task_Name : declare
18635 P : constant Node_Id := Parent (N);
18640 Check_No_Identifiers;
18641 Check_Arg_Count (1);
18643 Arg := Get_Pragma_Arg (Arg1);
18645 -- The expression is used in the call to Create_Task, and must be
18646 -- expanded there, not in the context of the current spec. It must
18647 -- however be analyzed to capture global references, in case it
18648 -- appears in a generic context.
18650 Preanalyze_And_Resolve (Arg, Standard_String);
18652 if Nkind (P) /= N_Task_Definition then
18656 Ent := Defining_Identifier (Parent (P));
18658 -- Check duplicate pragma before we chain the pragma in the Rep
18659 -- Item chain of Ent.
18662 (Ent, Name_Task_Name, Check_Parents => False)
18664 Error_Pragma ("duplicate pragma% not allowed");
18667 Record_Rep_Item (Ent, N);
18674 -- pragma Task_Storage (
18675 -- [Task_Type =>] LOCAL_NAME,
18676 -- [Top_Guard =>] static_integer_EXPRESSION);
18678 when Pragma_Task_Storage => Task_Storage : declare
18679 Args : Args_List (1 .. 2);
18680 Names : constant Name_List (1 .. 2) := (
18684 Task_Type : Node_Id renames Args (1);
18685 Top_Guard : Node_Id renames Args (2);
18691 Gather_Associations (Names, Args);
18693 if No (Task_Type) then
18695 ("missing task_type argument for pragma%");
18698 Check_Arg_Is_Local_Name (Task_Type);
18700 Ent := Entity (Task_Type);
18702 if not Is_Task_Type (Ent) then
18704 ("argument for pragma% must be task type", Task_Type);
18707 if No (Top_Guard) then
18709 ("pragma% takes two arguments", Task_Type);
18711 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
18714 Check_First_Subtype (Task_Type);
18716 if Rep_Item_Too_Late (Ent, N) then
18725 -- pragma Test_Case
18726 -- ([Name =>] Static_String_EXPRESSION
18727 -- ,[Mode =>] MODE_TYPE
18728 -- [, Requires => Boolean_EXPRESSION]
18729 -- [, Ensures => Boolean_EXPRESSION]);
18731 -- MODE_TYPE ::= Nominal | Robustness
18733 when Pragma_Test_Case =>
18737 --------------------------
18738 -- Thread_Local_Storage --
18739 --------------------------
18741 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
18743 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
18749 Check_Arg_Count (1);
18750 Check_Optional_Identifier (Arg1, Name_Entity);
18751 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18753 Id := Get_Pragma_Arg (Arg1);
18756 if not Is_Entity_Name (Id)
18757 or else Ekind (Entity (Id)) /= E_Variable
18759 Error_Pragma_Arg ("local variable name required", Arg1);
18764 if Rep_Item_Too_Early (E, N)
18765 or else Rep_Item_Too_Late (E, N)
18770 Set_Has_Pragma_Thread_Local_Storage (E);
18771 Set_Has_Gigi_Rep_Item (E);
18772 end Thread_Local_Storage;
18778 -- pragma Time_Slice (static_duration_EXPRESSION);
18780 when Pragma_Time_Slice => Time_Slice : declare
18786 Check_Arg_Count (1);
18787 Check_No_Identifiers;
18788 Check_In_Main_Program;
18789 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
18791 if not Error_Posted (Arg1) then
18793 while Present (Nod) loop
18794 if Nkind (Nod) = N_Pragma
18795 and then Pragma_Name (Nod) = Name_Time_Slice
18797 Error_Msg_Name_1 := Pname;
18798 Error_Msg_N ("duplicate pragma% not permitted", Nod);
18805 -- Process only if in main unit
18807 if Get_Source_Unit (Loc) = Main_Unit then
18808 Opt.Time_Slice_Set := True;
18809 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
18811 if Val <= Ureal_0 then
18812 Opt.Time_Slice_Value := 0;
18814 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
18815 Opt.Time_Slice_Value := 1_000_000_000;
18818 Opt.Time_Slice_Value :=
18819 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
18828 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
18830 -- TITLING_OPTION ::=
18831 -- [Title =>] STRING_LITERAL
18832 -- | [Subtitle =>] STRING_LITERAL
18834 when Pragma_Title => Title : declare
18835 Args : Args_List (1 .. 2);
18836 Names : constant Name_List (1 .. 2) := (
18842 Gather_Associations (Names, Args);
18845 for J in 1 .. 2 loop
18846 if Present (Args (J)) then
18847 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
18852 ----------------------------
18853 -- Type_Invariant[_Class] --
18854 ----------------------------
18856 -- pragma Type_Invariant[_Class]
18857 -- ([Entity =>] type_LOCAL_NAME,
18858 -- [Check =>] EXPRESSION);
18860 when Pragma_Type_Invariant |
18861 Pragma_Type_Invariant_Class =>
18862 Type_Invariant : declare
18863 I_Pragma : Node_Id;
18866 Check_Arg_Count (2);
18868 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
18869 -- setting Class_Present for the Type_Invariant_Class case.
18871 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
18872 I_Pragma := New_Copy (N);
18873 Set_Pragma_Identifier
18874 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
18875 Rewrite (N, I_Pragma);
18876 Set_Analyzed (N, False);
18878 end Type_Invariant;
18880 ---------------------
18881 -- Unchecked_Union --
18882 ---------------------
18884 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
18886 when Pragma_Unchecked_Union => Unchecked_Union : declare
18887 Assoc : constant Node_Id := Arg1;
18888 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
18898 Check_No_Identifiers;
18899 Check_Arg_Count (1);
18900 Check_Arg_Is_Local_Name (Arg1);
18902 Find_Type (Type_Id);
18904 Typ := Entity (Type_Id);
18907 or else Rep_Item_Too_Early (Typ, N)
18911 Typ := Underlying_Type (Typ);
18914 if Rep_Item_Too_Late (Typ, N) then
18918 Check_First_Subtype (Arg1);
18920 -- Note remaining cases are references to a type in the current
18921 -- declarative part. If we find an error, we post the error on
18922 -- the relevant type declaration at an appropriate point.
18924 if not Is_Record_Type (Typ) then
18925 Error_Msg_N ("unchecked union must be record type", Typ);
18928 elsif Is_Tagged_Type (Typ) then
18929 Error_Msg_N ("unchecked union must not be tagged", Typ);
18932 elsif not Has_Discriminants (Typ) then
18934 ("unchecked union must have one discriminant", Typ);
18937 -- Note: in previous versions of GNAT we used to check for limited
18938 -- types and give an error, but in fact the standard does allow
18939 -- Unchecked_Union on limited types, so this check was removed.
18941 -- Similarly, GNAT used to require that all discriminants have
18942 -- default values, but this is not mandated by the RM.
18944 -- Proceed with basic error checks completed
18947 Tdef := Type_Definition (Declaration_Node (Typ));
18948 Clist := Component_List (Tdef);
18950 -- Check presence of component list and variant part
18952 if No (Clist) or else No (Variant_Part (Clist)) then
18954 ("unchecked union must have variant part", Tdef);
18958 -- Check components
18960 Comp := First (Component_Items (Clist));
18961 while Present (Comp) loop
18962 Check_Component (Comp, Typ);
18966 -- Check variant part
18968 Vpart := Variant_Part (Clist);
18970 Variant := First (Variants (Vpart));
18971 while Present (Variant) loop
18972 Check_Variant (Variant, Typ);
18977 Set_Is_Unchecked_Union (Typ);
18978 Set_Convention (Typ, Convention_C);
18979 Set_Has_Unchecked_Union (Base_Type (Typ));
18980 Set_Is_Unchecked_Union (Base_Type (Typ));
18981 end Unchecked_Union;
18983 ------------------------
18984 -- Unimplemented_Unit --
18985 ------------------------
18987 -- pragma Unimplemented_Unit;
18989 -- Note: this only gives an error if we are generating code, or if
18990 -- we are in a generic library unit (where the pragma appears in the
18991 -- body, not in the spec).
18993 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
18994 Cunitent : constant Entity_Id :=
18995 Cunit_Entity (Get_Source_Unit (Loc));
18996 Ent_Kind : constant Entity_Kind :=
19001 Check_Arg_Count (0);
19003 if Operating_Mode = Generate_Code
19004 or else Ent_Kind = E_Generic_Function
19005 or else Ent_Kind = E_Generic_Procedure
19006 or else Ent_Kind = E_Generic_Package
19008 Get_Name_String (Chars (Cunitent));
19009 Set_Casing (Mixed_Case);
19010 Write_Str (Name_Buffer (1 .. Name_Len));
19011 Write_Str (" is not supported in this configuration");
19013 raise Unrecoverable_Error;
19015 end Unimplemented_Unit;
19017 ------------------------
19018 -- Universal_Aliasing --
19019 ------------------------
19021 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
19023 when Pragma_Universal_Aliasing => Universal_Alias : declare
19028 Check_Arg_Count (1);
19029 Check_Optional_Identifier (Arg2, Name_Entity);
19030 Check_Arg_Is_Local_Name (Arg1);
19031 E_Id := Entity (Get_Pragma_Arg (Arg1));
19033 if E_Id = Any_Type then
19035 elsif No (E_Id) or else not Is_Type (E_Id) then
19036 Error_Pragma_Arg ("pragma% requires type", Arg1);
19039 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
19040 Record_Rep_Item (E_Id, N);
19041 end Universal_Alias;
19043 --------------------
19044 -- Universal_Data --
19045 --------------------
19047 -- pragma Universal_Data [(library_unit_NAME)];
19049 when Pragma_Universal_Data =>
19052 -- If this is a configuration pragma, then set the universal
19053 -- addressing option, otherwise confirm that the pragma satisfies
19054 -- the requirements of library unit pragma placement and leave it
19055 -- to the GNAAMP back end to detect the pragma (avoids transitive
19056 -- setting of the option due to withed units).
19058 if Is_Configuration_Pragma then
19059 Universal_Addressing_On_AAMP := True;
19061 Check_Valid_Library_Unit_Pragma;
19064 if not AAMP_On_Target then
19065 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
19072 -- pragma Unmodified (local_Name {, local_Name});
19074 when Pragma_Unmodified => Unmodified : declare
19075 Arg_Node : Node_Id;
19076 Arg_Expr : Node_Id;
19077 Arg_Ent : Entity_Id;
19081 Check_At_Least_N_Arguments (1);
19083 -- Loop through arguments
19086 while Present (Arg_Node) loop
19087 Check_No_Identifier (Arg_Node);
19089 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
19090 -- in fact generate reference, so that the entity will have a
19091 -- reference, which will inhibit any warnings about it not
19092 -- being referenced, and also properly show up in the ali file
19093 -- as a reference. But this reference is recorded before the
19094 -- Has_Pragma_Unreferenced flag is set, so that no warning is
19095 -- generated for this reference.
19097 Check_Arg_Is_Local_Name (Arg_Node);
19098 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19100 if Is_Entity_Name (Arg_Expr) then
19101 Arg_Ent := Entity (Arg_Expr);
19103 if not Is_Assignable (Arg_Ent) then
19105 ("pragma% can only be applied to a variable",
19108 Set_Has_Pragma_Unmodified (Arg_Ent);
19120 -- pragma Unreferenced (local_Name {, local_Name});
19122 -- or when used in a context clause:
19124 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
19126 when Pragma_Unreferenced => Unreferenced : declare
19127 Arg_Node : Node_Id;
19128 Arg_Expr : Node_Id;
19129 Arg_Ent : Entity_Id;
19134 Check_At_Least_N_Arguments (1);
19136 -- Check case of appearing within context clause
19138 if Is_In_Context_Clause then
19140 -- The arguments must all be units mentioned in a with clause
19141 -- in the same context clause. Note we already checked (in
19142 -- Par.Prag) that the arguments are either identifiers or
19143 -- selected components.
19146 while Present (Arg_Node) loop
19147 Citem := First (List_Containing (N));
19148 while Citem /= N loop
19149 if Nkind (Citem) = N_With_Clause
19151 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
19153 Set_Has_Pragma_Unreferenced
19156 (Library_Unit (Citem))));
19158 (Get_Pragma_Arg (Arg_Node), Name (Citem));
19167 ("argument of pragma% is not withed unit", Arg_Node);
19173 -- Case of not in list of context items
19177 while Present (Arg_Node) loop
19178 Check_No_Identifier (Arg_Node);
19180 -- Note: the analyze call done by Check_Arg_Is_Local_Name
19181 -- will in fact generate reference, so that the entity will
19182 -- have a reference, which will inhibit any warnings about
19183 -- it not being referenced, and also properly show up in the
19184 -- ali file as a reference. But this reference is recorded
19185 -- before the Has_Pragma_Unreferenced flag is set, so that
19186 -- no warning is generated for this reference.
19188 Check_Arg_Is_Local_Name (Arg_Node);
19189 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19191 if Is_Entity_Name (Arg_Expr) then
19192 Arg_Ent := Entity (Arg_Expr);
19194 -- If the entity is overloaded, the pragma applies to the
19195 -- most recent overloading, as documented. In this case,
19196 -- name resolution does not generate a reference, so it
19197 -- must be done here explicitly.
19199 if Is_Overloaded (Arg_Expr) then
19200 Generate_Reference (Arg_Ent, N);
19203 Set_Has_Pragma_Unreferenced (Arg_Ent);
19211 --------------------------
19212 -- Unreferenced_Objects --
19213 --------------------------
19215 -- pragma Unreferenced_Objects (local_Name {, local_Name});
19217 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
19218 Arg_Node : Node_Id;
19219 Arg_Expr : Node_Id;
19223 Check_At_Least_N_Arguments (1);
19226 while Present (Arg_Node) loop
19227 Check_No_Identifier (Arg_Node);
19228 Check_Arg_Is_Local_Name (Arg_Node);
19229 Arg_Expr := Get_Pragma_Arg (Arg_Node);
19231 if not Is_Entity_Name (Arg_Expr)
19232 or else not Is_Type (Entity (Arg_Expr))
19235 ("argument for pragma% must be type or subtype", Arg_Node);
19238 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
19241 end Unreferenced_Objects;
19243 ------------------------------
19244 -- Unreserve_All_Interrupts --
19245 ------------------------------
19247 -- pragma Unreserve_All_Interrupts;
19249 when Pragma_Unreserve_All_Interrupts =>
19251 Check_Arg_Count (0);
19253 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
19254 Unreserve_All_Interrupts := True;
19261 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
19263 when Pragma_Unsuppress =>
19265 Process_Suppress_Unsuppress (False);
19267 -------------------
19268 -- Use_VADS_Size --
19269 -------------------
19271 -- pragma Use_VADS_Size;
19273 when Pragma_Use_VADS_Size =>
19275 Check_Arg_Count (0);
19276 Check_Valid_Configuration_Pragma;
19277 Use_VADS_Size := True;
19279 ---------------------
19280 -- Validity_Checks --
19281 ---------------------
19283 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
19285 when Pragma_Validity_Checks => Validity_Checks : declare
19286 A : constant Node_Id := Get_Pragma_Arg (Arg1);
19292 Check_Arg_Count (1);
19293 Check_No_Identifiers;
19295 if Nkind (A) = N_String_Literal then
19299 Slen : constant Natural := Natural (String_Length (S));
19300 Options : String (1 .. Slen);
19306 C := Get_String_Char (S, Int (J));
19307 exit when not In_Character_Range (C);
19308 Options (J) := Get_Character (C);
19311 Set_Validity_Check_Options (Options);
19319 elsif Nkind (A) = N_Identifier then
19320 if Chars (A) = Name_All_Checks then
19321 Set_Validity_Check_Options ("a");
19322 elsif Chars (A) = Name_On then
19323 Validity_Checks_On := True;
19324 elsif Chars (A) = Name_Off then
19325 Validity_Checks_On := False;
19328 end Validity_Checks;
19334 -- pragma Volatile (LOCAL_NAME);
19336 when Pragma_Volatile =>
19337 Process_Atomic_Shared_Volatile;
19339 -------------------------
19340 -- Volatile_Components --
19341 -------------------------
19343 -- pragma Volatile_Components (array_LOCAL_NAME);
19345 -- Volatile is handled by the same circuit as Atomic_Components
19351 -- pragma Warnings (On | Off [,REASON]);
19352 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
19353 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
19354 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
19356 -- REASON ::= Reason => Static_String_Expression
19358 when Pragma_Warnings => Warnings : begin
19360 Check_At_Least_N_Arguments (1);
19362 -- See if last argument is labeled Reason. If so, make sure we
19363 -- have a static string expression, but otherwise just ignore
19364 -- the REASON argument by decreasing Num_Args by 1 (all the
19365 -- remaining tests look only at the first Num_Args arguments).
19368 Last_Arg : constant Node_Id :=
19369 Last (Pragma_Argument_Associations (N));
19371 if Nkind (Last_Arg) = N_Pragma_Argument_Association
19372 and then Chars (Last_Arg) = Name_Reason
19374 Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
19375 Arg_Count := Arg_Count - 1;
19377 -- Not allowed in compiler units (bootstrap issues)
19379 Check_Compiler_Unit (N);
19383 -- Now proceed with REASON taken care of and eliminated
19385 Check_No_Identifiers;
19387 -- If debug flag -gnatd.i is set, pragma is ignored
19389 if Debug_Flag_Dot_I then
19393 -- Process various forms of the pragma
19396 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19399 -- One argument case
19401 if Arg_Count = 1 then
19403 -- On/Off one argument case was processed by parser
19405 if Nkind (Argx) = N_Identifier
19406 and then Nam_In (Chars (Argx), Name_On, Name_Off)
19410 -- One argument case must be ON/OFF or static string expr
19412 elsif not Is_Static_String_Expression (Arg1) then
19414 ("argument of pragma% must be On/Off or static string "
19415 & "expression", Arg1);
19417 -- One argument string expression case
19421 Lit : constant Node_Id := Expr_Value_S (Argx);
19422 Str : constant String_Id := Strval (Lit);
19423 Len : constant Nat := String_Length (Str);
19431 while J <= Len loop
19432 C := Get_String_Char (Str, J);
19433 OK := In_Character_Range (C);
19436 Chr := Get_Character (C);
19438 -- Dash case: only -Wxxx is accepted
19445 C := Get_String_Char (Str, J);
19446 Chr := Get_Character (C);
19447 exit when Chr = 'W';
19452 elsif J < Len and then Chr = '.' then
19454 C := Get_String_Char (Str, J);
19455 Chr := Get_Character (C);
19457 if not Set_Dot_Warning_Switch (Chr) then
19459 ("invalid warning switch character "
19460 & '.' & Chr, Arg1);
19466 OK := Set_Warning_Switch (Chr);
19472 ("invalid warning switch character " & Chr,
19481 -- Two or more arguments (must be two)
19484 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19485 Check_At_Most_N_Arguments (2);
19493 E_Id := Get_Pragma_Arg (Arg2);
19496 -- In the expansion of an inlined body, a reference to
19497 -- the formal may be wrapped in a conversion if the
19498 -- actual is a conversion. Retrieve the real entity name.
19500 if (In_Instance_Body or In_Inlined_Body)
19501 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
19503 E_Id := Expression (E_Id);
19506 -- Entity name case
19508 if Is_Entity_Name (E_Id) then
19509 E := Entity (E_Id);
19516 (E, (Chars (Get_Pragma_Arg (Arg1)) =
19519 -- For OFF case, make entry in warnings off
19520 -- pragma table for later processing. But we do
19521 -- not do that within an instance, since these
19522 -- warnings are about what is needed in the
19523 -- template, not an instance of it.
19525 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
19526 and then Warn_On_Warnings_Off
19527 and then not In_Instance
19529 Warnings_Off_Pragmas.Append ((N, E));
19532 if Is_Enumeration_Type (E) then
19536 Lit := First_Literal (E);
19537 while Present (Lit) loop
19538 Set_Warnings_Off (Lit);
19539 Next_Literal (Lit);
19544 exit when No (Homonym (E));
19549 -- Error if not entity or static string literal case
19551 elsif not Is_Static_String_Expression (Arg2) then
19553 ("second argument of pragma% must be entity name "
19554 & "or static string expression", Arg2);
19556 -- String literal case
19559 String_To_Name_Buffer
19560 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
19562 -- Note on configuration pragma case: If this is a
19563 -- configuration pragma, then for an OFF pragma, we
19564 -- just set Config True in the call, which is all
19565 -- that needs to be done. For the case of ON, this
19566 -- is normally an error, unless it is canceling the
19567 -- effect of a previous OFF pragma in the same file.
19568 -- In any other case, an error will be signalled (ON
19569 -- with no matching OFF).
19571 -- Note: We set Used if we are inside a generic to
19572 -- disable the test that the non-config case actually
19573 -- cancels a warning. That's because we can't be sure
19574 -- there isn't an instantiation in some other unit
19575 -- where a warning is suppressed.
19577 -- We could do a little better here by checking if the
19578 -- generic unit we are inside is public, but for now
19579 -- we don't bother with that refinement.
19581 if Chars (Argx) = Name_Off then
19582 Set_Specific_Warning_Off
19583 (Loc, Name_Buffer (1 .. Name_Len),
19584 Config => Is_Configuration_Pragma,
19585 Used => Inside_A_Generic or else In_Instance);
19587 elsif Chars (Argx) = Name_On then
19588 Set_Specific_Warning_On
19589 (Loc, Name_Buffer (1 .. Name_Len), Err);
19593 ("??pragma Warnings On with no matching "
19594 & "Warnings Off", Loc);
19603 -------------------
19604 -- Weak_External --
19605 -------------------
19607 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
19609 when Pragma_Weak_External => Weak_External : declare
19614 Check_Arg_Count (1);
19615 Check_Optional_Identifier (Arg1, Name_Entity);
19616 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19617 Ent := Entity (Get_Pragma_Arg (Arg1));
19619 if Rep_Item_Too_Early (Ent, N) then
19622 Ent := Underlying_Type (Ent);
19625 -- The only processing required is to link this item on to the
19626 -- list of rep items for the given entity. This is accomplished
19627 -- by the call to Rep_Item_Too_Late (when no error is detected
19628 -- and False is returned).
19630 if Rep_Item_Too_Late (Ent, N) then
19633 Set_Has_Gigi_Rep_Item (Ent);
19637 -----------------------------
19638 -- Wide_Character_Encoding --
19639 -----------------------------
19641 -- pragma Wide_Character_Encoding (IDENTIFIER);
19643 when Pragma_Wide_Character_Encoding =>
19646 -- Nothing to do, handled in parser. Note that we do not enforce
19647 -- configuration pragma placement, this pragma can appear at any
19648 -- place in the source, allowing mixed encodings within a single
19653 --------------------
19654 -- Unknown_Pragma --
19655 --------------------
19657 -- Should be impossible, since the case of an unknown pragma is
19658 -- separately processed before the case statement is entered.
19660 when Unknown_Pragma =>
19661 raise Program_Error;
19664 -- AI05-0144: detect dangerous order dependence. Disabled for now,
19665 -- until AI is formally approved.
19667 -- Check_Order_Dependence;
19670 when Pragma_Exit => null;
19671 end Analyze_Pragma;
19673 ---------------------------------------------
19674 -- Analyze_Pre_Post_Condition_In_Decl_Part --
19675 ---------------------------------------------
19677 procedure Analyze_Pre_Post_Condition_In_Decl_Part
19679 Subp_Id : Entity_Id)
19681 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
19682 Nam : constant Name_Id := Original_Aspect_Name (Prag);
19685 Restore_Scope : Boolean := False;
19686 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
19689 -- Ensure that the subprogram and its formals are visible when analyzing
19690 -- the expression of the pragma.
19692 if not In_Open_Scopes (Subp_Id) then
19693 Restore_Scope := True;
19694 Push_Scope (Subp_Id);
19695 Install_Formals (Subp_Id);
19698 -- Preanalyze the boolean expression, we treat this as a spec expression
19699 -- (i.e. similar to a default expression).
19701 Expr := Get_Pragma_Arg (Arg1);
19703 -- In ASIS mode, for a pragma generated from a source aspect, analyze
19704 -- the original aspect expression, which is shared with the generated
19707 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
19708 Expr := Expression (Corresponding_Aspect (Prag));
19711 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
19713 -- For a class-wide condition, a reference to a controlling formal must
19714 -- be interpreted as having the class-wide type (or an access to such)
19715 -- so that the inherited condition can be properly applied to any
19716 -- overriding operation (see ARM12 6.6.1 (7)).
19718 if Class_Present (Prag) then
19719 Class_Wide_Condition : declare
19720 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
19722 ACW : Entity_Id := Empty;
19723 -- Access to T'class, created if there is a controlling formal
19724 -- that is an access parameter.
19726 function Get_ACW return Entity_Id;
19727 -- If the expression has a reference to an controlling access
19728 -- parameter, create an access to T'class for the necessary
19729 -- conversions if one does not exist.
19731 function Process (N : Node_Id) return Traverse_Result;
19732 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
19733 -- aspect for a primitive subprogram of a tagged type T, a name
19734 -- that denotes a formal parameter of type T is interpreted as
19735 -- having type T'Class. Similarly, a name that denotes a formal
19736 -- accessparameter of type access-to-T is interpreted as having
19737 -- type access-to-T'Class. This ensures the expression is well-
19738 -- defined for a primitive subprogram of a type descended from T.
19739 -- Note that this replacement is not done for selector names in
19740 -- parameter associations. These carry an entity for reference
19741 -- purposes, but semantically they are just identifiers.
19747 function Get_ACW return Entity_Id is
19748 Loc : constant Source_Ptr := Sloc (Prag);
19754 Make_Full_Type_Declaration (Loc,
19755 Defining_Identifier => Make_Temporary (Loc, 'T'),
19757 Make_Access_To_Object_Definition (Loc,
19758 Subtype_Indication =>
19759 New_Occurrence_Of (Class_Wide_Type (T), Loc),
19760 All_Present => True));
19762 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
19764 ACW := Defining_Identifier (Decl);
19765 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
19775 function Process (N : Node_Id) return Traverse_Result is
19776 Loc : constant Source_Ptr := Sloc (N);
19780 if Is_Entity_Name (N)
19781 and then Present (Entity (N))
19782 and then Is_Formal (Entity (N))
19783 and then Nkind (Parent (N)) /= N_Type_Conversion
19785 (Nkind (Parent (N)) /= N_Parameter_Association
19786 or else N /= Selector_Name (Parent (N)))
19788 if Etype (Entity (N)) = T then
19789 Typ := Class_Wide_Type (T);
19791 elsif Is_Access_Type (Etype (Entity (N)))
19792 and then Designated_Type (Etype (Entity (N))) = T
19799 if Present (Typ) then
19801 Make_Type_Conversion (Loc,
19803 New_Occurrence_Of (Typ, Loc),
19804 Expression => New_Occurrence_Of (Entity (N), Loc)));
19805 Set_Etype (N, Typ);
19812 procedure Replace_Type is new Traverse_Proc (Process);
19814 -- Start of processing for Class_Wide_Condition
19817 if not Present (T) then
19819 -- Pre'Class/Post'Class aspect cases
19821 if From_Aspect_Specification (Prag) then
19822 if Nam = Name_uPre then
19823 Error_Msg_Name_1 := Name_Pre;
19825 Error_Msg_Name_1 := Name_Post;
19828 Error_Msg_Name_2 := Name_Class;
19831 ("aspect `%''%` can only be specified for a primitive "
19832 & "operation of a tagged type",
19833 Corresponding_Aspect (Prag));
19835 -- Pre_Class, Post_Class pragma cases
19838 if Nam = Name_uPre then
19839 Error_Msg_Name_1 := Name_Pre_Class;
19841 Error_Msg_Name_1 := Name_Post_Class;
19845 ("pragma% can only be specified for a primitive "
19846 & "operation of a tagged type",
19847 Corresponding_Aspect (Prag));
19851 Replace_Type (Get_Pragma_Arg (Arg1));
19852 end Class_Wide_Condition;
19855 -- Remove the subprogram from the scope stack now that the pre-analysis
19856 -- of the precondition/postcondition is done.
19858 if Restore_Scope then
19861 end Analyze_Pre_Post_Condition_In_Decl_Part;
19863 ------------------------------------------
19864 -- Analyze_Refined_Depends_In_Decl_Part --
19865 ------------------------------------------
19867 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
19868 Dependencies : List_Id := No_List;
19870 -- The corresponding Depends pragma along with its clauses
19872 Global : Node_Id := Empty;
19873 -- The corresponding Refined_Global pragma (if any)
19875 Out_Items : Elist_Id := No_Elist;
19876 -- All output items as defined in pragma Refined_Global (if any)
19878 Refinements : List_Id := No_List;
19879 -- The clauses of pragma Refined_Depends
19881 Spec_Id : Entity_Id;
19882 -- The entity of the subprogram subject to pragma Refined_Depends
19884 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
19885 -- Verify the legality of a single clause
19887 procedure Report_Extra_Clauses;
19888 -- Emit an error for each extra clause the appears in Refined_Depends
19890 -----------------------------
19891 -- Check_Dependency_Clause --
19892 -----------------------------
19894 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
19895 function Inputs_Match
19896 (Ref_Clause : Node_Id;
19897 Do_Checks : Boolean) return Boolean;
19898 -- Determine whether the inputs of clause Dep_Clause match those of
19899 -- clause Ref_Clause. If flag Do_Checks is set, the routine reports
19900 -- missed or extra input items.
19902 function Output_Constituents (State_Id : Entity_Id) return Elist_Id;
19903 -- Given a state denoted by State_Id, return a list of all output
19904 -- constituents that may be referenced within Refined_Depends. The
19905 -- contents of the list depend on whethe Refined_Global is present.
19907 procedure Report_Unused_Constituents (Constits : Elist_Id);
19908 -- Emit errors for all constituents found in list Constits
19914 function Inputs_Match
19915 (Ref_Clause : Node_Id;
19916 Do_Checks : Boolean) return Boolean
19918 Ref_Inputs : List_Id;
19919 -- The input list of the refinement clause
19921 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean;
19922 -- Determine whether input Dep_Input matches one of the inputs of
19923 -- clause Ref_Clause.
19925 procedure Report_Extra_Inputs;
19926 -- Emit errors for all extra inputs that appear in Ref_Clause
19928 -----------------------
19929 -- Is_Matching_Input --
19930 -----------------------
19932 function Is_Matching_Input (Dep_Input : Node_Id) return Boolean is
19933 procedure Match_Error (Msg : String; N : Node_Id);
19934 -- Emit a matching error if flag Do_Checks is set
19940 procedure Match_Error (Msg : String; N : Node_Id) is
19943 Error_Msg_N (Msg, N);
19950 Next_Ref_Input : Node_Id;
19951 Ref_Id : Entity_Id;
19952 Ref_Input : Node_Id;
19954 Has_Constituent : Boolean := False;
19955 -- Flag set when the refinement input list contains at least
19956 -- one constituent of the state denoted by Dep_Id.
19958 Has_Null_State : Boolean := False;
19959 -- Flag set when the dependency input is a state with a null
19962 Has_Refined_State : Boolean := False;
19963 -- Flag set when the dependency input is a state with visible
19966 -- Start of processing for Is_Matching_Input
19969 -- Match a null input with another null input
19971 if Nkind (Dep_Input) = N_Null then
19972 Ref_Input := First (Ref_Inputs);
19974 -- Remove the matching null from the pool of candidates
19976 if Nkind (Ref_Input) = N_Null then
19977 Remove (Ref_Input);
19982 ("null input cannot be matched in corresponding "
19983 & "refinement clause", Dep_Input);
19986 -- Remaining cases are formal parameters, variables, and states
19989 Dep_Id := Entity_Of (Dep_Input);
19991 -- Inspect all inputs of the refinement clause and attempt
19992 -- to match against the inputs of the dependence clause.
19994 Ref_Input := First (Ref_Inputs);
19995 while Present (Ref_Input) loop
19997 -- Store the next input now because a match will remove
19998 -- it from the list.
20000 Next_Ref_Input := Next (Ref_Input);
20002 if Ekind (Dep_Id) = E_Abstract_State then
20004 -- A state with a null refinement matches either a
20005 -- null input list or nothing at all (no input):
20007 -- Refined_State => (State => null)
20011 -- Depends => (<output> => (State, Input))
20012 -- Refined_Depends => (<output> => Input) -- OK
20016 -- Depends => (<output> => State)
20017 -- Refined_Depends => (<output> => null) -- OK
20019 if Has_Null_Refinement (Dep_Id) then
20020 Has_Null_State := True;
20022 -- Remove the matching null from the pool of
20025 if Nkind (Ref_Input) = N_Null then
20026 Remove (Ref_Input);
20031 -- The state has a non-null refinement in which case
20032 -- remove all the matching constituents of the state:
20034 -- Refined_State => (State => (C1, C2))
20035 -- Depends => (<output> => State)
20036 -- Refined_Depends => (<output> => (C1, C2))
20038 elsif Has_Non_Null_Refinement (Dep_Id) then
20039 Has_Refined_State := True;
20041 -- Ref_Input is an entity name
20043 if Is_Entity_Name (Ref_Input) then
20044 Ref_Id := Entity_Of (Ref_Input);
20046 -- The input of the refinement clause is a valid
20047 -- constituent of the state. Remove the input
20048 -- from the pool of candidates. Note that the
20049 -- search continues because the state may be
20050 -- represented by multiple constituents.
20052 if Ekind_In (Ref_Id, E_Abstract_State,
20054 and then Present (Refined_State (Ref_Id))
20055 and then Refined_State (Ref_Id) = Dep_Id
20057 Has_Constituent := True;
20058 Remove (Ref_Input);
20063 -- Formal parameters and variables are matched on
20064 -- entities. If this is the case, remove the input from
20065 -- the candidate list.
20067 elsif Is_Entity_Name (Ref_Input)
20068 and then Entity_Of (Ref_Input) = Dep_Id
20070 Remove (Ref_Input);
20074 Ref_Input := Next_Ref_Input;
20077 -- When a state with a null refinement appears as the last
20078 -- input, it matches nothing:
20080 -- Refined_State => (State => null)
20081 -- Depends => (<output> => (Input, State))
20082 -- Refined_Depends => (<output> => Input) -- OK
20084 if Ekind (Dep_Id) = E_Abstract_State
20085 and then Has_Null_Refinement (Dep_Id)
20086 and then No (Ref_Input)
20088 Has_Null_State := True;
20092 -- A state with visible refinement was matched against one or
20093 -- more of its constituents.
20095 if Has_Constituent then
20098 -- A state with a null refinement matched null or nothing
20100 elsif Has_Null_State then
20103 -- The input of a dependence clause does not have a matching
20104 -- input in the refinement clause, emit an error.
20108 ("input cannot be matched in corresponding refinement "
20109 & "clause", Dep_Input);
20111 if Has_Refined_State then
20113 ("\check the use of constituents in dependence "
20114 & "refinement", Dep_Input);
20119 end Is_Matching_Input;
20121 -------------------------
20122 -- Report_Extra_Inputs --
20123 -------------------------
20125 procedure Report_Extra_Inputs is
20129 if Present (Ref_Inputs) and then Do_Checks then
20130 Input := First (Ref_Inputs);
20131 while Present (Input) loop
20133 ("unmatched or extra input in refinement clause",
20139 end Report_Extra_Inputs;
20143 Dep_Inputs : constant Node_Id := Expression (Dep_Clause);
20144 Inputs : constant Node_Id := Expression (Ref_Clause);
20145 Dep_Input : Node_Id;
20148 -- Start of processing for Inputs_Match
20151 -- Construct a list of all refinement inputs. Note that the input
20152 -- list is copied because the algorithm modifies its contents and
20153 -- this should not be visible in Refined_Depends.
20155 if Nkind (Inputs) = N_Aggregate then
20156 Ref_Inputs := New_Copy_List (Expressions (Inputs));
20158 Ref_Inputs := New_List (Inputs);
20161 -- Depending on whether the original dependency clause mentions
20162 -- states with visible refinement, the corresponding refinement
20163 -- clause may differ greatly in structure and contents:
20165 -- State with null refinement
20167 -- Refined_State => (State => null)
20168 -- Depends => (<output> => State)
20169 -- Refined_Depends => (<output> => null)
20171 -- Depends => (<output> => (State, Input))
20172 -- Refined_Depends => (<output> => Input)
20174 -- Depends => (<output> => (Input_1, State, Input_2))
20175 -- Refined_Depends => (<output> => (Input_1, Input_2))
20177 -- State with non-null refinement
20179 -- Refined_State => (State_1 => (C1, C2))
20180 -- Depends => (<output> => State)
20181 -- Refined_Depends => (<output> => C1)
20183 -- Refined_Depends => (<output> => (C1, C2))
20185 if Nkind (Dep_Inputs) = N_Aggregate then
20186 Dep_Input := First (Expressions (Dep_Inputs));
20187 while Present (Dep_Input) loop
20188 if not Is_Matching_Input (Dep_Input) then
20200 Result := Is_Matching_Input (Dep_Inputs);
20203 Report_Extra_Inputs;
20207 -------------------------
20208 -- Output_Constituents --
20209 -------------------------
20211 function Output_Constituents (State_Id : Entity_Id) return Elist_Id is
20212 Item_Elmt : Elmt_Id;
20213 Item_Id : Entity_Id;
20214 Result : Elist_Id := No_Elist;
20217 -- The related subprogram is subject to pragma Refined_Global. All
20218 -- usable output constituents are defined in its output item list.
20220 if Present (Global) then
20221 Item_Elmt := First_Elmt (Out_Items);
20222 while Present (Item_Elmt) loop
20223 Item_Id := Node (Item_Elmt);
20225 -- The constituent is part of the refinement of the input
20226 -- state, add it to the result list.
20228 if Refined_State (Item_Id) = State_Id then
20229 Add_Item (Item_Id, Result);
20232 Next_Elmt (Item_Elmt);
20235 -- When pragma Refined_Global is not present, the usable output
20236 -- constituents are all the constituents as defined in pragma
20237 -- Refined_State. Note that the elements are copied because the
20238 -- algorithm trims the list and this should not be reflected in
20239 -- the state itself.
20242 Result := New_Copy_Elist (Refinement_Constituents (State_Id));
20246 end Output_Constituents;
20248 --------------------------------
20249 -- Report_Unused_Constituents --
20250 --------------------------------
20252 procedure Report_Unused_Constituents (Constits : Elist_Id) is
20253 Constit : Entity_Id;
20255 Posted : Boolean := False;
20258 if Present (Constits) then
20259 Elmt := First_Elmt (Constits);
20260 while Present (Elmt) loop
20261 Constit := Node (Elmt);
20263 -- A constituent must always refine a state
20265 pragma Assert (Present (Refined_State (Constit)));
20267 -- When a state has a visible refinement and its mode is
20268 -- Output_Only, all its constituents must be used as
20274 ("output only state & must be replaced by all its "
20275 & "constituents in dependence refinement",
20276 N, Refined_State (Constit));
20280 ("\ constituent & is missing in output list", N, Constit);
20285 end Report_Unused_Constituents;
20289 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
20290 Dep_Id : Entity_Id;
20291 Matching_Clause : Node_Id := Empty;
20292 Next_Ref_Clause : Node_Id;
20293 Ref_Clause : Node_Id;
20294 Ref_Id : Entity_Id;
20295 Ref_Output : Node_Id;
20297 Has_Constituent : Boolean := False;
20298 -- Flag set when the refinement output list contains at least one
20299 -- constituent of the state denoted by Dep_Id.
20301 Has_Null_State : Boolean := False;
20302 -- Flag set when the output of clause Dep_Clause is a state with a
20303 -- null refinement.
20305 Has_Refined_State : Boolean := False;
20306 -- Flag set when the output of clause Dep_Clause is a state with
20307 -- visible refinement.
20309 Out_Constits : Elist_Id := No_Elist;
20310 -- This list contains the entities all output constituents of state
20311 -- Dep_Id as defined in pragma Refined_State.
20313 -- Start of processing for Check_Dependency_Clause
20316 -- The analysis of pragma Depends should produce normalized clauses
20317 -- with exactly one output. This is important because output items
20318 -- are unique in the whole dependence relation and can be used as
20321 pragma Assert (No (Next (Dep_Output)));
20323 -- Inspect all clauses of Refined_Depends and attempt to match the
20324 -- output of Dep_Clause against an output from the refinement clauses
20327 Ref_Clause := First (Refinements);
20328 while Present (Ref_Clause) loop
20329 Matching_Clause := Empty;
20331 -- Store the next clause now because a match will trim the list of
20332 -- refinement clauses and this side effect should not be visible
20333 -- in pragma Refined_Depends.
20335 Next_Ref_Clause := Next (Ref_Clause);
20337 -- The analysis of pragma Refined_Depends should produce
20338 -- normalized clauses with exactly one output.
20340 Ref_Output := First (Choices (Ref_Clause));
20341 pragma Assert (No (Next (Ref_Output)));
20343 -- Two null output lists match if their inputs match
20345 if Nkind (Dep_Output) = N_Null
20346 and then Nkind (Ref_Output) = N_Null
20348 Matching_Clause := Ref_Clause;
20351 -- Two function 'Result attributes match if their inputs match.
20352 -- Note that there is no need to compare the two prefixes because
20353 -- the attributes cannot denote anything but the related function.
20355 elsif Is_Attribute_Result (Dep_Output)
20356 and then Is_Attribute_Result (Ref_Output)
20358 Matching_Clause := Ref_Clause;
20361 -- The remaining cases are formal parameters, variables and states
20363 elsif Is_Entity_Name (Dep_Output) then
20364 Dep_Id := Entity_Of (Dep_Output);
20366 if Ekind (Dep_Id) = E_Abstract_State then
20368 -- A state with a null refinement matches either a null
20369 -- output list or nothing at all (no clause):
20371 -- Refined_State => (State => null)
20375 -- Depends => (State => null)
20376 -- Refined_Depends => null -- OK
20378 -- Null output list
20380 -- Depends => (State => <input>)
20381 -- Refined_Depends => (null => <input>) -- OK
20383 if Has_Null_Refinement (Dep_Id) then
20384 Has_Null_State := True;
20386 -- When a state with null refinement matches a null
20387 -- output, compare their inputs.
20389 if Nkind (Ref_Output) = N_Null then
20390 Matching_Clause := Ref_Clause;
20395 -- The state has a non-null refinement in which case the
20396 -- match is based on constituents and inputs. A state with
20397 -- multiple output constituents may match multiple clauses:
20399 -- Refined_State => (State => (C1, C2))
20400 -- Depends => (State => <input>)
20401 -- Refined_Depends => ((C1, C2) => <input>)
20403 -- When normalized, the above becomes:
20405 -- Refined_Depends => (C1 => <input>,
20408 elsif Has_Non_Null_Refinement (Dep_Id) then
20409 Has_Refined_State := True;
20411 -- Store the entities of all output constituents of an
20412 -- Output_Only state with visible refinement.
20414 if No (Out_Constits)
20415 and then Is_Output_Only_State (Dep_Id)
20417 Out_Constits := Output_Constituents (Dep_Id);
20420 if Is_Entity_Name (Ref_Output) then
20421 Ref_Id := Entity_Of (Ref_Output);
20423 -- The output of the refinement clause is a valid
20424 -- constituent of the state. Remove the clause from
20425 -- the pool of candidates if both input lists match.
20426 -- Note that the search continues because one clause
20427 -- may have been normalized into multiple clauses as
20428 -- per the example above.
20430 if Ekind_In (Ref_Id, E_Abstract_State, E_Variable)
20431 and then Present (Refined_State (Ref_Id))
20432 and then Refined_State (Ref_Id) = Dep_Id
20433 and then Inputs_Match
20434 (Ref_Clause, Do_Checks => False)
20436 Has_Constituent := True;
20437 Remove (Ref_Clause);
20439 -- The matching constituent may act as an output
20440 -- for an Output_Only state. Remove the item from
20441 -- the available output constituents.
20443 Remove (Out_Constits, Ref_Id);
20448 -- Formal parameters and variables match if their inputs match
20450 elsif Is_Entity_Name (Ref_Output)
20451 and then Entity_Of (Ref_Output) = Dep_Id
20453 Matching_Clause := Ref_Clause;
20458 Ref_Clause := Next_Ref_Clause;
20461 -- Handle the case where pragma Depends contains one or more clauses
20462 -- that only mention states with null refinements. In that case the
20463 -- corresponding pragma Refined_Depends may have a null relation.
20465 -- Refined_State => (State => null)
20466 -- Depends => (State => null)
20467 -- Refined_Depends => null -- OK
20469 if No (Refinements) and then Is_Entity_Name (Dep_Output) then
20470 Dep_Id := Entity_Of (Dep_Output);
20472 if Ekind (Dep_Id) = E_Abstract_State
20473 and then Has_Null_Refinement (Dep_Id)
20475 Has_Null_State := True;
20479 -- The above search produced a match based on unique output. Ensure
20480 -- that the inputs match as well and if they do, remove the clause
20481 -- from the pool of candidates.
20483 if Present (Matching_Clause) then
20484 if Inputs_Match (Matching_Clause, Do_Checks => True) then
20485 Remove (Matching_Clause);
20488 -- A state with a visible refinement was matched against one or
20489 -- more clauses containing appropriate constituents.
20491 elsif Has_Constituent then
20494 -- A state with a null refinement did not warrant a clause
20496 elsif Has_Null_State then
20499 -- The dependence relation of pragma Refined_Depends does not contain
20500 -- a matching clause, emit an error.
20504 ("dependence clause of subprogram & has no matching refinement "
20505 & "in body", Ref_Clause, Spec_Id);
20507 if Has_Refined_State then
20509 ("\check the use of constituents in dependence refinement",
20514 -- Emit errors for all unused constituents of an Output_Only state
20515 -- with visible refinement.
20517 Report_Unused_Constituents (Out_Constits);
20518 end Check_Dependency_Clause;
20520 --------------------------
20521 -- Report_Extra_Clauses --
20522 --------------------------
20524 procedure Report_Extra_Clauses is
20528 if Present (Refinements) then
20529 Clause := First (Refinements);
20530 while Present (Clause) loop
20532 -- Do not complain about a null input refinement, since a null
20533 -- input legitimately matches anything.
20535 if Nkind (Clause) /= N_Component_Association
20536 or else Nkind (Expression (Clause)) /= N_Null
20539 ("unmatched or extra clause in dependence refinement",
20546 end Report_Extra_Clauses;
20550 Body_Decl : constant Node_Id := Parent (N);
20551 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
20552 Errors : constant Nat := Serious_Errors_Detected;
20557 -- The following are dummy variables that capture unused output of
20558 -- routine Collect_Global_Items.
20560 D1, D2 : Elist_Id := No_Elist;
20561 D3, D4, D5, D6 : Boolean;
20563 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
20566 Spec_Id := Corresponding_Spec (Body_Decl);
20567 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
20569 -- The subprogram declarations lacks pragma Depends. This renders
20570 -- Refined_Depends useless as there is nothing to refine.
20572 if No (Depends) then
20574 ("useless refinement, subprogram & lacks dependence clauses",
20579 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends)));
20581 -- A null dependency relation renders the refinement useless because it
20582 -- cannot possibly mention abstract states with visible refinement. Note
20583 -- that the inverse is not true as states may be refined to null.
20585 if Nkind (Deps) = N_Null then
20587 ("useless refinement, subprogram & does not depend on abstract "
20588 & "state with visible refinement", N, Spec_Id);
20592 -- Multiple dependency clauses appear as component associations of an
20595 pragma Assert (Nkind (Deps) = N_Aggregate);
20596 Dependencies := Component_Associations (Deps);
20598 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
20599 -- This ensures that the categorization of all refined dependency items
20600 -- is consistent with their role.
20602 Analyze_Depends_In_Decl_Part (N);
20603 Refs := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
20605 if Serious_Errors_Detected = Errors then
20607 -- The related subprogram may be subject to pragma Refined_Global. If
20608 -- this is the case, gather all output items. These are needed when
20609 -- verifying the use of constituents that apply to output states with
20610 -- visible refinement.
20612 Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
20614 if Present (Global) then
20615 Collect_Global_Items
20618 In_Out_Items => D2,
20619 Out_Items => Out_Items,
20620 Has_In_State => D3,
20621 Has_In_Out_State => D4,
20622 Has_Out_State => D5,
20623 Has_Null_State => D6);
20626 if Nkind (Refs) = N_Null then
20627 Refinements := No_List;
20629 -- Multiple dependency clauses appear as component associations of an
20630 -- aggregate. Note that the clauses are copied because the algorithm
20631 -- modifies them and this should not be visible in Refined_Depends.
20633 else pragma Assert (Nkind (Refs) = N_Aggregate);
20634 Refinements := New_Copy_List (Component_Associations (Refs));
20637 -- Inspect all the clauses of pragma Depends looking for a matching
20638 -- clause in pragma Refined_Depends. The approach is to use the
20639 -- sole output of a clause as a key. Output items are unique in a
20640 -- dependence relation. Clause normalization also ensured that all
20641 -- clauses have exactly one output. Depending on what the key is, one
20642 -- or more refinement clauses may satisfy the dependency clause. Each
20643 -- time a dependency clause is matched, its related refinement clause
20644 -- is consumed. In the end, two things may happen:
20646 -- 1) A clause of pragma Depends was not matched in which case
20647 -- Check_Dependency_Clause reports the error.
20649 -- 2) Refined_Depends has an extra clause in which case the error
20650 -- is reported by Report_Extra_Clauses.
20652 Clause := First (Dependencies);
20653 while Present (Clause) loop
20654 Check_Dependency_Clause (Clause);
20659 if Serious_Errors_Detected = Errors then
20660 Report_Extra_Clauses;
20662 end Analyze_Refined_Depends_In_Decl_Part;
20664 -----------------------------------------
20665 -- Analyze_Refined_Global_In_Decl_Part --
20666 -----------------------------------------
20668 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
20670 -- The corresponding Global pragma
20672 Has_In_State : Boolean := False;
20673 Has_In_Out_State : Boolean := False;
20674 Has_Out_State : Boolean := False;
20675 -- These flags are set when the corresponding Global pragma has a state
20676 -- of mode Input, In_Out and Output respectively with a visible
20679 Has_Null_State : Boolean := False;
20680 -- This flag is set when the corresponding Global pragma has at least
20681 -- one state with a null refinement.
20683 In_Constits : Elist_Id := No_Elist;
20684 In_Out_Constits : Elist_Id := No_Elist;
20685 Out_Constits : Elist_Id := No_Elist;
20686 -- These lists contain the entities of all Input, In_Out and Output
20687 -- constituents that appear in Refined_Global and participate in state
20690 In_Items : Elist_Id := No_Elist;
20691 In_Out_Items : Elist_Id := No_Elist;
20692 Out_Items : Elist_Id := No_Elist;
20693 -- These list contain the entities of all Input, In_Out and Output items
20694 -- defined in the corresponding Global pragma.
20696 procedure Check_In_Out_States;
20697 -- Determine whether the corresponding Global pragma mentions In_Out
20698 -- states with visible refinement and if so, ensure that one of the
20699 -- following completions apply to the constituents of the state:
20700 -- 1) there is at least one constituent of mode In_Out
20701 -- 2) there is at least one Input and one Output constituent
20702 -- 3) not all constituents are present and one of them is of mode
20704 -- This routine may remove elements from In_Constits, In_Out_Constits
20705 -- and Out_Constits.
20707 procedure Check_Input_States;
20708 -- Determine whether the corresponding Global pragma mentions Input
20709 -- states with visible refinement and if so, ensure that at least one of
20710 -- its constituents appears as an Input item in Refined_Global.
20711 -- This routine may remove elements from In_Constits, In_Out_Constits
20712 -- and Out_Constits.
20714 procedure Check_Output_States;
20715 -- Determine whether the corresponding Global pragma mentions Output
20716 -- states with visible refinement and if so, ensure that all of its
20717 -- constituents appear as Output items in Refined_Global. This routine
20718 -- may remove elements from In_Constits, In_Out_Constits and
20721 procedure Check_Refined_Global_List
20723 Global_Mode : Name_Id := Name_Input);
20724 -- Verify the legality of a single global list declaration. Global_Mode
20725 -- denotes the current mode in effect.
20727 function Present_Then_Remove
20729 Item : Entity_Id) return Boolean;
20730 -- Search List for a particular entity Item. If Item has been found,
20731 -- remove it from List. This routine is used to strip lists In_Constits,
20732 -- In_Out_Constits and Out_Constits of valid constituents.
20734 procedure Report_Extra_Constituents;
20735 -- Emit an error for each constituent found in lists In_Constits,
20736 -- In_Out_Constits and Out_Constits.
20738 -------------------------
20739 -- Check_In_Out_States --
20740 -------------------------
20742 procedure Check_In_Out_States is
20743 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20744 -- Determine whether one of the following coverage scenarios is in
20746 -- 1) there is at least one constituent of mode In_Out
20747 -- 2) there is at least one Input and one Output constituent
20748 -- 3) not all constituents are present and one of them is of mode
20750 -- If this is not the case, emit an error.
20752 -----------------------------
20753 -- Check_Constituent_Usage --
20754 -----------------------------
20756 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20757 Constit_Elmt : Elmt_Id;
20758 Constit_Id : Entity_Id;
20759 Has_Missing : Boolean := False;
20760 In_Out_Seen : Boolean := False;
20761 In_Seen : Boolean := False;
20762 Out_Seen : Boolean := False;
20765 -- Process all the constituents of the state and note their modes
20766 -- within the global refinement.
20768 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20769 while Present (Constit_Elmt) loop
20770 Constit_Id := Node (Constit_Elmt);
20772 if Present_Then_Remove (In_Constits, Constit_Id) then
20775 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
20776 In_Out_Seen := True;
20778 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
20782 Has_Missing := True;
20785 Next_Elmt (Constit_Elmt);
20788 -- A single In_Out constituent is a valid completion
20790 if In_Out_Seen then
20793 -- A pair of one Input and one Output constituent is a valid
20796 elsif In_Seen and then Out_Seen then
20799 -- A single Output constituent is a valid completion only when
20800 -- some of the other constituents are missing.
20802 elsif Has_Missing and then Out_Seen then
20807 ("global refinement of state & redefines the mode of its "
20808 & "constituents", N, State_Id);
20810 end Check_Constituent_Usage;
20814 Item_Elmt : Elmt_Id;
20815 Item_Id : Entity_Id;
20817 -- Start of processing for Check_In_Out_States
20820 -- Inspect the In_Out items of the corresponding Global pragma
20821 -- looking for a state with a visible refinement.
20823 if Has_In_Out_State and then Present (In_Out_Items) then
20824 Item_Elmt := First_Elmt (In_Out_Items);
20825 while Present (Item_Elmt) loop
20826 Item_Id := Node (Item_Elmt);
20828 -- Ensure that one of the three coverage variants is satisfied
20830 if Ekind (Item_Id) = E_Abstract_State
20831 and then Has_Non_Null_Refinement (Item_Id)
20833 Check_Constituent_Usage (Item_Id);
20836 Next_Elmt (Item_Elmt);
20839 end Check_In_Out_States;
20841 ------------------------
20842 -- Check_Input_States --
20843 ------------------------
20845 procedure Check_Input_States is
20846 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20847 -- Determine whether at least one constituent of state State_Id with
20848 -- visible refinement is used and has mode Input. Ensure that the
20849 -- remaining constituents do not have In_Out or Output modes.
20851 -----------------------------
20852 -- Check_Constituent_Usage --
20853 -----------------------------
20855 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20856 Constit_Elmt : Elmt_Id;
20857 Constit_Id : Entity_Id;
20858 In_Seen : Boolean := False;
20861 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20862 while Present (Constit_Elmt) loop
20863 Constit_Id := Node (Constit_Elmt);
20865 -- At least one of the constituents appears as an Input
20867 if Present_Then_Remove (In_Constits, Constit_Id) then
20870 -- The constituent appears in the global refinement, but has
20871 -- mode In_Out or Output.
20873 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
20874 or else Present_Then_Remove (Out_Constits, Constit_Id)
20876 Error_Msg_Name_1 := Chars (State_Id);
20878 ("constituent & of state % must have mode Input in global "
20879 & "refinement", N, Constit_Id);
20882 Next_Elmt (Constit_Elmt);
20885 -- Not one of the constituents appeared as Input
20887 if not In_Seen then
20889 ("global refinement of state & must include at least one "
20890 & "constituent of mode Input", N, State_Id);
20892 end Check_Constituent_Usage;
20896 Item_Elmt : Elmt_Id;
20897 Item_Id : Entity_Id;
20899 -- Start of processing for Check_Input_States
20902 -- Inspect the Input items of the corresponding Global pragma
20903 -- looking for a state with a visible refinement.
20905 if Has_In_State and then Present (In_Items) then
20906 Item_Elmt := First_Elmt (In_Items);
20907 while Present (Item_Elmt) loop
20908 Item_Id := Node (Item_Elmt);
20910 -- Ensure that at least one of the constituents is utilized and
20911 -- is of mode Input.
20913 if Ekind (Item_Id) = E_Abstract_State
20914 and then Has_Non_Null_Refinement (Item_Id)
20916 Check_Constituent_Usage (Item_Id);
20919 Next_Elmt (Item_Elmt);
20922 end Check_Input_States;
20924 -------------------------
20925 -- Check_Output_States --
20926 -------------------------
20928 procedure Check_Output_States is
20929 procedure Check_Constituent_Usage (State_Id : Entity_Id);
20930 -- Determine whether all constituents of state State_Id with visible
20931 -- refinement are used and have mode Output. Emit an error if this is
20934 -----------------------------
20935 -- Check_Constituent_Usage --
20936 -----------------------------
20938 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
20939 Constit_Elmt : Elmt_Id;
20940 Constit_Id : Entity_Id;
20943 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
20944 while Present (Constit_Elmt) loop
20945 Constit_Id := Node (Constit_Elmt);
20947 if Present_Then_Remove (Out_Constits, Constit_Id) then
20951 Remove (In_Constits, Constit_Id);
20952 Remove (In_Out_Constits, Constit_Id);
20954 Error_Msg_Name_1 := Chars (State_Id);
20956 ("constituent & of state % must have mode Output in "
20957 & "global refinement", N, Constit_Id);
20960 Next_Elmt (Constit_Elmt);
20962 end Check_Constituent_Usage;
20966 Item_Elmt : Elmt_Id;
20967 Item_Id : Entity_Id;
20969 -- Start of processing for Check_Output_States
20972 -- Inspect the Output items of the corresponding Global pragma
20973 -- looking for a state with a visible refinement.
20975 if Has_Out_State and then Present (Out_Items) then
20976 Item_Elmt := First_Elmt (Out_Items);
20977 while Present (Item_Elmt) loop
20978 Item_Id := Node (Item_Elmt);
20980 -- Ensure that all of the constituents are utilized and they
20981 -- have mode Output.
20983 if Ekind (Item_Id) = E_Abstract_State
20984 and then Has_Non_Null_Refinement (Item_Id)
20986 Check_Constituent_Usage (Item_Id);
20989 Next_Elmt (Item_Elmt);
20992 end Check_Output_States;
20994 -------------------------------
20995 -- Check_Refined_Global_List --
20996 -------------------------------
20998 procedure Check_Refined_Global_List
21000 Global_Mode : Name_Id := Name_Input)
21002 procedure Check_Refined_Global_Item
21004 Global_Mode : Name_Id);
21005 -- Verify the legality of a single global item declaration. Parameter
21006 -- Global_Mode denotes the current mode in effect.
21008 -------------------------------
21009 -- Check_Refined_Global_Item --
21010 -------------------------------
21012 procedure Check_Refined_Global_Item
21014 Global_Mode : Name_Id)
21016 procedure Add_Constituent (Item_Id : Entity_Id);
21017 -- Add a single constituent to one of the three constituent lists
21018 -- depending on Global_Mode.
21020 procedure Check_Matching_Modes (Item_Id : Entity_Id);
21021 -- Verify that the global modes of item Item_Id are the same in
21022 -- both pragmas Global and Refined_Global.
21024 ---------------------
21025 -- Add_Constituent --
21026 ---------------------
21028 procedure Add_Constituent (Item_Id : Entity_Id) is
21030 if Global_Mode = Name_Input then
21031 Add_Item (Item_Id, In_Constits);
21033 elsif Global_Mode = Name_In_Out then
21034 Add_Item (Item_Id, In_Out_Constits);
21036 elsif Global_Mode = Name_Output then
21037 Add_Item (Item_Id, Out_Constits);
21039 end Add_Constituent;
21041 --------------------------
21042 -- Check_Matching_Modes --
21043 --------------------------
21045 procedure Check_Matching_Modes (Item_Id : Entity_Id) is
21046 procedure Inconsistent_Mode_Error (Expect : Name_Id);
21047 -- Issue a common error message for all mode mismatche. Expect
21048 -- denotes the expected mode.
21050 -----------------------------
21051 -- Inconsistent_Mode_Error --
21052 -----------------------------
21054 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
21057 ("global item & has inconsistent modes", Item, Item_Id);
21059 Error_Msg_Name_1 := Global_Mode;
21060 Error_Msg_N ("\ expected mode %", Item);
21062 Error_Msg_Name_1 := Expect;
21063 Error_Msg_N ("\ found mode %", Item);
21064 end Inconsistent_Mode_Error;
21066 -- Start processing for Check_Matching_Modes
21069 if Contains (In_Items, Item_Id) then
21070 if Global_Mode /= Name_Input then
21071 Inconsistent_Mode_Error (Name_Input);
21074 elsif Contains (In_Out_Items, Item_Id) then
21075 if Global_Mode /= Name_In_Out then
21076 Inconsistent_Mode_Error (Name_In_Out);
21079 elsif Contains (Out_Items, Item_Id) then
21080 if Global_Mode /= Name_Output then
21081 Inconsistent_Mode_Error (Name_Output);
21084 -- The item does not appear in the corresponding Global aspect,
21085 -- it must be an extra.
21088 Error_Msg_NE ("extra global item &", Item, Item_Id);
21090 end Check_Matching_Modes;
21094 Item_Id : constant Entity_Id := Entity_Of (Item);
21096 -- Start of processing for Check_Refined_Global_Item
21099 if Ekind (Item_Id) = E_Abstract_State then
21101 -- The state is neither a constituent of an ancestor state nor
21102 -- has a visible refinement. Ensure that the modes of both its
21103 -- occurrences in Global and Refined_Global match.
21105 if No (Refined_State (Item_Id))
21106 and then not Has_Visible_Refinement (Item_Id)
21108 Check_Matching_Modes (Item_Id);
21111 else pragma Assert (Ekind (Item_Id) = E_Variable);
21113 -- The variable acts as a constituent of a state, collect it
21114 -- for the state completeness checks performed later on.
21116 if Present (Refined_State (Item_Id)) then
21117 Add_Constituent (Item_Id);
21119 -- The variable is not a constituent. Ensure that the modes of
21120 -- both its occurrences in Global and Refined_Global match.
21123 Check_Matching_Modes (Item_Id);
21126 end Check_Refined_Global_Item;
21132 -- Start of processing for Check_Refined_Global_List
21135 if Nkind (List) = N_Null then
21138 -- Single global item declaration
21140 elsif Nkind_In (List, N_Expanded_Name,
21142 N_Selected_Component)
21144 Check_Refined_Global_Item (List, Global_Mode);
21146 -- Simple global list or moded global list declaration
21148 elsif Nkind (List) = N_Aggregate then
21150 -- The declaration of a simple global list appear as a collection
21153 if Present (Expressions (List)) then
21154 Item := First (Expressions (List));
21155 while Present (Item) loop
21156 Check_Refined_Global_Item (Item, Global_Mode);
21161 -- The declaration of a moded global list appears as a collection
21162 -- of component associations where individual choices denote
21165 elsif Present (Component_Associations (List)) then
21166 Item := First (Component_Associations (List));
21167 while Present (Item) loop
21168 Check_Refined_Global_List
21169 (List => Expression (Item),
21170 Global_Mode => Chars (First (Choices (Item))));
21178 raise Program_Error;
21184 raise Program_Error;
21186 end Check_Refined_Global_List;
21188 -------------------------
21189 -- Present_Then_Remove --
21190 -------------------------
21192 function Present_Then_Remove
21194 Item : Entity_Id) return Boolean
21199 if Present (List) then
21200 Elmt := First_Elmt (List);
21201 while Present (Elmt) loop
21202 if Node (Elmt) = Item then
21203 Remove_Elmt (List, Elmt);
21212 end Present_Then_Remove;
21214 -------------------------------
21215 -- Report_Extra_Constituents --
21216 -------------------------------
21218 procedure Report_Extra_Constituents is
21219 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
21220 -- Emit an error for every element of List
21222 ---------------------------------------
21223 -- Report_Extra_Constituents_In_List --
21224 ---------------------------------------
21226 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
21227 Constit_Elmt : Elmt_Id;
21230 if Present (List) then
21231 Constit_Elmt := First_Elmt (List);
21232 while Present (Constit_Elmt) loop
21233 Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
21234 Next_Elmt (Constit_Elmt);
21237 end Report_Extra_Constituents_In_List;
21239 -- Start of processing for Report_Extra_Constituents
21242 Report_Extra_Constituents_In_List (In_Constits);
21243 Report_Extra_Constituents_In_List (In_Out_Constits);
21244 Report_Extra_Constituents_In_List (Out_Constits);
21245 end Report_Extra_Constituents;
21249 Body_Decl : constant Node_Id := Parent (N);
21250 Errors : constant Nat := Serious_Errors_Detected;
21251 Items : constant Node_Id :=
21252 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
21253 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
21255 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
21258 Global := Get_Pragma (Spec_Id, Pragma_Global);
21260 -- The subprogram declaration lacks pragma Global. This renders
21261 -- Refined_Global useless as there is nothing to refine.
21263 if No (Global) then
21265 ("useless refinement, subprogram & lacks global items", N, Spec_Id);
21269 -- Extract all relevant items from the corresponding Global pragma
21271 Collect_Global_Items
21273 In_Items => In_Items,
21274 In_Out_Items => In_Out_Items,
21275 Out_Items => Out_Items,
21276 Has_In_State => Has_In_State,
21277 Has_In_Out_State => Has_In_Out_State,
21278 Has_Out_State => Has_Out_State,
21279 Has_Null_State => Has_Null_State);
21281 -- The corresponding Global pragma must mention at least one state with
21282 -- a visible refinement at the point Refined_Global is processed. States
21283 -- with null refinements warrant a Refined_Global pragma.
21285 if not Has_In_State
21286 and then not Has_In_Out_State
21287 and then not Has_Out_State
21288 and then not Has_Null_State
21291 ("useless refinement, subprogram & does not mention abstract state "
21292 & "with visible refinement", N, Spec_Id);
21296 -- The global refinement of inputs and outputs cannot be null when the
21297 -- corresponding Global pragma contains at least one item except in the
21298 -- case where we have states with null refinements.
21300 if Nkind (Items) = N_Null
21302 (Present (In_Items)
21303 or else Present (In_Out_Items)
21304 or else Present (Out_Items))
21305 and then not Has_Null_State
21308 ("refinement cannot be null, subprogram & has global items",
21313 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
21314 -- This ensures that the categorization of all refined global items is
21315 -- consistent with their role.
21317 Analyze_Global_In_Decl_Part (N);
21319 -- Perform all refinement checks with respect to completeness and mode
21322 if Serious_Errors_Detected = Errors then
21323 Check_Refined_Global_List (Items);
21326 -- For Input states with visible refinement, at least one constituent
21327 -- must be used as an Input in the global refinement.
21329 if Serious_Errors_Detected = Errors then
21330 Check_Input_States;
21333 -- Verify all possible completion variants for In_Out states with
21334 -- visible refinement.
21336 if Serious_Errors_Detected = Errors then
21337 Check_In_Out_States;
21340 -- For Output states with visible refinement, all constituents must be
21341 -- used as Outputs in the global refinement.
21343 if Serious_Errors_Detected = Errors then
21344 Check_Output_States;
21347 -- Emit errors for all constituents that belong to other states with
21348 -- visible refinement that do not appear in Global.
21350 if Serious_Errors_Detected = Errors then
21351 Report_Extra_Constituents;
21353 end Analyze_Refined_Global_In_Decl_Part;
21355 ----------------------------------------
21356 -- Analyze_Refined_State_In_Decl_Part --
21357 ----------------------------------------
21359 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
21360 Pack_Body : constant Node_Id := Parent (N);
21361 Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body);
21363 Abstr_States : Elist_Id := No_Elist;
21364 -- A list of all abstract states defined in the package declaration. The
21365 -- list is used to report unrefined states.
21367 Constituents_Seen : Elist_Id := No_Elist;
21368 -- A list that contains all constituents processed so far. The list is
21369 -- used to detect multiple uses of the same constituent.
21371 Hidden_States : Elist_Id := No_Elist;
21372 -- A list of all hidden states (abstract states and variables) that
21373 -- appear in the package spec and body. The list is used to report
21374 -- unused hidden states.
21376 Refined_States_Seen : Elist_Id := No_Elist;
21377 -- A list that contains all refined states processed so far. The list is
21378 -- used to detect duplicate refinements.
21380 procedure Analyze_Refinement_Clause (Clause : Node_Id);
21381 -- Perform full analysis of a single refinement clause
21383 procedure Collect_Hidden_States;
21384 -- Gather the entities of all hidden states that appear in the spec and
21385 -- body of the related package in Hidden_States.
21387 procedure Report_Unrefined_States;
21388 -- Emit errors for all abstract states that have not been refined by
21391 procedure Report_Unused_Hidden_States;
21392 -- Emit errors for all hidden states of the related package that do not
21393 -- participate in a refinement.
21395 -------------------------------
21396 -- Analyze_Refinement_Clause --
21397 -------------------------------
21399 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
21400 State_Id : Entity_Id := Empty;
21401 -- The entity of the state being refined in the current clause
21403 Non_Null_Seen : Boolean := False;
21404 Null_Seen : Boolean := False;
21405 -- Flags used to detect multiple uses of null in a single clause or a
21406 -- mixture of null and non-null constituents.
21408 procedure Analyze_Constituent (Constit : Node_Id);
21409 -- Perform full analysis of a single constituent
21411 procedure Check_Matching_State
21413 State_Id : Entity_Id);
21414 -- Determine whether state State denoted by its name State_Id appears
21415 -- in Abstr_States. Emit an error when attempting to re-refine the
21416 -- state or when the state is not defined in the package declaration.
21417 -- Otherwise remove the state from Abstr_States.
21419 -------------------------
21420 -- Analyze_Constituent --
21421 -------------------------
21423 procedure Analyze_Constituent (Constit : Node_Id) is
21424 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
21425 -- Determine whether constituent Constit denoted by its entity
21426 -- Constit_Id appears in Hidden_States. Emit an error when the
21427 -- constituent is not a valid hidden state of the related package
21428 -- or when it is used more than once. Otherwise remove the
21429 -- constituent from Hidden_States.
21431 --------------------------------
21432 -- Check_Matching_Constituent --
21433 --------------------------------
21435 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
21436 State_Elmt : Elmt_Id;
21439 -- Detect a duplicate use of a constituent
21441 if Contains (Constituents_Seen, Constit_Id) then
21443 ("duplicate use of constituent &", Constit, Constit_Id);
21446 -- A state can act as a constituent only when it is part of
21447 -- another state. This relation is expressed by option Part_Of
21448 -- of pragma Abstract_State.
21450 elsif Ekind (Constit_Id) = E_Abstract_State then
21451 if not Is_Part_Of (Constit_Id, State_Id) then
21452 Error_Msg_Name_1 := Chars (State_Id);
21454 ("state & is not a valid constituent of ancestor "
21455 & "state %", Constit, Constit_Id);
21458 -- The constituent has the proper Part_Of option, but may
21459 -- not appear in the immediate hidden state of the related
21460 -- package. This case arises when the constituent comes from
21461 -- a private child or a private sibling. Recognize these
21462 -- scenarios to avoid generating a bogus error message.
21464 elsif Is_Child_Or_Sibling
21465 (Pack_1 => Scope (State_Id),
21466 Pack_2 => Scope (Constit_Id),
21467 Private_Child => True)
21473 -- Inspect the hidden states of the related package looking for
21476 if Present (Hidden_States) then
21477 State_Elmt := First_Elmt (Hidden_States);
21478 while Present (State_Elmt) loop
21480 -- A valid hidden state or variable acts as a constituent
21482 if Node (State_Elmt) = Constit_Id then
21484 -- Add the constituent to the lis of processed items
21485 -- to aid with the detection of duplicates. Remove the
21486 -- constituent from Hidden_States to signal that it
21487 -- has already been matched.
21489 Add_Item (Constit_Id, Constituents_Seen);
21490 Remove_Elmt (Hidden_States, State_Elmt);
21492 -- Collect the constituent in the list of refinement
21493 -- items. Establish a relation between the refined
21494 -- state and its constituent.
21497 (Constit_Id, Refinement_Constituents (State_Id));
21498 Set_Refined_State (Constit_Id, State_Id);
21500 -- The state has at least one legal constituent, mark
21501 -- the start of the refinement region. The region ends
21502 -- when the body declarations end (see routine
21503 -- Analyze_Declarations).
21505 Set_Has_Visible_Refinement (State_Id);
21510 Next_Elmt (State_Elmt);
21514 -- If we get here, we are refining a state that is not hidden
21515 -- with respect to the related package.
21517 Error_Msg_Name_1 := Chars (Spec_Id);
21519 ("cannot use & in refinement, constituent is not a hidden "
21520 & "state of package %", Constit, Constit_Id);
21521 end Check_Matching_Constituent;
21525 Constit_Id : Entity_Id;
21527 -- Start of processing for Analyze_Constituent
21530 -- Detect multiple uses of null in a single refinement clause or a
21531 -- mixture of null and non-null constituents.
21533 if Nkind (Constit) = N_Null then
21536 ("multiple null constituents not allowed", Constit);
21538 elsif Non_Null_Seen then
21540 ("cannot mix null and non-null constituents", Constit);
21545 -- Collect the constituent in the list of refinement items
21547 Append_Elmt (Constit, Refinement_Constituents (State_Id));
21549 -- The state has at least one legal constituent, mark the
21550 -- start of the refinement region. The region ends when the
21551 -- body declarations end (see Analyze_Declarations).
21553 Set_Has_Visible_Refinement (State_Id);
21556 -- Non-null constituents
21559 Non_Null_Seen := True;
21563 ("cannot mix null and non-null constituents", Constit);
21568 -- Ensure that the constituent denotes a valid state or a
21571 if Is_Entity_Name (Constit) then
21572 Constit_Id := Entity (Constit);
21574 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
21575 Check_Matching_Constituent (Constit_Id);
21579 ("constituent & must denote a variable or state",
21580 Constit, Constit_Id);
21583 -- The constituent is illegal
21586 Error_Msg_N ("malformed constituent", Constit);
21589 end Analyze_Constituent;
21591 --------------------------
21592 -- Check_Matching_State --
21593 --------------------------
21595 procedure Check_Matching_State
21597 State_Id : Entity_Id)
21599 State_Elmt : Elmt_Id;
21602 -- Detect a duplicate refinement of a state
21604 if Contains (Refined_States_Seen, State_Id) then
21606 ("duplicate refinement of state &", State, State_Id);
21610 -- Inspect the abstract states defined in the package declaration
21611 -- looking for a match.
21613 State_Elmt := First_Elmt (Abstr_States);
21614 while Present (State_Elmt) loop
21616 -- A valid abstract state is being refined in the body. Add
21617 -- the state to the list of processed refined states to aid
21618 -- with the detection of duplicate refinements. Remove the
21619 -- state from Abstr_States to signal that it has already been
21622 if Node (State_Elmt) = State_Id then
21623 Add_Item (State_Id, Refined_States_Seen);
21624 Remove_Elmt (Abstr_States, State_Elmt);
21628 Next_Elmt (State_Elmt);
21631 -- If we get here, we are refining a state that is not defined in
21632 -- the package declaration.
21634 Error_Msg_Name_1 := Chars (Spec_Id);
21636 ("cannot refine state, & is not defined in package %",
21638 end Check_Matching_State;
21640 -- Local declarations
21645 -- Start of processing for Analyze_Refinement_Clause
21648 -- Analyze the state name of a refinement clause
21650 State := First (Choices (Clause));
21651 while Present (State) loop
21652 if Present (State_Id) then
21654 ("refinement clause cannot cover multiple states", State);
21659 -- Ensure that the state name denotes a valid abstract state
21660 -- that is defined in the spec of the related package.
21662 if Is_Entity_Name (State) then
21663 State_Id := Entity (State);
21665 -- Catch any attempts to re-refine a state or refine a
21666 -- state that is not defined in the package declaration.
21668 if Ekind (State_Id) = E_Abstract_State then
21669 Check_Matching_State (State, State_Id);
21672 ("& must denote an abstract state", State, State_Id);
21675 -- Enforce SPARK RM (6.1.5(4)): A global item shall not
21676 -- denote a state abstraction whose refinement is visible
21677 -- (a state abstraction cannot be named within its enclosing
21678 -- package's body other than in its refinement).
21680 if Has_Body_References (State_Id) then
21685 Ref := First_Elmt (Body_References (State_Id));
21686 while Present (Ref) loop
21689 ("global reference to & not allowed "
21690 & "(SPARK RM 6.1.5(4))", Nod);
21691 Error_Msg_Sloc := Sloc (State);
21692 Error_Msg_N ("\refinement of & is visible#", Nod);
21698 -- The state name is illegal
21702 ("malformed state name in refinement clause", State);
21709 -- Analyze all constituents of the refinement. Multiple constituents
21710 -- appear as an aggregate.
21712 Constit := Expression (Clause);
21714 if Nkind (Constit) = N_Aggregate then
21715 if Present (Component_Associations (Constit)) then
21717 ("constituents of refinement clause must appear in "
21718 & "positional form", Constit);
21720 else pragma Assert (Present (Expressions (Constit)));
21721 Constit := First (Expressions (Constit));
21722 while Present (Constit) loop
21723 Analyze_Constituent (Constit);
21729 -- Various forms of a single constituent. Note that these may include
21730 -- malformed constituents.
21733 Analyze_Constituent (Constit);
21735 end Analyze_Refinement_Clause;
21737 ---------------------------
21738 -- Collect_Hidden_States --
21739 ---------------------------
21741 procedure Collect_Hidden_States is
21742 procedure Collect_Hidden_States_In_Decls (Decls : List_Id);
21743 -- Find all hidden states that appear in declarative list Decls and
21744 -- append their entities to Result.
21746 ------------------------------------
21747 -- Collect_Hidden_States_In_Decls --
21748 ------------------------------------
21750 procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is
21751 procedure Collect_Abstract_States (States : Elist_Id);
21752 -- Copy the abstract states defined in list States to list Result
21754 -----------------------------
21755 -- Collect_Abstract_States --
21756 -----------------------------
21758 procedure Collect_Abstract_States (States : Elist_Id) is
21759 State_Elmt : Elmt_Id;
21762 State_Elmt := First_Elmt (States);
21763 while Present (State_Elmt) loop
21764 Add_Item (Node (State_Elmt), Hidden_States);
21766 Next_Elmt (State_Elmt);
21768 end Collect_Abstract_States;
21774 -- Start of processing for Collect_Hidden_States_In_Decls
21777 Decl := First (Decls);
21778 while Present (Decl) loop
21780 -- Source objects (non-constants) are valid hidden states
21782 if Nkind (Decl) = N_Object_Declaration
21783 and then Ekind (Defining_Entity (Decl)) = E_Variable
21784 and then Comes_From_Source (Decl)
21786 Add_Item (Defining_Entity (Decl), Hidden_States);
21788 -- Gather the abstract states of a package along with all
21789 -- hidden states in its visible declarations.
21791 elsif Nkind (Decl) = N_Package_Declaration then
21792 Collect_Abstract_States
21793 (Abstract_States (Defining_Entity (Decl)));
21795 Collect_Hidden_States_In_Decls
21796 (Visible_Declarations (Specification (Decl)));
21801 end Collect_Hidden_States_In_Decls;
21805 Pack_Spec : constant Node_Id := Package_Specification (Spec_Id);
21807 -- Start of processing for Collect_Hidden_States
21810 -- Process the private declarations of the package spec and the
21811 -- declarations of the body.
21813 Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec));
21814 Collect_Hidden_States_In_Decls (Declarations (Pack_Body));
21815 end Collect_Hidden_States;
21817 -----------------------------
21818 -- Report_Unrefined_States --
21819 -----------------------------
21821 procedure Report_Unrefined_States is
21822 State_Elmt : Elmt_Id;
21825 if Present (Abstr_States) then
21826 State_Elmt := First_Elmt (Abstr_States);
21827 while Present (State_Elmt) loop
21829 ("abstract state & must be refined", Node (State_Elmt));
21831 Next_Elmt (State_Elmt);
21834 end Report_Unrefined_States;
21836 ---------------------------------
21837 -- Report_Unused_Hidden_States --
21838 ---------------------------------
21840 procedure Report_Unused_Hidden_States is
21841 Posted : Boolean := False;
21842 State_Elmt : Elmt_Id;
21843 State_Id : Entity_Id;
21846 if Present (Hidden_States) then
21847 State_Elmt := First_Elmt (Hidden_States);
21848 while Present (State_Elmt) loop
21849 State_Id := Node (State_Elmt);
21851 -- Generate an error message of the form:
21853 -- package ... has unused hidden states
21854 -- abstract state ... defined at ...
21855 -- variable ... defined at ...
21860 ("package & has unused hidden states", N, Spec_Id);
21863 Error_Msg_Sloc := Sloc (State_Id);
21865 if Ekind (State_Id) = E_Abstract_State then
21866 Error_Msg_NE ("\ abstract state & defined #", N, State_Id);
21868 Error_Msg_NE ("\ variable & defined #", N, State_Id);
21871 Next_Elmt (State_Elmt);
21874 end Report_Unused_Hidden_States;
21876 -- Local declarations
21878 Clauses : constant Node_Id :=
21879 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
21882 -- Start of processing for Analyze_Refined_State_In_Decl_Part
21887 -- Initialize the various lists used during analysis
21889 Abstr_States := New_Copy_Elist (Abstract_States (Spec_Id));
21890 Collect_Hidden_States;
21892 -- Multiple state refinements appear as an aggregate
21894 if Nkind (Clauses) = N_Aggregate then
21895 if Present (Expressions (Clauses)) then
21897 ("state refinements must appear as component associations",
21900 else pragma Assert (Present (Component_Associations (Clauses)));
21901 Clause := First (Component_Associations (Clauses));
21902 while Present (Clause) loop
21903 Analyze_Refinement_Clause (Clause);
21909 -- Various forms of a single state refinement. Note that these may
21910 -- include malformed refinements.
21913 Analyze_Refinement_Clause (Clauses);
21916 -- Ensure that all abstract states have been refined and all hidden
21917 -- states of the related package unilized in refinements.
21919 Report_Unrefined_States;
21920 Report_Unused_Hidden_States;
21921 end Analyze_Refined_State_In_Decl_Part;
21923 ------------------------------------
21924 -- Analyze_Test_Case_In_Decl_Part --
21925 ------------------------------------
21927 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
21929 -- Install formals and push subprogram spec onto scope stack so that we
21930 -- can see the formals from the pragma.
21933 Install_Formals (S);
21935 -- Preanalyze the boolean expressions, we treat these as spec
21936 -- expressions (i.e. similar to a default expression).
21938 if Pragma_Name (N) = Name_Test_Case then
21939 Preanalyze_CTC_Args
21941 Get_Requires_From_CTC_Pragma (N),
21942 Get_Ensures_From_CTC_Pragma (N));
21945 -- Remove the subprogram from the scope stack now that the pre-analysis
21946 -- of the expressions in the contract case or test case is done.
21949 end Analyze_Test_Case_In_Decl_Part;
21955 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
21960 if Present (List) then
21961 Elmt := First_Elmt (List);
21962 while Present (Elmt) loop
21963 if Nkind (Node (Elmt)) = N_Defining_Identifier then
21966 Id := Entity (Node (Elmt));
21969 if Id = Item_Id then
21984 function Check_Kind (Nam : Name_Id) return Name_Id is
21988 -- Loop through entries in check policy list
21990 PP := Opt.Check_Policy_List;
21991 while Present (PP) loop
21993 PPA : constant List_Id := Pragma_Argument_Associations (PP);
21994 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
21998 or else (Pnm = Name_Assertion
21999 and then Is_Valid_Assertion_Kind (Nam))
22000 or else (Pnm = Name_Statement_Assertions
22001 and then Nam_In (Nam, Name_Assert,
22002 Name_Assert_And_Cut,
22004 Name_Loop_Invariant))
22006 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
22007 when Name_On | Name_Check =>
22009 when Name_Off | Name_Ignore =>
22010 return Name_Ignore;
22011 when Name_Disable =>
22012 return Name_Disable;
22014 raise Program_Error;
22018 PP := Next_Pragma (PP);
22023 -- If there are no specific entries that matched, then we let the
22024 -- setting of assertions govern. Note that this provides the needed
22025 -- compatibility with the RM for the cases of assertion, invariant,
22026 -- precondition, predicate, and postcondition.
22028 if Assertions_Enabled then
22031 return Name_Ignore;
22035 -----------------------------
22036 -- Check_Applicable_Policy --
22037 -----------------------------
22039 procedure Check_Applicable_Policy (N : Node_Id) is
22043 Ename : constant Name_Id := Original_Aspect_Name (N);
22046 -- No effect if not valid assertion kind name
22048 if not Is_Valid_Assertion_Kind (Ename) then
22052 -- Loop through entries in check policy list
22054 PP := Opt.Check_Policy_List;
22055 while Present (PP) loop
22057 PPA : constant List_Id := Pragma_Argument_Associations (PP);
22058 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
22062 or else Pnm = Name_Assertion
22063 or else (Pnm = Name_Statement_Assertions
22064 and then (Ename = Name_Assert or else
22065 Ename = Name_Assert_And_Cut or else
22066 Ename = Name_Assume or else
22067 Ename = Name_Loop_Invariant))
22069 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
22072 when Name_Off | Name_Ignore =>
22073 Set_Is_Ignored (N, True);
22074 Set_Is_Checked (N, False);
22076 when Name_On | Name_Check =>
22077 Set_Is_Checked (N, True);
22078 Set_Is_Ignored (N, False);
22080 when Name_Disable =>
22081 Set_Is_Ignored (N, True);
22082 Set_Is_Checked (N, False);
22083 Set_Is_Disabled (N, True);
22085 -- That should be exhaustive, the null here is a defence
22086 -- against a malformed tree from previous errors.
22095 PP := Next_Pragma (PP);
22099 -- If there are no specific entries that matched, then we let the
22100 -- setting of assertions govern. Note that this provides the needed
22101 -- compatibility with the RM for the cases of assertion, invariant,
22102 -- precondition, predicate, and postcondition.
22104 if Assertions_Enabled then
22105 Set_Is_Checked (N, True);
22106 Set_Is_Ignored (N, False);
22108 Set_Is_Checked (N, False);
22109 Set_Is_Ignored (N, True);
22111 end Check_Applicable_Policy;
22113 --------------------------
22114 -- Collect_Global_Items --
22115 --------------------------
22117 procedure Collect_Global_Items
22119 In_Items : in out Elist_Id;
22120 In_Out_Items : in out Elist_Id;
22121 Out_Items : in out Elist_Id;
22122 Has_In_State : out Boolean;
22123 Has_In_Out_State : out Boolean;
22124 Has_Out_State : out Boolean;
22125 Has_Null_State : out Boolean)
22127 procedure Process_Global_List
22129 Mode : Name_Id := Name_Input);
22130 -- Collect all items housed in a global list. Formal Mode denotes the
22131 -- current mode in effect.
22133 -------------------------
22134 -- Process_Global_List --
22135 -------------------------
22137 procedure Process_Global_List
22139 Mode : Name_Id := Name_Input)
22141 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id);
22142 -- Add a single item to the appropriate list. Formal Mode denotes the
22143 -- current mode in effect.
22145 -------------------------
22146 -- Process_Global_Item --
22147 -------------------------
22149 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is
22150 Item_Id : constant Entity_Id := Entity_Of (Item);
22153 -- Signal that the global list contains at least one abstract
22154 -- state with a visible refinement. Note that the refinement may
22155 -- be null in which case there are no constituents.
22157 if Ekind (Item_Id) = E_Abstract_State then
22158 if Has_Null_Refinement (Item_Id) then
22159 Has_Null_State := True;
22161 elsif Has_Non_Null_Refinement (Item_Id) then
22162 if Mode = Name_Input then
22163 Has_In_State := True;
22164 elsif Mode = Name_In_Out then
22165 Has_In_Out_State := True;
22166 elsif Mode = Name_Output then
22167 Has_Out_State := True;
22172 -- Add the item to the proper list
22174 if Mode = Name_Input then
22175 Add_Item (Item_Id, In_Items);
22176 elsif Mode = Name_In_Out then
22177 Add_Item (Item_Id, In_Out_Items);
22178 elsif Mode = Name_Output then
22179 Add_Item (Item_Id, Out_Items);
22181 end Process_Global_Item;
22187 -- Start of processing for Process_Global_List
22190 if Nkind (List) = N_Null then
22193 -- Single global item declaration
22195 elsif Nkind_In (List, N_Expanded_Name,
22197 N_Selected_Component)
22199 Process_Global_Item (List, Mode);
22201 -- Single global list or moded global list declaration
22203 elsif Nkind (List) = N_Aggregate then
22205 -- The declaration of a simple global list appear as a collection
22208 if Present (Expressions (List)) then
22209 Item := First (Expressions (List));
22210 while Present (Item) loop
22211 Process_Global_Item (Item, Mode);
22216 -- The declaration of a moded global list appears as a collection
22217 -- of component associations where individual choices denote mode.
22219 elsif Present (Component_Associations (List)) then
22220 Item := First (Component_Associations (List));
22221 while Present (Item) loop
22222 Process_Global_List
22223 (List => Expression (Item),
22224 Mode => Chars (First (Choices (Item))));
22232 raise Program_Error;
22238 raise Program_Error;
22240 end Process_Global_List;
22244 Items : constant Node_Id :=
22245 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
22247 -- Start of processing for Collect_Global_Items
22250 -- Assume that no states have been encountered
22252 Has_In_State := False;
22253 Has_In_Out_State := False;
22254 Has_Out_State := False;
22255 Has_Null_State := False;
22257 Process_Global_List (Items);
22258 end Collect_Global_Items;
22260 ---------------------------------------
22261 -- Collect_Subprogram_Inputs_Outputs --
22262 ---------------------------------------
22264 procedure Collect_Subprogram_Inputs_Outputs
22265 (Subp_Id : Entity_Id;
22266 Subp_Inputs : in out Elist_Id;
22267 Subp_Outputs : in out Elist_Id;
22268 Global_Seen : out Boolean)
22270 procedure Collect_Global_List
22272 Mode : Name_Id := Name_Input);
22273 -- Collect all relevant items from a global list
22275 -------------------------
22276 -- Collect_Global_List --
22277 -------------------------
22279 procedure Collect_Global_List
22281 Mode : Name_Id := Name_Input)
22283 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
22284 -- Add an item to the proper subprogram input or output collection
22286 -------------------------
22287 -- Collect_Global_Item --
22288 -------------------------
22290 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
22292 if Nam_In (Mode, Name_In_Out, Name_Input) then
22293 Add_Item (Item, Subp_Inputs);
22296 if Nam_In (Mode, Name_In_Out, Name_Output) then
22297 Add_Item (Item, Subp_Outputs);
22299 end Collect_Global_Item;
22306 -- Start of processing for Collect_Global_List
22309 if Nkind (List) = N_Null then
22312 -- Single global item declaration
22314 elsif Nkind_In (List, N_Expanded_Name,
22316 N_Selected_Component)
22318 Collect_Global_Item (List, Mode);
22320 -- Simple global list or moded global list declaration
22322 elsif Nkind (List) = N_Aggregate then
22323 if Present (Expressions (List)) then
22324 Item := First (Expressions (List));
22325 while Present (Item) loop
22326 Collect_Global_Item (Item, Mode);
22331 Assoc := First (Component_Associations (List));
22332 while Present (Assoc) loop
22333 Collect_Global_List
22334 (List => Expression (Assoc),
22335 Mode => Chars (First (Choices (Assoc))));
22343 raise Program_Error;
22345 end Collect_Global_List;
22349 Formal : Entity_Id;
22352 Spec_Id : Entity_Id;
22354 -- Start of processing for Collect_Subprogram_Inputs_Outputs
22357 Global_Seen := False;
22359 -- Find the entity of the corresponding spec when processing a body
22361 if Ekind (Subp_Id) = E_Subprogram_Body then
22362 Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id)));
22364 Spec_Id := Subp_Id;
22367 -- Process all formal parameters
22369 Formal := First_Formal (Spec_Id);
22370 while Present (Formal) loop
22371 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
22372 Add_Item (Formal, Subp_Inputs);
22375 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
22376 Add_Item (Formal, Subp_Outputs);
22378 -- Out parameters can act as inputs when the related type is
22379 -- tagged, unconstrained array, unconstrained record or record
22380 -- with unconstrained components.
22382 if Ekind (Formal) = E_Out_Parameter
22383 and then Is_Unconstrained_Or_Tagged_Item (Formal)
22385 Add_Item (Formal, Subp_Inputs);
22389 Next_Formal (Formal);
22392 -- When processing a subprogram body, look for pragma Refined_Global as
22393 -- it provides finer granularity of inputs and outputs.
22395 if Ekind (Subp_Id) = E_Subprogram_Body then
22396 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
22398 -- Subprogram declaration case, look for pragma Global
22401 Global := Get_Pragma (Spec_Id, Pragma_Global);
22404 if Present (Global) then
22405 Global_Seen := True;
22406 List := Expression (First (Pragma_Argument_Associations (Global)));
22408 -- The pragma may not have been analyzed because of the arbitrary
22409 -- declaration order of aspects. Make sure that it is analyzed for
22410 -- the purposes of item extraction.
22412 if not Analyzed (List) then
22413 if Pragma_Name (Global) = Name_Refined_Global then
22414 Analyze_Refined_Global_In_Decl_Part (Global);
22416 Analyze_Global_In_Decl_Part (Global);
22420 -- Nothing to be done for a null global list
22422 if Nkind (List) /= N_Null then
22423 Collect_Global_List (List);
22426 end Collect_Subprogram_Inputs_Outputs;
22428 ---------------------------------
22429 -- Delay_Config_Pragma_Analyze --
22430 ---------------------------------
22432 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
22434 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
22435 Name_Priority_Specific_Dispatching);
22436 end Delay_Config_Pragma_Analyze;
22438 -------------------------------------
22439 -- Find_Related_Subprogram_Or_Body --
22440 -------------------------------------
22442 function Find_Related_Subprogram_Or_Body
22444 Do_Checks : Boolean := False) return Node_Id
22446 Context : constant Node_Id := Parent (Prag);
22447 Nam : constant Name_Id := Pragma_Name (Prag);
22450 Look_For_Body : constant Boolean :=
22451 Nam_In (Nam, Name_Refined_Depends,
22452 Name_Refined_Global,
22453 Name_Refined_Post);
22454 -- Refinement pragmas must be associated with a subprogram body [stub]
22457 pragma Assert (Nkind (Prag) = N_Pragma);
22459 -- If the pragma is a byproduct of aspect expansion, return the related
22460 -- context of the original aspect.
22462 if Present (Corresponding_Aspect (Prag)) then
22463 return Parent (Corresponding_Aspect (Prag));
22466 -- Otherwise the pragma is a source construct, most likely part of a
22467 -- declarative list. Skip preceding declarations while looking for a
22468 -- proper subprogram declaration.
22470 pragma Assert (Is_List_Member (Prag));
22472 Stmt := Prev (Prag);
22473 while Present (Stmt) loop
22475 -- Skip prior pragmas, but check for duplicates
22477 if Nkind (Stmt) = N_Pragma then
22478 if Do_Checks and then Pragma_Name (Stmt) = Nam then
22479 Error_Msg_Name_1 := Nam;
22480 Error_Msg_Sloc := Sloc (Stmt);
22481 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
22484 -- Emit an error when a refinement pragma appears on an expression
22485 -- function without a completion.
22488 and then Look_For_Body
22489 and then Nkind (Stmt) = N_Subprogram_Declaration
22490 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
22491 and then not Has_Completion (Defining_Entity (Stmt))
22493 Error_Msg_Name_1 := Nam;
22495 ("pragma % cannot apply to a stand alone expression function",
22500 -- The refinement pragma applies to a subprogram body stub
22502 elsif Look_For_Body
22503 and then Nkind (Stmt) = N_Subprogram_Body_Stub
22507 -- Skip internally generated code
22509 elsif not Comes_From_Source (Stmt) then
22512 -- Return the current construct which is either a subprogram body,
22513 -- a subprogram declaration or is illegal.
22522 -- If we fall through, then the pragma was either the first declaration
22523 -- or it was preceded by other pragmas and no source constructs.
22525 -- The pragma is associated with a library-level subprogram
22527 if Nkind (Context) = N_Compilation_Unit_Aux then
22528 return Unit (Parent (Context));
22530 -- The pragma appears inside the declarative part of a subprogram body
22532 elsif Nkind (Context) = N_Subprogram_Body then
22535 -- No candidate subprogram [body] found
22540 end Find_Related_Subprogram_Or_Body;
22542 -------------------------
22543 -- Get_Base_Subprogram --
22544 -------------------------
22546 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
22547 Result : Entity_Id;
22550 -- Follow subprogram renaming chain
22554 if Is_Subprogram (Result)
22556 Nkind (Parent (Declaration_Node (Result))) =
22557 N_Subprogram_Renaming_Declaration
22558 and then Present (Alias (Result))
22560 Result := Alias (Result);
22564 end Get_Base_Subprogram;
22566 -----------------------
22567 -- Get_SPARK_Mode_Id --
22568 -----------------------
22570 function Get_SPARK_Mode_Id (N : Name_Id) return SPARK_Mode_Id is
22572 if N = Name_On then
22574 elsif N = Name_Off then
22576 elsif N = Name_Auto then
22579 -- Any other argument is erroneous
22582 raise Program_Error;
22584 end Get_SPARK_Mode_Id;
22586 -----------------------
22587 -- Get_SPARK_Mode_Id --
22588 -----------------------
22590 function Get_SPARK_Mode_Id (N : Node_Id) return SPARK_Mode_Id is
22595 pragma Assert (Nkind (N) = N_Pragma);
22596 Args := Pragma_Argument_Associations (N);
22598 -- Extract the mode from the argument list
22600 if Present (Args) then
22601 Mode := First (Pragma_Argument_Associations (N));
22602 return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
22604 -- When SPARK_Mode appears without an argument, the default is ON
22609 end Get_SPARK_Mode_Id;
22615 procedure Initialize is
22620 -----------------------------
22621 -- Is_Config_Static_String --
22622 -----------------------------
22624 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
22626 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
22627 -- This is an internal recursive function that is just like the outer
22628 -- function except that it adds the string to the name buffer rather
22629 -- than placing the string in the name buffer.
22631 ------------------------------
22632 -- Add_Config_Static_String --
22633 ------------------------------
22635 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
22642 if Nkind (N) = N_Op_Concat then
22643 if Add_Config_Static_String (Left_Opnd (N)) then
22644 N := Right_Opnd (N);
22650 if Nkind (N) /= N_String_Literal then
22651 Error_Msg_N ("string literal expected for pragma argument", N);
22655 for J in 1 .. String_Length (Strval (N)) loop
22656 C := Get_String_Char (Strval (N), J);
22658 if not In_Character_Range (C) then
22660 ("string literal contains invalid wide character",
22661 Sloc (N) + 1 + Source_Ptr (J));
22665 Add_Char_To_Name_Buffer (Get_Character (C));
22670 end Add_Config_Static_String;
22672 -- Start of processing for Is_Config_Static_String
22677 return Add_Config_Static_String (Arg);
22678 end Is_Config_Static_String;
22680 -------------------------------
22681 -- Is_Elaboration_SPARK_Mode --
22682 -------------------------------
22684 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
22687 (Nkind (N) = N_Pragma
22688 and then Pragma_Name (N) = Name_SPARK_Mode
22689 and then Is_List_Member (N));
22691 -- Pragma SPARK_Mode affects the elaboration of a package body when it
22692 -- appears in the statement part of the body.
22695 Present (Parent (N))
22696 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
22697 and then List_Containing (N) = Statements (Parent (N))
22698 and then Present (Parent (Parent (N)))
22699 and then Nkind (Parent (Parent (N))) = N_Package_Body;
22700 end Is_Elaboration_SPARK_Mode;
22702 -----------------------------------------
22703 -- Is_Non_Significant_Pragma_Reference --
22704 -----------------------------------------
22706 -- This function makes use of the following static table which indicates
22707 -- whether appearance of some name in a given pragma is to be considered
22708 -- as a reference for the purposes of warnings about unreferenced objects.
22710 -- -1 indicates that references in any argument position are significant
22711 -- 0 indicates that appearance in any argument is not significant
22712 -- +n indicates that appearance as argument n is significant, but all
22713 -- other arguments are not significant
22714 -- 99 special processing required (e.g. for pragma Check)
22716 Sig_Flags : constant array (Pragma_Id) of Int :=
22717 (Pragma_AST_Entry => -1,
22718 Pragma_Abort_Defer => -1,
22719 Pragma_Abstract_State => -1,
22720 Pragma_Ada_83 => -1,
22721 Pragma_Ada_95 => -1,
22722 Pragma_Ada_05 => -1,
22723 Pragma_Ada_2005 => -1,
22724 Pragma_Ada_12 => -1,
22725 Pragma_Ada_2012 => -1,
22726 Pragma_All_Calls_Remote => -1,
22727 Pragma_Annotate => -1,
22728 Pragma_Assert => -1,
22729 Pragma_Assert_And_Cut => -1,
22730 Pragma_Assertion_Policy => 0,
22731 Pragma_Assume => -1,
22732 Pragma_Assume_No_Invalid_Values => 0,
22733 Pragma_Attribute_Definition => +3,
22734 Pragma_Asynchronous => -1,
22735 Pragma_Atomic => 0,
22736 Pragma_Atomic_Components => 0,
22737 Pragma_Attach_Handler => -1,
22738 Pragma_Check => 99,
22739 Pragma_Check_Float_Overflow => 0,
22740 Pragma_Check_Name => 0,
22741 Pragma_Check_Policy => 0,
22742 Pragma_CIL_Constructor => -1,
22743 Pragma_CPP_Class => 0,
22744 Pragma_CPP_Constructor => 0,
22745 Pragma_CPP_Virtual => 0,
22746 Pragma_CPP_Vtable => 0,
22748 Pragma_C_Pass_By_Copy => 0,
22749 Pragma_Comment => 0,
22750 Pragma_Common_Object => -1,
22751 Pragma_Compile_Time_Error => -1,
22752 Pragma_Compile_Time_Warning => -1,
22753 Pragma_Compiler_Unit => 0,
22754 Pragma_Complete_Representation => 0,
22755 Pragma_Complex_Representation => 0,
22756 Pragma_Component_Alignment => -1,
22757 Pragma_Contract_Cases => -1,
22758 Pragma_Controlled => 0,
22759 Pragma_Convention => 0,
22760 Pragma_Convention_Identifier => 0,
22761 Pragma_Debug => -1,
22762 Pragma_Debug_Policy => 0,
22763 Pragma_Detect_Blocking => -1,
22764 Pragma_Default_Storage_Pool => -1,
22765 Pragma_Depends => -1,
22766 Pragma_Disable_Atomic_Synchronization => -1,
22767 Pragma_Discard_Names => 0,
22768 Pragma_Dispatching_Domain => -1,
22769 Pragma_Elaborate => -1,
22770 Pragma_Elaborate_All => -1,
22771 Pragma_Elaborate_Body => -1,
22772 Pragma_Elaboration_Checks => -1,
22773 Pragma_Eliminate => -1,
22774 Pragma_Enable_Atomic_Synchronization => -1,
22775 Pragma_Export => -1,
22776 Pragma_Export_Exception => -1,
22777 Pragma_Export_Function => -1,
22778 Pragma_Export_Object => -1,
22779 Pragma_Export_Procedure => -1,
22780 Pragma_Export_Value => -1,
22781 Pragma_Export_Valued_Procedure => -1,
22782 Pragma_Extend_System => -1,
22783 Pragma_Extensions_Allowed => -1,
22784 Pragma_External => -1,
22785 Pragma_Favor_Top_Level => -1,
22786 Pragma_External_Name_Casing => -1,
22787 Pragma_Fast_Math => -1,
22788 Pragma_Finalize_Storage_Only => 0,
22789 Pragma_Float_Representation => 0,
22790 Pragma_Global => -1,
22791 Pragma_Ident => -1,
22792 Pragma_Implementation_Defined => -1,
22793 Pragma_Implemented => -1,
22794 Pragma_Implicit_Packing => 0,
22795 Pragma_Import => +2,
22796 Pragma_Import_Exception => 0,
22797 Pragma_Import_Function => 0,
22798 Pragma_Import_Object => 0,
22799 Pragma_Import_Procedure => 0,
22800 Pragma_Import_Valued_Procedure => 0,
22801 Pragma_Independent => 0,
22802 Pragma_Independent_Components => 0,
22803 Pragma_Initial_Condition => -1,
22804 Pragma_Initialize_Scalars => -1,
22805 Pragma_Initializes => -1,
22806 Pragma_Inline => 0,
22807 Pragma_Inline_Always => 0,
22808 Pragma_Inline_Generic => 0,
22809 Pragma_Inspection_Point => -1,
22810 Pragma_Interface => +2,
22811 Pragma_Interface_Name => +2,
22812 Pragma_Interrupt_Handler => -1,
22813 Pragma_Interrupt_Priority => -1,
22814 Pragma_Interrupt_State => -1,
22815 Pragma_Invariant => -1,
22816 Pragma_Java_Constructor => -1,
22817 Pragma_Java_Interface => -1,
22818 Pragma_Keep_Names => 0,
22819 Pragma_License => -1,
22820 Pragma_Link_With => -1,
22821 Pragma_Linker_Alias => -1,
22822 Pragma_Linker_Constructor => -1,
22823 Pragma_Linker_Destructor => -1,
22824 Pragma_Linker_Options => -1,
22825 Pragma_Linker_Section => -1,
22827 Pragma_Lock_Free => -1,
22828 Pragma_Locking_Policy => -1,
22829 Pragma_Long_Float => -1,
22830 Pragma_Loop_Invariant => -1,
22831 Pragma_Loop_Optimize => -1,
22832 Pragma_Loop_Variant => -1,
22833 Pragma_Machine_Attribute => -1,
22835 Pragma_Main_Storage => -1,
22836 Pragma_Memory_Size => -1,
22837 Pragma_No_Return => 0,
22838 Pragma_No_Body => 0,
22839 Pragma_No_Inline => 0,
22840 Pragma_No_Run_Time => -1,
22841 Pragma_No_Strict_Aliasing => -1,
22842 Pragma_Normalize_Scalars => -1,
22843 Pragma_Obsolescent => 0,
22844 Pragma_Optimize => -1,
22845 Pragma_Optimize_Alignment => -1,
22846 Pragma_Overflow_Mode => 0,
22847 Pragma_Overriding_Renamings => 0,
22848 Pragma_Ordered => 0,
22851 Pragma_Partition_Elaboration_Policy => -1,
22852 Pragma_Passive => -1,
22853 Pragma_Persistent_BSS => 0,
22854 Pragma_Polling => -1,
22856 Pragma_Postcondition => -1,
22857 Pragma_Post_Class => -1,
22859 Pragma_Precondition => -1,
22860 Pragma_Predicate => -1,
22861 Pragma_Preelaborable_Initialization => -1,
22862 Pragma_Preelaborate => -1,
22863 Pragma_Preelaborate_05 => -1,
22864 Pragma_Pre_Class => -1,
22865 Pragma_Priority => -1,
22866 Pragma_Priority_Specific_Dispatching => -1,
22867 Pragma_Profile => 0,
22868 Pragma_Profile_Warnings => 0,
22869 Pragma_Propagate_Exceptions => -1,
22870 Pragma_Psect_Object => -1,
22872 Pragma_Pure_05 => -1,
22873 Pragma_Pure_12 => -1,
22874 Pragma_Pure_Function => -1,
22875 Pragma_Queuing_Policy => -1,
22876 Pragma_Rational => -1,
22877 Pragma_Ravenscar => -1,
22878 Pragma_Refined_Depends => -1,
22879 Pragma_Refined_Global => -1,
22880 Pragma_Refined_Post => -1,
22881 Pragma_Refined_State => -1,
22882 Pragma_Relative_Deadline => -1,
22883 Pragma_Remote_Access_Type => -1,
22884 Pragma_Remote_Call_Interface => -1,
22885 Pragma_Remote_Types => -1,
22886 Pragma_Restricted_Run_Time => -1,
22887 Pragma_Restriction_Warnings => -1,
22888 Pragma_Restrictions => -1,
22889 Pragma_Reviewable => -1,
22890 Pragma_Short_Circuit_And_Or => -1,
22891 Pragma_Share_Generic => -1,
22892 Pragma_Shared => -1,
22893 Pragma_Shared_Passive => -1,
22894 Pragma_Short_Descriptors => 0,
22895 Pragma_Simple_Storage_Pool_Type => 0,
22896 Pragma_Source_File_Name => -1,
22897 Pragma_Source_File_Name_Project => -1,
22898 Pragma_Source_Reference => -1,
22899 Pragma_SPARK_Mode => 0,
22900 Pragma_Storage_Size => -1,
22901 Pragma_Storage_Unit => -1,
22902 Pragma_Static_Elaboration_Desired => -1,
22903 Pragma_Stream_Convert => -1,
22904 Pragma_Style_Checks => -1,
22905 Pragma_Subtitle => -1,
22906 Pragma_Suppress => 0,
22907 Pragma_Suppress_Exception_Locations => 0,
22908 Pragma_Suppress_All => -1,
22909 Pragma_Suppress_Debug_Info => 0,
22910 Pragma_Suppress_Initialization => 0,
22911 Pragma_System_Name => -1,
22912 Pragma_Task_Dispatching_Policy => -1,
22913 Pragma_Task_Info => -1,
22914 Pragma_Task_Name => -1,
22915 Pragma_Task_Storage => 0,
22916 Pragma_Test_Case => -1,
22917 Pragma_Thread_Local_Storage => 0,
22918 Pragma_Time_Slice => -1,
22919 Pragma_Title => -1,
22920 Pragma_Type_Invariant => -1,
22921 Pragma_Type_Invariant_Class => -1,
22922 Pragma_Unchecked_Union => 0,
22923 Pragma_Unimplemented_Unit => -1,
22924 Pragma_Universal_Aliasing => -1,
22925 Pragma_Universal_Data => -1,
22926 Pragma_Unmodified => -1,
22927 Pragma_Unreferenced => -1,
22928 Pragma_Unreferenced_Objects => -1,
22929 Pragma_Unreserve_All_Interrupts => -1,
22930 Pragma_Unsuppress => 0,
22931 Pragma_Use_VADS_Size => -1,
22932 Pragma_Validity_Checks => -1,
22933 Pragma_Volatile => 0,
22934 Pragma_Volatile_Components => 0,
22935 Pragma_Warnings => -1,
22936 Pragma_Weak_External => -1,
22937 Pragma_Wide_Character_Encoding => 0,
22938 Unknown_Pragma => 0);
22940 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
22949 if Nkind (P) /= N_Pragma_Argument_Association then
22953 Id := Get_Pragma_Id (Parent (P));
22954 C := Sig_Flags (Id);
22966 -- For pragma Check, the first argument is not significant,
22967 -- the second and the third (if present) arguments are
22970 when Pragma_Check =>
22972 P = First (Pragma_Argument_Associations (Parent (P)));
22975 raise Program_Error;
22979 A := First (Pragma_Argument_Associations (Parent (P)));
22980 for J in 1 .. C - 1 loop
22988 return A = P; -- is this wrong way round ???
22991 end Is_Non_Significant_Pragma_Reference;
22997 function Is_Part_Of
22998 (State : Entity_Id;
22999 Ancestor : Entity_Id) return Boolean
23001 Options : constant Node_Id := Parent (State);
23007 -- A state declaration with option Part_Of appears as an extension
23008 -- aggregate with component associations.
23010 if Nkind (Options) = N_Extension_Aggregate then
23011 Option := First (Component_Associations (Options));
23012 while Present (Option) loop
23013 Name := First (Choices (Option));
23014 Value := Expression (Option);
23016 if Chars (Name) = Name_Part_Of then
23017 return Entity (Value) = Ancestor;
23027 ------------------------------
23028 -- Is_Pragma_String_Literal --
23029 ------------------------------
23031 -- This function returns true if the corresponding pragma argument is a
23032 -- static string expression. These are the only cases in which string
23033 -- literals can appear as pragma arguments. We also allow a string literal
23034 -- as the first argument to pragma Assert (although it will of course
23035 -- always generate a type error).
23037 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
23038 Pragn : constant Node_Id := Parent (Par);
23039 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
23040 Pname : constant Name_Id := Pragma_Name (Pragn);
23046 N := First (Assoc);
23053 if Pname = Name_Assert then
23056 elsif Pname = Name_Export then
23059 elsif Pname = Name_Ident then
23062 elsif Pname = Name_Import then
23065 elsif Pname = Name_Interface_Name then
23068 elsif Pname = Name_Linker_Alias then
23071 elsif Pname = Name_Linker_Section then
23074 elsif Pname = Name_Machine_Attribute then
23077 elsif Pname = Name_Source_File_Name then
23080 elsif Pname = Name_Source_Reference then
23083 elsif Pname = Name_Title then
23086 elsif Pname = Name_Subtitle then
23092 end Is_Pragma_String_Literal;
23094 ---------------------------
23095 -- Is_Private_SPARK_Mode --
23096 ---------------------------
23098 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
23101 (Nkind (N) = N_Pragma
23102 and then Pragma_Name (N) = Name_SPARK_Mode
23103 and then Is_List_Member (N));
23105 -- For pragma SPARK_Mode to be private, it has to appear in the private
23106 -- declarations of a package.
23109 Present (Parent (N))
23110 and then Nkind (Parent (N)) = N_Package_Specification
23111 and then List_Containing (N) = Private_Declarations (Parent (N));
23112 end Is_Private_SPARK_Mode;
23114 -------------------------------------
23115 -- Is_Unconstrained_Or_Tagged_Item --
23116 -------------------------------------
23118 function Is_Unconstrained_Or_Tagged_Item
23119 (Item : Entity_Id) return Boolean
23121 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
23122 -- Determine whether record type Typ has at least one unconstrained
23125 ---------------------------------
23126 -- Has_Unconstrained_Component --
23127 ---------------------------------
23129 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
23133 Comp := First_Component (Typ);
23134 while Present (Comp) loop
23135 if Is_Unconstrained_Or_Tagged_Item (Comp) then
23139 Next_Component (Comp);
23143 end Has_Unconstrained_Component;
23147 Typ : constant Entity_Id := Etype (Item);
23149 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
23152 if Is_Tagged_Type (Typ) then
23155 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
23158 elsif Is_Record_Type (Typ) then
23159 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
23162 return Has_Unconstrained_Component (Typ);
23168 end Is_Unconstrained_Or_Tagged_Item;
23170 -----------------------------
23171 -- Is_Valid_Assertion_Kind --
23172 -----------------------------
23174 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
23181 Name_Static_Predicate |
23182 Name_Dynamic_Predicate |
23187 Name_Type_Invariant |
23188 Name_uType_Invariant |
23192 Name_Assert_And_Cut |
23194 Name_Contract_Cases |
23196 Name_Initial_Condition |
23199 Name_Loop_Invariant |
23200 Name_Loop_Variant |
23201 Name_Postcondition |
23202 Name_Precondition |
23204 Name_Refined_Post |
23205 Name_Statement_Assertions => return True;
23207 when others => return False;
23209 end Is_Valid_Assertion_Kind;
23211 -----------------------------------------
23212 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
23213 -----------------------------------------
23215 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
23216 Aspects : constant List_Id := New_List;
23217 Loc : constant Source_Ptr := Sloc (Decl);
23218 Or_Decl : constant Node_Id := Original_Node (Decl);
23220 Original_Aspects : List_Id;
23221 -- To capture global references, a copy of the created aspects must be
23222 -- inserted in the original tree.
23225 Prag_Arg_Ass : Node_Id;
23226 Prag_Id : Pragma_Id;
23229 -- Check for any PPC pragmas that appear within Decl
23231 Prag := Next (Decl);
23232 while Nkind (Prag) = N_Pragma loop
23233 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
23236 when Pragma_Postcondition | Pragma_Precondition =>
23237 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
23239 -- Make an aspect from any PPC pragma
23241 Append_To (Aspects,
23242 Make_Aspect_Specification (Loc,
23244 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
23246 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
23248 -- Generate the analysis information in the pragma expression
23249 -- and then set the pragma node analyzed to avoid any further
23252 Analyze (Expression (Prag_Arg_Ass));
23253 Set_Analyzed (Prag, True);
23255 when others => null;
23261 -- Set all new aspects into the generic declaration node
23263 if Is_Non_Empty_List (Aspects) then
23265 -- Create the list of aspects to be inserted in the original tree
23267 Original_Aspects := Copy_Separate_List (Aspects);
23269 -- Check if Decl already has aspects
23271 -- Attach the new lists of aspects to both the generic copy and the
23274 if Has_Aspects (Decl) then
23275 Append_List (Aspects, Aspect_Specifications (Decl));
23276 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
23279 Set_Parent (Aspects, Decl);
23280 Set_Aspect_Specifications (Decl, Aspects);
23281 Set_Parent (Original_Aspects, Or_Decl);
23282 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
23285 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
23287 -------------------------
23288 -- Preanalyze_CTC_Args --
23289 -------------------------
23291 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
23293 -- Preanalyze the boolean expressions, we treat these as spec
23294 -- expressions (i.e. similar to a default expression).
23296 if Present (Arg_Req) then
23297 Preanalyze_Assert_Expression
23298 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
23300 -- In ASIS mode, for a pragma generated from a source aspect, also
23301 -- analyze the original aspect expression.
23303 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
23304 Preanalyze_Assert_Expression
23305 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
23309 if Present (Arg_Ens) then
23310 Preanalyze_Assert_Expression
23311 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
23313 -- In ASIS mode, for a pragma generated from a source aspect, also
23314 -- analyze the original aspect expression.
23316 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
23317 Preanalyze_Assert_Expression
23318 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
23321 end Preanalyze_CTC_Args;
23323 --------------------------------------
23324 -- Process_Compilation_Unit_Pragmas --
23325 --------------------------------------
23327 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
23329 -- A special check for pragma Suppress_All, a very strange DEC pragma,
23330 -- strange because it comes at the end of the unit. Rational has the
23331 -- same name for a pragma, but treats it as a program unit pragma, In
23332 -- GNAT we just decide to allow it anywhere at all. If it appeared then
23333 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
23334 -- node, and we insert a pragma Suppress (All_Checks) at the start of
23335 -- the context clause to ensure the correct processing.
23337 if Has_Pragma_Suppress_All (N) then
23338 Prepend_To (Context_Items (N),
23339 Make_Pragma (Sloc (N),
23340 Chars => Name_Suppress,
23341 Pragma_Argument_Associations => New_List (
23342 Make_Pragma_Argument_Association (Sloc (N),
23343 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
23346 -- Nothing else to do at the current time!
23348 end Process_Compilation_Unit_Pragmas;
23350 ------------------------------------
23351 -- Record_Possible_Body_Reference --
23352 ------------------------------------
23354 procedure Record_Possible_Body_Reference
23356 Item_Id : Entity_Id)
23360 and then Ekind (Item_Id) = E_Abstract_State
23362 if not Has_Body_References (Item_Id) then
23363 Set_Has_Body_References (Item_Id, True);
23364 Set_Body_References (Item_Id, New_Elmt_List);
23367 Append_Elmt (Item, Body_References (Item_Id));
23369 end Record_Possible_Body_Reference;
23371 ------------------------------
23372 -- Relocate_Pragmas_To_Body --
23373 ------------------------------
23375 procedure Relocate_Pragmas_To_Body
23376 (Subp_Body : Node_Id;
23377 Target_Body : Node_Id := Empty)
23379 procedure Relocate_Pragma (Prag : Node_Id);
23380 -- Remove a single pragma from its current list and add it to the
23381 -- declarations of the proper body (either Subp_Body or Target_Body).
23383 ---------------------
23384 -- Relocate_Pragma --
23385 ---------------------
23387 procedure Relocate_Pragma (Prag : Node_Id) is
23392 -- When subprogram stubs or expression functions are involves, the
23393 -- destination declaration list belongs to the proper body.
23395 if Present (Target_Body) then
23396 Target := Target_Body;
23398 Target := Subp_Body;
23401 Decls := Declarations (Target);
23405 Set_Declarations (Target, Decls);
23408 -- Unhook the pragma from its current list
23411 Prepend (Prag, Decls);
23412 end Relocate_Pragma;
23416 Body_Id : constant Entity_Id :=
23417 Defining_Unit_Name (Specification (Subp_Body));
23418 Next_Stmt : Node_Id;
23421 -- Start of processing for Relocate_Pragmas_To_Body
23424 -- Do not process a body that comes from a separate unit as no construct
23425 -- can possibly follow it.
23427 if not Is_List_Member (Subp_Body) then
23430 -- Do not relocate pragmas that follow a stub if the stub does not have
23433 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
23434 and then No (Target_Body)
23438 -- Do not process internally generated routine _Postconditions
23440 elsif Ekind (Body_Id) = E_Procedure
23441 and then Chars (Body_Id) = Name_uPostconditions
23446 -- Look at what is following the body. We are interested in certain kind
23447 -- of pragmas (either from source or byproducts of expansion) that can
23448 -- apply to a body [stub].
23450 Stmt := Next (Subp_Body);
23451 while Present (Stmt) loop
23453 -- Preserve the following statement for iteration purposes due to a
23454 -- possible relocation of a pragma.
23456 Next_Stmt := Next (Stmt);
23458 -- Move a candidate pragma following the body to the declarations of
23461 if Nkind (Stmt) = N_Pragma
23462 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
23464 Relocate_Pragma (Stmt);
23466 -- Skip internally generated code
23468 elsif not Comes_From_Source (Stmt) then
23471 -- No candidate pragmas are available for relocation
23479 end Relocate_Pragmas_To_Body;
23481 ----------------------------
23482 -- Rewrite_Assertion_Kind --
23483 ----------------------------
23485 procedure Rewrite_Assertion_Kind (N : Node_Id) is
23489 if Nkind (N) = N_Attribute_Reference
23490 and then Attribute_Name (N) = Name_Class
23491 and then Nkind (Prefix (N)) = N_Identifier
23493 case Chars (Prefix (N)) is
23498 when Name_Type_Invariant =>
23499 Nam := Name_uType_Invariant;
23500 when Name_Invariant =>
23501 Nam := Name_uInvariant;
23506 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
23508 end Rewrite_Assertion_Kind;
23519 --------------------------------
23520 -- Set_Encoded_Interface_Name --
23521 --------------------------------
23523 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
23524 Str : constant String_Id := Strval (S);
23525 Len : constant Int := String_Length (Str);
23530 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
23533 -- Stores encoded value of character code CC. The encoding we use an
23534 -- underscore followed by four lower case hex digits.
23540 procedure Encode is
23542 Store_String_Char (Get_Char_Code ('_'));
23544 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
23546 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
23548 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
23550 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
23553 -- Start of processing for Set_Encoded_Interface_Name
23556 -- If first character is asterisk, this is a link name, and we leave it
23557 -- completely unmodified. We also ignore null strings (the latter case
23558 -- happens only in error cases) and no encoding should occur for Java or
23559 -- AAMP interface names.
23562 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
23563 or else VM_Target /= No_VM
23564 or else AAMP_On_Target
23566 Set_Interface_Name (E, S);
23571 CC := Get_String_Char (Str, J);
23573 exit when not In_Character_Range (CC);
23575 C := Get_Character (CC);
23577 exit when C /= '_' and then C /= '$'
23578 and then C not in '0' .. '9'
23579 and then C not in 'a' .. 'z'
23580 and then C not in 'A' .. 'Z';
23583 Set_Interface_Name (E, S);
23591 -- Here we need to encode. The encoding we use as follows:
23592 -- three underscores + four hex digits (lower case)
23596 for J in 1 .. String_Length (Str) loop
23597 CC := Get_String_Char (Str, J);
23599 if not In_Character_Range (CC) then
23602 C := Get_Character (CC);
23604 if C = '_' or else C = '$'
23605 or else C in '0' .. '9'
23606 or else C in 'a' .. 'z'
23607 or else C in 'A' .. 'Z'
23609 Store_String_Char (CC);
23616 Set_Interface_Name (E,
23617 Make_String_Literal (Sloc (S),
23618 Strval => End_String));
23620 end Set_Encoded_Interface_Name;
23622 -------------------
23623 -- Set_Unit_Name --
23624 -------------------
23626 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
23631 if Nkind (N) = N_Identifier
23632 and then Nkind (With_Item) = N_Identifier
23634 Set_Entity (N, Entity (With_Item));
23636 elsif Nkind (N) = N_Selected_Component then
23637 Change_Selected_Component_To_Expanded_Name (N);
23638 Set_Entity (N, Entity (With_Item));
23639 Set_Entity (Selector_Name (N), Entity (N));
23641 Pref := Prefix (N);
23642 Scop := Scope (Entity (N));
23643 while Nkind (Pref) = N_Selected_Component loop
23644 Change_Selected_Component_To_Expanded_Name (Pref);
23645 Set_Entity (Selector_Name (Pref), Scop);
23646 Set_Entity (Pref, Scop);
23647 Pref := Prefix (Pref);
23648 Scop := Scope (Scop);
23651 Set_Entity (Pref, Scop);