1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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;
50 with Output; use Output;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch12; use Sem_Ch12;
61 with Sem_Ch13; use Sem_Ch13;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Dist; use Sem_Dist;
64 with Sem_Elim; use Sem_Elim;
65 with Sem_Eval; use Sem_Eval;
66 with Sem_Intr; use Sem_Intr;
67 with Sem_Mech; use Sem_Mech;
68 with Sem_Res; use Sem_Res;
69 with Sem_Type; use Sem_Type;
70 with Sem_Util; use Sem_Util;
71 with Sem_VFpt; use Sem_VFpt;
72 with Sem_Warn; use Sem_Warn;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.CN; use Sinfo.CN;
76 with Sinput; use Sinput;
77 with Stringt; use Stringt;
78 with Stylesw; use Stylesw;
80 with Targparm; use Targparm;
81 with Tbuild; use Tbuild;
83 with Uintp; use Uintp;
84 with Uname; use Uname;
85 with Urealp; use Urealp;
86 with Validsw; use Validsw;
87 with Warnsw; use Warnsw;
89 package body Sem_Prag is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all upper case letters for OpenVMS versions of GNAT, and to all
129 -- lower case letters for all other versions
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
170 -- Subsidiary routine to the analysis of pragmas Depends, Global and
171 -- Refined_State. Append an entity to a list. If the list is empty, create
174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
183 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
184 -- whether a particular item appears in a mixed list of nodes and entities.
185 -- It is assumed that all nodes in the list have entities.
187 function Check_Kind (Nam : Name_Id) return Name_Id;
188 -- This function is used in connection with pragmas Assert, Check,
189 -- and assertion aspects and pragmas, to determine if Check pragmas
190 -- (or corresponding assertion aspects or pragmas) are currently active
191 -- as determined by the presence of -gnata on the command line (which
192 -- sets the default), and the appearance of pragmas Check_Policy and
193 -- Assertion_Policy as configuration pragmas either in a configuration
194 -- pragma file, or at the start of the current unit, or locally given
195 -- Check_Policy and Assertion_Policy pragmas that are currently active.
197 -- The value returned is one of the names Check, Ignore, Disable (On
198 -- returns Check, and Off returns Ignore).
200 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
201 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
202 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
203 -- _Post, _Invariant, or _Type_Invariant, which are special names used
204 -- in identifiers to represent these attribute references.
206 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id);
207 -- In ASIS mode we need to analyze the original expression in the aspect
208 -- specification. For Initializes, Global, and related SPARK aspects, the
209 -- expression has a sui-generis syntax which may be a list, an expression,
212 procedure Check_State_And_Constituent_Use
216 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
217 -- Global and Initializes. Determine whether a state from list States and a
218 -- corresponding constituent from list Constits (if any) appear in the same
219 -- context denoted by Context. If this is the case, emit an error.
221 procedure Collect_Global_Items
223 In_Items : in out Elist_Id;
224 In_Out_Items : in out Elist_Id;
225 Out_Items : in out Elist_Id;
226 Proof_In_Items : in out Elist_Id;
227 Has_In_State : out Boolean;
228 Has_In_Out_State : out Boolean;
229 Has_Out_State : out Boolean;
230 Has_Proof_In_State : out Boolean;
231 Has_Null_State : out Boolean);
232 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
233 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output
234 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items
235 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
236 -- and Has_Proof_In_State are set when there is at least one abstract state
237 -- with visible refinement available in the corresponding mode. Flag
238 -- Has_Null_State is set when at least state has a null refinement.
240 function Find_Related_Subprogram_Or_Body
242 Do_Checks : Boolean := False) return Node_Id;
243 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global,
244 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration
245 -- of the related subprogram [body or stub] subject to pragma Prag. If flag
246 -- Do_Checks is set, the routine reports duplicate pragmas and detects
247 -- improper use of refinement pragmas in stand alone expression functions.
248 -- The returned value depends on the related pragma as follows:
249 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding
250 -- N_Subprogram_Declaration node or if the pragma applies to a stand
251 -- alone body, the N_Subprogram_Body node or Empty if illegal.
252 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield
253 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if
256 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
257 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
258 -- original one, following the renaming chain) is returned. Otherwise the
259 -- entity is returned unchanged. Should be in Einfo???
261 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
262 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
263 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
266 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
267 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
268 -- Determine whether dependency clause Clause is surrounded by extra
269 -- parentheses. If this is the case, issue an error message.
271 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
272 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
273 -- pragma Depends. Determine whether the type of dependency item Item is
274 -- tagged, unconstrained array, unconstrained record or a record with at
275 -- least one unconstrained component.
277 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id);
278 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
279 -- of a Test_Case pragma if present (possibly Empty). We treat these as
280 -- spec expressions (i.e. similar to a default expression).
282 procedure Record_Possible_Body_Reference
283 (State_Id : Entity_Id;
285 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
286 -- Global. Given an abstract state denoted by State_Id and a reference Ref
287 -- to it, determine whether the reference appears in a package body that
288 -- will eventually refine the state. If this is the case, record the
289 -- reference for future checks (see Analyze_Refined_State_In_Decls).
291 procedure Resolve_State (N : Node_Id);
292 -- Handle the overloading of state names by functions. When N denotes a
293 -- function, this routine finds the corresponding state and sets the entity
294 -- of N to that of the state.
296 procedure Rewrite_Assertion_Kind (N : Node_Id);
297 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
298 -- then it is rewritten as an identifier with the corresponding special
299 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
300 -- Check, Check_Policy.
302 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
303 -- Place semantic information on the argument of an Elaborate/Elaborate_All
304 -- pragma. Entity name for unit and its parents is taken from item in
305 -- previous with_clause that mentions the unit.
307 Dummy : Integer := 0;
308 pragma Volatile (Dummy);
309 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
312 pragma No_Inline (ip);
313 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
314 -- is just to help debugging the front end. If a pragma Inspection_Point
315 -- is added to a source program, then breaking on ip will get you to that
316 -- point in the program.
319 pragma No_Inline (rv);
320 -- This is a dummy function called by the processing for pragma Reviewable.
321 -- It is there for assisting front end debugging. By placing a Reviewable
322 -- pragma in the source program, a breakpoint on rv catches this place in
323 -- the source, allowing convenient stepping to the point of interest.
329 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
332 To_List := New_Elmt_List;
335 Append_Elmt (Item, To_List);
338 -------------------------------
339 -- Adjust_External_Name_Case --
340 -------------------------------
342 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
346 -- Adjust case of literal if required
348 if Opt.External_Name_Exp_Casing = As_Is then
352 -- Copy existing string
358 for J in 1 .. String_Length (Strval (N)) loop
359 CC := Get_String_Char (Strval (N), J);
361 if Opt.External_Name_Exp_Casing = Uppercase
362 and then CC >= Get_Char_Code ('a')
363 and then CC <= Get_Char_Code ('z')
365 Store_String_Char (CC - 32);
367 elsif Opt.External_Name_Exp_Casing = Lowercase
368 and then CC >= Get_Char_Code ('A')
369 and then CC <= Get_Char_Code ('Z')
371 Store_String_Char (CC + 32);
374 Store_String_Char (CC);
379 Make_String_Literal (Sloc (N),
380 Strval => End_String);
382 end Adjust_External_Name_Case;
384 -----------------------------------------
385 -- Analyze_Contract_Cases_In_Decl_Part --
386 -----------------------------------------
388 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is
389 Others_Seen : Boolean := False;
391 procedure Analyze_Contract_Case (CCase : Node_Id);
392 -- Verify the legality of a single contract case
394 ---------------------------
395 -- Analyze_Contract_Case --
396 ---------------------------
398 procedure Analyze_Contract_Case (CCase : Node_Id) is
399 Case_Guard : Node_Id;
401 Extra_Guard : Node_Id;
404 if Nkind (CCase) = N_Component_Association then
405 Case_Guard := First (Choices (CCase));
406 Conseq := Expression (CCase);
408 -- Each contract case must have exactly one case guard
410 Extra_Guard := Next (Case_Guard);
412 if Present (Extra_Guard) then
414 ("contract case must have exactly one case guard",
418 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
420 if Nkind (Case_Guard) = N_Others_Choice then
423 ("only one others choice allowed in contract cases",
429 elsif Others_Seen then
431 ("others must be the last choice in contract cases", N);
434 -- Preanalyze the case guard and consequence
436 if Nkind (Case_Guard) /= N_Others_Choice then
437 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
440 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
442 -- The contract case is malformed
445 Error_Msg_N ("wrong syntax in contract case", CCase);
447 end Analyze_Contract_Case;
456 Restore_Scope : Boolean := False;
457 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
459 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
464 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
465 Subp_Id := Defining_Entity (Subp_Decl);
466 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
468 -- Single and multiple contract cases must appear in aggregate form. If
469 -- this is not the case, then either the parser of the analysis of the
470 -- pragma failed to produce an aggregate.
472 pragma Assert (Nkind (All_Cases) = N_Aggregate);
474 if No (Component_Associations (All_Cases)) then
475 Error_Msg_N ("wrong syntax for constract cases", N);
477 -- Individual contract cases appear as component associations
480 -- Ensure that the formal parameters are visible when analyzing all
481 -- clauses. This falls out of the general rule of aspects pertaining
482 -- to subprogram declarations. Skip the installation for subprogram
483 -- bodies because the formals are already visible.
485 if not In_Open_Scopes (Subp_Id) then
486 Restore_Scope := True;
487 Push_Scope (Subp_Id);
488 Install_Formals (Subp_Id);
491 CCase := First (Component_Associations (All_Cases));
492 while Present (CCase) loop
493 Analyze_Contract_Case (CCase);
497 if Restore_Scope then
501 end Analyze_Contract_Cases_In_Decl_Part;
503 ----------------------------------
504 -- Analyze_Depends_In_Decl_Part --
505 ----------------------------------
507 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
508 Loc : constant Source_Ptr := Sloc (N);
510 All_Inputs_Seen : Elist_Id := No_Elist;
511 -- A list containing the entities of all the inputs processed so far.
512 -- The list is populated with unique entities because the same input
513 -- may appear in multiple input lists.
515 All_Outputs_Seen : Elist_Id := No_Elist;
516 -- A list containing the entities of all the outputs processed so far.
517 -- The list is populated with unique entities because output items are
518 -- unique in a dependence relation.
520 Constits_Seen : Elist_Id := No_Elist;
521 -- A list containing the entities of all constituents processed so far.
522 -- It aids in detecting illegal usage of a state and a corresponding
523 -- constituent in pragma [Refinde_]Depends.
525 Global_Seen : Boolean := False;
526 -- A flag set when pragma Global has been processed
528 Null_Output_Seen : Boolean := False;
529 -- A flag used to track the legality of a null output
531 Result_Seen : Boolean := False;
532 -- A flag set when Subp_Id'Result is processed
535 -- The entity of the subprogram subject to pragma [Refined_]Depends
537 States_Seen : Elist_Id := No_Elist;
538 -- A list containing the entities of all states processed so far. It
539 -- helps in detecting illegal usage of a state and a corresponding
540 -- constituent in pragma [Refined_]Depends.
543 -- The entity of the subprogram [body or stub] subject to pragma
544 -- [Refined_]Depends.
546 Subp_Inputs : Elist_Id := No_Elist;
547 Subp_Outputs : Elist_Id := No_Elist;
548 -- Two lists containing the full set of inputs and output of the related
549 -- subprograms. Note that these lists contain both nodes and entities.
551 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
552 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
553 -- to the name buffer. The individual kinds are as follows:
554 -- E_Abstract_State - "state"
555 -- E_In_Parameter - "parameter"
556 -- E_In_Out_Parameter - "parameter"
557 -- E_Out_Parameter - "parameter"
558 -- E_Variable - "global"
560 procedure Analyze_Dependency_Clause
563 -- Verify the legality of a single dependency clause. Flag Is_Last
564 -- denotes whether Clause is the last clause in the relation.
566 procedure Check_Function_Return;
567 -- Verify that Funtion'Result appears as one of the outputs
568 -- (SPARK RM 6.1.5(10)).
575 -- Ensure that an item fulfils its designated input and/or output role
576 -- as specified by pragma Global (if any) or the enclosing context. If
577 -- this is not the case, emit an error. Item and Item_Id denote the
578 -- attributes of an item. Flag Is_Input should be set when item comes
579 -- from an input list. Flag Self_Ref should be set when the item is an
580 -- output and the dependency clause has operator "+".
582 procedure Check_Usage
583 (Subp_Items : Elist_Id;
584 Used_Items : Elist_Id;
586 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
587 -- error if this is not the case.
589 procedure Normalize_Clause (Clause : Node_Id);
590 -- Remove a self-dependency "+" from the input list of a clause. Split
591 -- a clause with multiple outputs into multiple clauses with a single
594 -----------------------------
595 -- Add_Item_To_Name_Buffer --
596 -----------------------------
598 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
600 if Ekind (Item_Id) = E_Abstract_State then
601 Add_Str_To_Name_Buffer ("state");
603 elsif Is_Formal (Item_Id) then
604 Add_Str_To_Name_Buffer ("parameter");
606 elsif Ekind (Item_Id) = E_Variable then
607 Add_Str_To_Name_Buffer ("global");
609 -- The routine should not be called with non-SPARK items
614 end Add_Item_To_Name_Buffer;
616 -------------------------------
617 -- Analyze_Dependency_Clause --
618 -------------------------------
620 procedure Analyze_Dependency_Clause
624 procedure Analyze_Input_List (Inputs : Node_Id);
625 -- Verify the legality of a single input list
627 procedure Analyze_Input_Output
632 Seen : in out Elist_Id;
633 Null_Seen : in out Boolean;
634 Non_Null_Seen : in out Boolean);
635 -- Verify the legality of a single input or output item. Flag
636 -- Is_Input should be set whenever Item is an input, False when it
637 -- denotes an output. Flag Self_Ref should be set when the item is an
638 -- output and the dependency clause has a "+". Flag Top_Level should
639 -- be set whenever Item appears immediately within an input or output
640 -- list. Seen is a collection of all abstract states, variables and
641 -- formals processed so far. Flag Null_Seen denotes whether a null
642 -- input or output has been encountered. Flag Non_Null_Seen denotes
643 -- whether a non-null input or output has been encountered.
645 ------------------------
646 -- Analyze_Input_List --
647 ------------------------
649 procedure Analyze_Input_List (Inputs : Node_Id) is
650 Inputs_Seen : Elist_Id := No_Elist;
651 -- A list containing the entities of all inputs that appear in the
652 -- current input list.
654 Non_Null_Input_Seen : Boolean := False;
655 Null_Input_Seen : Boolean := False;
656 -- Flags used to check the legality of an input list
661 -- Multiple inputs appear as an aggregate
663 if Nkind (Inputs) = N_Aggregate then
664 if Present (Component_Associations (Inputs)) then
666 ("nested dependency relations not allowed", Inputs);
668 elsif Present (Expressions (Inputs)) then
669 Input := First (Expressions (Inputs));
670 while Present (Input) loop
677 Null_Seen => Null_Input_Seen,
678 Non_Null_Seen => Non_Null_Input_Seen);
683 -- Syntax error, always report
686 Error_Msg_N ("malformed input dependency list", Inputs);
689 -- Process a solitary input
698 Null_Seen => Null_Input_Seen,
699 Non_Null_Seen => Non_Null_Input_Seen);
702 -- Detect an illegal dependency clause of the form
706 if Null_Output_Seen and then Null_Input_Seen then
708 ("null dependency clause cannot have a null input list",
711 end Analyze_Input_List;
713 --------------------------
714 -- Analyze_Input_Output --
715 --------------------------
717 procedure Analyze_Input_Output
722 Seen : in out Elist_Id;
723 Null_Seen : in out Boolean;
724 Non_Null_Seen : in out Boolean)
726 Is_Output : constant Boolean := not Is_Input;
731 -- Multiple input or output items appear as an aggregate
733 if Nkind (Item) = N_Aggregate then
734 if not Top_Level then
735 SPARK_Msg_N ("nested grouping of items not allowed", Item);
737 elsif Present (Component_Associations (Item)) then
739 ("nested dependency relations not allowed", Item);
741 -- Recursively analyze the grouped items
743 elsif Present (Expressions (Item)) then
744 Grouped := First (Expressions (Item));
745 while Present (Grouped) loop
748 Is_Input => Is_Input,
749 Self_Ref => Self_Ref,
752 Null_Seen => Null_Seen,
753 Non_Null_Seen => Non_Null_Seen);
758 -- Syntax error, always report
761 Error_Msg_N ("malformed dependency list", Item);
764 -- Process Function'Result in the context of a dependency clause
766 elsif Is_Attribute_Result (Item) then
767 Non_Null_Seen := True;
769 -- It is sufficent to analyze the prefix of 'Result in order to
770 -- establish legality of the attribute.
772 Analyze (Prefix (Item));
774 -- The prefix of 'Result must denote the function for which
775 -- pragma Depends applies (SPARK RM 6.1.5(11)).
777 if not Is_Entity_Name (Prefix (Item))
778 or else Ekind (Spec_Id) /= E_Function
779 or else Entity (Prefix (Item)) /= Spec_Id
781 Error_Msg_Name_1 := Name_Result;
783 ("prefix of attribute % must denote the enclosing "
786 -- Function'Result is allowed to appear on the output side of a
787 -- dependency clause (SPARK RM 6.1.5(6)).
790 SPARK_Msg_N ("function result cannot act as input", Item);
794 ("cannot mix null and non-null dependency items", Item);
800 -- Detect multiple uses of null in a single dependency list or
801 -- throughout the whole relation. Verify the placement of a null
802 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
804 elsif Nkind (Item) = N_Null then
807 ("multiple null dependency relations not allowed", Item);
809 elsif Non_Null_Seen then
811 ("cannot mix null and non-null dependency items", Item);
819 ("null output list must be the last clause in a "
820 & "dependency relation", Item);
822 -- Catch a useless dependence of the form:
827 ("useless dependence, null depends on itself", Item);
835 Non_Null_Seen := True;
838 SPARK_Msg_N ("cannot mix null and non-null items", Item);
842 Resolve_State (Item);
844 -- Find the entity of the item. If this is a renaming, climb
845 -- the renaming chain to reach the root object. Renamings of
846 -- non-entire objects do not yield an entity (Empty).
848 Item_Id := Entity_Of (Item);
850 if Present (Item_Id) then
851 if Ekind_In (Item_Id, E_Abstract_State,
857 -- Ensure that the item fulfils its role as input and/or
858 -- output as specified by pragma Global or the enclosing
861 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
863 -- Detect multiple uses of the same state, variable or
864 -- formal parameter. If this is not the case, add the
865 -- item to the list of processed relations.
867 if Contains (Seen, Item_Id) then
869 ("duplicate use of item &", Item, Item_Id);
871 Add_Item (Item_Id, Seen);
874 -- Detect illegal use of an input related to a null
875 -- output. Such input items cannot appear in other
876 -- input lists (SPARK RM 6.1.5(13)).
879 and then Null_Output_Seen
880 and then Contains (All_Inputs_Seen, Item_Id)
883 ("input of a null output list cannot appear in "
884 & "multiple input lists", Item);
887 -- Add an input or a self-referential output to the list
888 -- of all processed inputs.
890 if Is_Input or else Self_Ref then
891 Add_Item (Item_Id, All_Inputs_Seen);
894 -- State related checks (SPARK RM 6.1.5(3))
896 if Ekind (Item_Id) = E_Abstract_State then
897 if Has_Visible_Refinement (Item_Id) then
899 ("cannot mention state & in global refinement",
902 ("\use its constituents instead", Item);
905 -- If the reference to the abstract state appears in
906 -- an enclosing package body that will eventually
907 -- refine the state, record the reference for future
911 Record_Possible_Body_Reference
912 (State_Id => Item_Id,
917 -- When the item renames an entire object, replace the
918 -- item with a reference to the object.
920 if Present (Renamed_Object (Entity (Item))) then
922 New_Occurrence_Of (Item_Id, Sloc (Item)));
926 -- Add the entity of the current item to the list of
929 if Ekind (Item_Id) = E_Abstract_State then
930 Add_Item (Item_Id, States_Seen);
933 if Ekind_In (Item_Id, E_Abstract_State, E_Variable)
934 and then Present (Encapsulating_State (Item_Id))
936 Add_Item (Item_Id, Constits_Seen);
939 -- All other input/output items are illegal
940 -- (SPARK RM 6.1.5(1)).
944 ("item must denote parameter, variable, or state",
948 -- All other input/output items are illegal
949 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
953 ("item must denote parameter, variable, or state", Item);
956 end Analyze_Input_Output;
964 Non_Null_Output_Seen : Boolean := False;
965 -- Flag used to check the legality of an output list
967 -- Start of processing for Analyze_Dependency_Clause
970 Inputs := Expression (Clause);
973 -- An input list with a self-dependency appears as operator "+" where
974 -- the actuals inputs are the right operand.
976 if Nkind (Inputs) = N_Op_Plus then
977 Inputs := Right_Opnd (Inputs);
981 -- Process the output_list of a dependency_clause
983 Output := First (Choices (Clause));
984 while Present (Output) loop
988 Self_Ref => Self_Ref,
990 Seen => All_Outputs_Seen,
991 Null_Seen => Null_Output_Seen,
992 Non_Null_Seen => Non_Null_Output_Seen);
997 -- Process the input_list of a dependency_clause
999 Analyze_Input_List (Inputs);
1000 end Analyze_Dependency_Clause;
1002 ---------------------------
1003 -- Check_Function_Return --
1004 ---------------------------
1006 procedure Check_Function_Return is
1008 if Ekind (Spec_Id) = E_Function and then not Result_Seen then
1010 ("result of & must appear in exactly one output list",
1013 end Check_Function_Return;
1019 procedure Check_Role
1021 Item_Id : Entity_Id;
1026 (Item_Is_Input : out Boolean;
1027 Item_Is_Output : out Boolean);
1028 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1029 -- Item_Is_Output are set depending on the role.
1031 procedure Role_Error
1032 (Item_Is_Input : Boolean;
1033 Item_Is_Output : Boolean);
1034 -- Emit an error message concerning the incorrect use of Item in
1035 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1036 -- denote whether the item is an input and/or an output.
1043 (Item_Is_Input : out Boolean;
1044 Item_Is_Output : out Boolean)
1047 Item_Is_Input := False;
1048 Item_Is_Output := False;
1050 -- Abstract state cases
1052 if Ekind (Item_Id) = E_Abstract_State then
1054 -- When pragma Global is present, the mode of the state may be
1055 -- further constrained by setting a more restrictive mode.
1058 if Appears_In (Subp_Inputs, Item_Id) then
1059 Item_Is_Input := True;
1062 if Appears_In (Subp_Outputs, Item_Id) then
1063 Item_Is_Output := True;
1066 -- Otherwise the state has a default IN OUT mode
1069 Item_Is_Input := True;
1070 Item_Is_Output := True;
1075 elsif Ekind (Item_Id) = E_In_Parameter then
1076 Item_Is_Input := True;
1078 elsif Ekind (Item_Id) = E_In_Out_Parameter then
1079 Item_Is_Input := True;
1080 Item_Is_Output := True;
1082 elsif Ekind (Item_Id) = E_Out_Parameter then
1083 if Scope (Item_Id) = Spec_Id then
1085 -- An OUT parameter of the related subprogram has mode IN
1086 -- if its type is unconstrained or tagged because array
1087 -- bounds, discriminants or tags can be read.
1089 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1090 Item_Is_Input := True;
1093 Item_Is_Output := True;
1095 -- An OUT parameter of an enclosing subprogram behaves as a
1096 -- read-write variable in which case the mode is IN OUT.
1099 Item_Is_Input := True;
1100 Item_Is_Output := True;
1105 else pragma Assert (Ekind (Item_Id) = E_Variable);
1107 -- When pragma Global is present, the mode of the variable may
1108 -- be further constrained by setting a more restrictive mode.
1112 -- A variable has mode IN when its type is unconstrained or
1113 -- tagged because array bounds, discriminants or tags can be
1116 if Appears_In (Subp_Inputs, Item_Id)
1117 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1119 Item_Is_Input := True;
1122 if Appears_In (Subp_Outputs, Item_Id) then
1123 Item_Is_Output := True;
1126 -- Otherwise the variable has a default IN OUT mode
1129 Item_Is_Input := True;
1130 Item_Is_Output := True;
1139 procedure Role_Error
1140 (Item_Is_Input : Boolean;
1141 Item_Is_Output : Boolean)
1143 Error_Msg : Name_Id;
1148 -- When the item is not part of the input and the output set of
1149 -- the related subprogram, then it appears as extra in pragma
1150 -- [Refined_]Depends.
1152 if not Item_Is_Input and then not Item_Is_Output then
1153 Add_Item_To_Name_Buffer (Item_Id);
1154 Add_Str_To_Name_Buffer
1155 (" & cannot appear in dependence relation");
1157 Error_Msg := Name_Find;
1158 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1160 Error_Msg_Name_1 := Chars (Subp_Id);
1162 ("\& is not part of the input or output set of subprogram %",
1165 -- The mode of the item and its role in pragma [Refined_]Depends
1166 -- are in conflict. Construct a detailed message explaining the
1167 -- illegality (SPARK RM 6.1.5(5-6)).
1170 if Item_Is_Input then
1171 Add_Str_To_Name_Buffer ("read-only");
1173 Add_Str_To_Name_Buffer ("write-only");
1176 Add_Char_To_Name_Buffer (' ');
1177 Add_Item_To_Name_Buffer (Item_Id);
1178 Add_Str_To_Name_Buffer (" & cannot appear as ");
1180 if Item_Is_Input then
1181 Add_Str_To_Name_Buffer ("output");
1183 Add_Str_To_Name_Buffer ("input");
1186 Add_Str_To_Name_Buffer (" in dependence relation");
1187 Error_Msg := Name_Find;
1188 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1194 Item_Is_Input : Boolean;
1195 Item_Is_Output : Boolean;
1197 -- Start of processing for Check_Role
1200 Find_Role (Item_Is_Input, Item_Is_Output);
1205 if not Item_Is_Input then
1206 Role_Error (Item_Is_Input, Item_Is_Output);
1209 -- Self-referential item
1212 if not Item_Is_Input or else not Item_Is_Output then
1213 Role_Error (Item_Is_Input, Item_Is_Output);
1218 elsif not Item_Is_Output then
1219 Role_Error (Item_Is_Input, Item_Is_Output);
1227 procedure Check_Usage
1228 (Subp_Items : Elist_Id;
1229 Used_Items : Elist_Id;
1232 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
1233 -- Emit an error concerning the illegal usage of an item
1239 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
1240 Error_Msg : Name_Id;
1247 -- Unconstrained and tagged items are not part of the explicit
1248 -- input set of the related subprogram, they do not have to be
1249 -- present in a dependence relation and should not be flagged
1250 -- (SPARK RM 6.1.5(8)).
1252 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1255 Add_Item_To_Name_Buffer (Item_Id);
1256 Add_Str_To_Name_Buffer
1257 (" & must appear in at least one input dependence list");
1259 Error_Msg := Name_Find;
1260 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1263 -- Output case (SPARK RM 6.1.5(10))
1268 Add_Item_To_Name_Buffer (Item_Id);
1269 Add_Str_To_Name_Buffer
1270 (" & must appear in exactly one output dependence list");
1272 Error_Msg := Name_Find;
1273 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1281 Item_Id : Entity_Id;
1283 -- Start of processing for Check_Usage
1286 if No (Subp_Items) then
1290 -- Each input or output of the subprogram must appear in a dependency
1293 Elmt := First_Elmt (Subp_Items);
1294 while Present (Elmt) loop
1295 Item := Node (Elmt);
1297 if Nkind (Item) = N_Defining_Identifier then
1300 Item_Id := Entity_Of (Item);
1303 -- The item does not appear in a dependency
1305 if Present (Item_Id)
1306 and then not Contains (Used_Items, Item_Id)
1308 if Is_Formal (Item_Id) then
1309 Usage_Error (Item, Item_Id);
1311 -- States and global variables are not used properly only when
1312 -- the subprogram is subject to pragma Global.
1314 elsif Global_Seen then
1315 Usage_Error (Item, Item_Id);
1323 ----------------------
1324 -- Normalize_Clause --
1325 ----------------------
1327 procedure Normalize_Clause (Clause : Node_Id) is
1328 procedure Create_Or_Modify_Clause
1334 Multiple : Boolean);
1335 -- Create a brand new clause to represent the self-reference or
1336 -- modify the input and/or output lists of an existing clause. Output
1337 -- denotes a self-referencial output. Outputs is the output list of a
1338 -- clause. Inputs is the input list of a clause. After denotes the
1339 -- clause after which the new clause is to be inserted. Flag In_Place
1340 -- should be set when normalizing the last output of an output list.
1341 -- Flag Multiple should be set when Output comes from a list with
1344 procedure Normalize_Outputs;
1345 -- If Clause contains more than one output, split the clause into
1346 -- multiple clauses with a single output. All new clauses are added
1349 -----------------------------
1350 -- Create_Or_Modify_Clause --
1351 -----------------------------
1353 procedure Create_Or_Modify_Clause
1361 procedure Propagate_Output
1364 -- Handle the various cases of output propagation to the input
1365 -- list. Output denotes a self-referencial output item. Inputs is
1366 -- the input list of a clause.
1368 ----------------------
1369 -- Propagate_Output --
1370 ----------------------
1372 procedure Propagate_Output
1376 function In_Input_List
1378 Inputs : List_Id) return Boolean;
1379 -- Determine whether a particulat item appears in the input
1380 -- list of a clause.
1386 function In_Input_List
1388 Inputs : List_Id) return Boolean
1393 Elmt := First (Inputs);
1394 while Present (Elmt) loop
1395 if Entity_Of (Elmt) = Item then
1407 Output_Id : constant Entity_Id := Entity_Of (Output);
1410 -- Start of processing for Propagate_Output
1413 -- The clause is of the form:
1415 -- (Output =>+ null)
1417 -- Remove the null input and replace it with a copy of the
1420 -- (Output => Output)
1422 if Nkind (Inputs) = N_Null then
1423 Rewrite (Inputs, New_Copy_Tree (Output));
1425 -- The clause is of the form:
1427 -- (Output =>+ (Input1, ..., InputN))
1429 -- Determine whether the output is not already mentioned in the
1430 -- input list and if not, add it to the list of inputs:
1432 -- (Output => (Output, Input1, ..., InputN))
1434 elsif Nkind (Inputs) = N_Aggregate then
1435 Grouped := Expressions (Inputs);
1437 if not In_Input_List
1441 Prepend_To (Grouped, New_Copy_Tree (Output));
1444 -- The clause is of the form:
1446 -- (Output =>+ Input)
1448 -- If the input does not mention the output, group the two
1451 -- (Output => (Output, Input))
1453 elsif Entity_Of (Inputs) /= Output_Id then
1455 Make_Aggregate (Loc,
1456 Expressions => New_List (
1457 New_Copy_Tree (Output),
1458 New_Copy_Tree (Inputs))));
1460 end Propagate_Output;
1464 Loc : constant Source_Ptr := Sloc (Clause);
1465 New_Clause : Node_Id;
1467 -- Start of processing for Create_Or_Modify_Clause
1470 -- A null output depending on itself does not require any
1473 if Nkind (Output) = N_Null then
1476 -- A function result cannot depend on itself because it cannot
1477 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1479 elsif Is_Attribute_Result (Output) then
1480 SPARK_Msg_N ("function result cannot depend on itself", Output);
1484 -- When performing the transformation in place, simply add the
1485 -- output to the list of inputs (if not already there). This case
1486 -- arises when dealing with the last output of an output list -
1487 -- we perform the normalization in place to avoid generating a
1491 Propagate_Output (Output, Inputs);
1493 -- A list with multiple outputs is slowly trimmed until only
1494 -- one element remains. When this happens, replace the
1495 -- aggregate with the element itself.
1499 Rewrite (Outputs, Output);
1505 -- Unchain the output from its output list as it will appear in
1506 -- a new clause. Note that we cannot simply rewrite the output
1507 -- as null because this will violate the semantics of pragma
1512 -- Generate a new clause of the form:
1513 -- (Output => Inputs)
1516 Make_Component_Association (Loc,
1517 Choices => New_List (Output),
1518 Expression => New_Copy_Tree (Inputs));
1520 -- The new clause contains replicated content that has already
1521 -- been analyzed. There is not need to reanalyze it or
1522 -- renormalize it again.
1524 Set_Analyzed (New_Clause);
1527 (Output => First (Choices (New_Clause)),
1528 Inputs => Expression (New_Clause));
1530 Insert_After (After, New_Clause);
1532 end Create_Or_Modify_Clause;
1534 -----------------------
1535 -- Normalize_Outputs --
1536 -----------------------
1538 procedure Normalize_Outputs is
1539 Inputs : constant Node_Id := Expression (Clause);
1540 Loc : constant Source_Ptr := Sloc (Clause);
1541 Outputs : constant Node_Id := First (Choices (Clause));
1542 Last_Output : Node_Id;
1543 New_Clause : Node_Id;
1544 Next_Output : Node_Id;
1548 -- Multiple outputs appear as an aggregate. Nothing to do when
1549 -- the clause has exactly one output.
1551 if Nkind (Outputs) = N_Aggregate then
1552 Last_Output := Last (Expressions (Outputs));
1554 -- Create a clause for each output. Note that each time a new
1555 -- clause is created, the original output list slowly shrinks
1556 -- until there is one item left.
1558 Output := First (Expressions (Outputs));
1559 while Present (Output) loop
1560 Next_Output := Next (Output);
1562 -- Unhook the output from the original output list as it
1563 -- will be relocated to a new clause.
1567 -- Special processing for the last output. At this point
1568 -- the original aggregate has been stripped down to one
1569 -- element. Replace the aggregate by the element itself.
1571 if Output = Last_Output then
1572 Rewrite (Outputs, Output);
1575 -- Generate a clause of the form:
1576 -- (Output => Inputs)
1579 Make_Component_Association (Loc,
1580 Choices => New_List (Output),
1581 Expression => New_Copy_Tree (Inputs));
1583 -- The new clause contains replicated content that has
1584 -- already been analyzed. There is not need to reanalyze
1587 Set_Analyzed (New_Clause);
1588 Insert_After (Clause, New_Clause);
1591 Output := Next_Output;
1594 end Normalize_Outputs;
1598 Outputs : constant Node_Id := First (Choices (Clause));
1600 Last_Output : Node_Id;
1601 Next_Output : Node_Id;
1604 -- Start of processing for Normalize_Clause
1607 -- A self-dependency appears as operator "+". Remove the "+" from the
1608 -- tree by moving the real inputs to their proper place.
1610 if Nkind (Expression (Clause)) = N_Op_Plus then
1611 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1612 Inputs := Expression (Clause);
1614 -- Multiple outputs appear as an aggregate
1616 if Nkind (Outputs) = N_Aggregate then
1617 Last_Output := Last (Expressions (Outputs));
1619 Output := First (Expressions (Outputs));
1620 while Present (Output) loop
1622 -- Normalization may remove an output from its list,
1623 -- preserve the subsequent output now.
1625 Next_Output := Next (Output);
1627 Create_Or_Modify_Clause
1632 In_Place => Output = Last_Output,
1635 Output := Next_Output;
1641 Create_Or_Modify_Clause
1651 -- Split a clause with multiple outputs into multiple clauses with a
1655 end Normalize_Clause;
1659 Deps : constant Node_Id :=
1661 (First (Pragma_Argument_Associations (N)));
1664 Last_Clause : Node_Id;
1665 Subp_Decl : Node_Id;
1667 Restore_Scope : Boolean := False;
1668 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1670 -- Start of processing for Analyze_Depends_In_Decl_Part
1675 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
1676 Subp_Id := Defining_Entity (Subp_Decl);
1678 -- The logic in this routine is used to analyze both pragma Depends and
1679 -- pragma Refined_Depends since they have the same syntax and base
1680 -- semantics. Find the entity of the corresponding spec when analyzing
1683 if Nkind (Subp_Decl) = N_Subprogram_Body
1684 and then Present (Corresponding_Spec (Subp_Decl))
1686 Spec_Id := Corresponding_Spec (Subp_Decl);
1688 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
1689 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
1691 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
1697 -- Empty dependency list
1699 if Nkind (Deps) = N_Null then
1701 -- Gather all states, variables and formal parameters that the
1702 -- subprogram may depend on. These items are obtained from the
1703 -- parameter profile or pragma [Refined_]Global (if available).
1705 Collect_Subprogram_Inputs_Outputs
1706 (Subp_Id => Subp_Id,
1707 Subp_Inputs => Subp_Inputs,
1708 Subp_Outputs => Subp_Outputs,
1709 Global_Seen => Global_Seen);
1711 -- Verify that every input or output of the subprogram appear in a
1714 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1715 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1716 Check_Function_Return;
1718 -- Dependency clauses appear as component associations of an aggregate
1720 elsif Nkind (Deps) = N_Aggregate then
1722 -- Do not attempt to perform analysis of a syntactically illegal
1723 -- clause as this will lead to misleading errors.
1725 if Has_Extra_Parentheses (Deps) then
1729 if Present (Component_Associations (Deps)) then
1730 Last_Clause := Last (Component_Associations (Deps));
1732 -- Gather all states, variables and formal parameters that the
1733 -- subprogram may depend on. These items are obtained from the
1734 -- parameter profile or pragma [Refined_]Global (if available).
1736 Collect_Subprogram_Inputs_Outputs
1737 (Subp_Id => Subp_Id,
1738 Subp_Inputs => Subp_Inputs,
1739 Subp_Outputs => Subp_Outputs,
1740 Global_Seen => Global_Seen);
1742 -- Ensure that the formal parameters are visible when analyzing
1743 -- all clauses. This falls out of the general rule of aspects
1744 -- pertaining to subprogram declarations. Skip the installation
1745 -- for subprogram bodies because the formals are already visible.
1747 if not In_Open_Scopes (Spec_Id) then
1748 Restore_Scope := True;
1749 Push_Scope (Spec_Id);
1750 Install_Formals (Spec_Id);
1753 Clause := First (Component_Associations (Deps));
1754 while Present (Clause) loop
1755 Errors := Serious_Errors_Detected;
1757 -- Normalization may create extra clauses that contain
1758 -- replicated input and output names. There is no need to
1761 if not Analyzed (Clause) then
1762 Set_Analyzed (Clause);
1764 Analyze_Dependency_Clause
1766 Is_Last => Clause = Last_Clause);
1769 -- Do not normalize a clause if errors were detected (count
1770 -- of Serious_Errors has increased) because the inputs and/or
1771 -- outputs may denote illegal items. Normalization is disabled
1772 -- in ASIS mode as it alters the tree by introducing new nodes
1773 -- similar to expansion.
1775 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1776 Normalize_Clause (Clause);
1782 if Restore_Scope then
1786 -- Verify that every input or output of the subprogram appear in a
1789 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1790 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1791 Check_Function_Return;
1793 -- The dependency list is malformed. This is a syntax error, always
1797 Error_Msg_N ("malformed dependency relation", Deps);
1801 -- The top level dependency relation is malformed. This is a syntax
1802 -- error, always report.
1805 Error_Msg_N ("malformed dependency relation", Deps);
1809 -- Ensure that a state and a corresponding constituent do not appear
1810 -- together in pragma [Refined_]Depends.
1812 Check_State_And_Constituent_Use
1813 (States => States_Seen,
1814 Constits => Constits_Seen,
1816 end Analyze_Depends_In_Decl_Part;
1818 --------------------------------------------
1819 -- Analyze_External_Property_In_Decl_Part --
1820 --------------------------------------------
1822 procedure Analyze_External_Property_In_Decl_Part
1824 Expr_Val : out Boolean)
1826 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1827 Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
1828 Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1));
1831 Error_Msg_Name_1 := Pragma_Name (N);
1833 -- An external property pragma must apply to a volatile object other
1834 -- than a formal subprogram parameter (SPARK RM 7.1.3(2)). The check
1835 -- is performed at the end of the declarative region due to a possible
1836 -- out-of-order arrangement of pragmas:
1839 -- pragma Async_Readers (Obj);
1840 -- pragma Volatile (Obj);
1842 if not Is_SPARK_Volatile (Obj_Id) then
1844 ("external property % must apply to a volatile object", N);
1847 -- Ensure that the Boolean expression (if present) is static. A missing
1848 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1852 if Present (Expr) then
1853 Analyze_And_Resolve (Expr, Standard_Boolean);
1855 if Is_OK_Static_Expression (Expr) then
1856 Expr_Val := Is_True (Expr_Value (Expr));
1858 SPARK_Msg_N ("expression of % must be static", Expr);
1861 end Analyze_External_Property_In_Decl_Part;
1863 ---------------------------------
1864 -- Analyze_Global_In_Decl_Part --
1865 ---------------------------------
1867 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
1868 Constits_Seen : Elist_Id := No_Elist;
1869 -- A list containing the entities of all constituents processed so far.
1870 -- It aids in detecting illegal usage of a state and a corresponding
1871 -- constituent in pragma [Refinde_]Global.
1873 Seen : Elist_Id := No_Elist;
1874 -- A list containing the entities of all the items processed so far. It
1875 -- plays a role in detecting distinct entities.
1877 Spec_Id : Entity_Id;
1878 -- The entity of the subprogram subject to pragma [Refined_]Global
1880 States_Seen : Elist_Id := No_Elist;
1881 -- A list containing the entities of all states processed so far. It
1882 -- helps in detecting illegal usage of a state and a corresponding
1883 -- constituent in pragma [Refined_]Global.
1885 Subp_Id : Entity_Id;
1886 -- The entity of the subprogram [body or stub] subject to pragma
1887 -- [Refined_]Global.
1889 In_Out_Seen : Boolean := False;
1890 Input_Seen : Boolean := False;
1891 Output_Seen : Boolean := False;
1892 Proof_Seen : Boolean := False;
1893 -- Flags used to verify the consistency of modes
1895 procedure Analyze_Global_List
1897 Global_Mode : Name_Id := Name_Input);
1898 -- Verify the legality of a single global list declaration. Global_Mode
1899 -- denotes the current mode in effect.
1901 -------------------------
1902 -- Analyze_Global_List --
1903 -------------------------
1905 procedure Analyze_Global_List
1907 Global_Mode : Name_Id := Name_Input)
1909 procedure Analyze_Global_Item
1911 Global_Mode : Name_Id);
1912 -- Verify the legality of a single global item declaration.
1913 -- Global_Mode denotes the current mode in effect.
1915 procedure Check_Duplicate_Mode
1917 Status : in out Boolean);
1918 -- Flag Status denotes whether a particular mode has been seen while
1919 -- processing a global list. This routine verifies that Mode is not a
1920 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1922 procedure Check_Mode_Restriction_In_Enclosing_Context
1924 Item_Id : Entity_Id);
1925 -- Verify that an item of mode In_Out or Output does not appear as an
1926 -- input in the Global aspect of an enclosing subprogram. If this is
1927 -- the case, emit an error. Item and Item_Id are respectively the
1928 -- item and its entity.
1930 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
1931 -- Mode denotes either In_Out or Output. Depending on the kind of the
1932 -- related subprogram, emit an error if those two modes apply to a
1933 -- function (SPARK RM 6.1.4(10)).
1935 -------------------------
1936 -- Analyze_Global_Item --
1937 -------------------------
1939 procedure Analyze_Global_Item
1941 Global_Mode : Name_Id)
1943 Item_Id : Entity_Id;
1946 -- Detect one of the following cases
1948 -- with Global => (null, Name)
1949 -- with Global => (Name_1, null, Name_2)
1950 -- with Global => (Name, null)
1952 if Nkind (Item) = N_Null then
1953 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
1958 Resolve_State (Item);
1960 -- Find the entity of the item. If this is a renaming, climb the
1961 -- renaming chain to reach the root object. Renamings of non-
1962 -- entire objects do not yield an entity (Empty).
1964 Item_Id := Entity_Of (Item);
1966 if Present (Item_Id) then
1968 -- A global item may denote a formal parameter of an enclosing
1969 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1970 -- provide a better error diagnostic.
1972 if Is_Formal (Item_Id) then
1973 if Scope (Item_Id) = Spec_Id then
1975 ("global item cannot reference parameter of subprogram",
1980 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1981 -- Do this check first to provide a better error diagnostic.
1983 elsif Ekind (Item_Id) = E_Constant then
1984 SPARK_Msg_N ("global item cannot denote a constant", Item);
1986 -- The only legal references are those to abstract states and
1987 -- variables (SPARK RM 6.1.4(4)).
1989 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
1991 ("global item must denote variable or state", Item);
1995 -- State related checks
1997 if Ekind (Item_Id) = E_Abstract_State then
1999 -- An abstract state with visible refinement cannot appear
2000 -- in pragma [Refined_]Global as its place must be taken by
2001 -- some of its constituents (SPARK RM 6.1.4(8)).
2003 if Has_Visible_Refinement (Item_Id) then
2005 ("cannot mention state & in global refinement",
2007 SPARK_Msg_N ("\use its constituents instead", Item);
2010 -- If the reference to the abstract state appears in an
2011 -- enclosing package body that will eventually refine the
2012 -- state, record the reference for future checks.
2015 Record_Possible_Body_Reference
2016 (State_Id => Item_Id,
2020 -- Variable related checks. These are only relevant when
2021 -- SPARK_Mode is on as they are not standard Ada legality
2024 elsif SPARK_Mode = On and then Is_SPARK_Volatile (Item_Id) then
2026 -- A volatile object cannot appear as a global item of a
2027 -- function (SPARK RM 7.1.3(9)).
2029 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2031 ("volatile object & cannot act as global item of a "
2032 & "function", Item, Item_Id);
2035 -- A volatile object with property Effective_Reads set to
2036 -- True must have mode Output or In_Out.
2038 elsif Effective_Reads_Enabled (Item_Id)
2039 and then Global_Mode = Name_Input
2042 ("volatile object & with property Effective_Reads must "
2043 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
2049 -- When the item renames an entire object, replace the item
2050 -- with a reference to the object.
2052 if Present (Renamed_Object (Entity (Item))) then
2053 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2057 -- Some form of illegal construct masquerading as a name
2058 -- (SPARK RM 6.1.4(4)).
2061 Error_Msg_N ("global item must denote variable or state", Item);
2065 -- Verify that an output does not appear as an input in an
2066 -- enclosing subprogram.
2068 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2069 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2072 -- The same entity might be referenced through various way.
2073 -- Check the entity of the item rather than the item itself
2074 -- (SPARK RM 6.1.4(11)).
2076 if Contains (Seen, Item_Id) then
2077 SPARK_Msg_N ("duplicate global item", Item);
2079 -- Add the entity of the current item to the list of processed
2083 Add_Item (Item_Id, Seen);
2085 if Ekind (Item_Id) = E_Abstract_State then
2086 Add_Item (Item_Id, States_Seen);
2089 if Ekind_In (Item_Id, E_Abstract_State, E_Variable)
2090 and then Present (Encapsulating_State (Item_Id))
2092 Add_Item (Item_Id, Constits_Seen);
2095 end Analyze_Global_Item;
2097 --------------------------
2098 -- Check_Duplicate_Mode --
2099 --------------------------
2101 procedure Check_Duplicate_Mode
2103 Status : in out Boolean)
2107 SPARK_Msg_N ("duplicate global mode", Mode);
2111 end Check_Duplicate_Mode;
2113 -------------------------------------------------
2114 -- Check_Mode_Restriction_In_Enclosing_Context --
2115 -------------------------------------------------
2117 procedure Check_Mode_Restriction_In_Enclosing_Context
2119 Item_Id : Entity_Id)
2121 Context : Entity_Id;
2123 Inputs : Elist_Id := No_Elist;
2124 Outputs : Elist_Id := No_Elist;
2127 -- Traverse the scope stack looking for enclosing subprograms
2128 -- subject to pragma [Refined_]Global.
2130 Context := Scope (Subp_Id);
2131 while Present (Context) and then Context /= Standard_Standard loop
2132 if Is_Subprogram (Context)
2134 (Present (Get_Pragma (Context, Pragma_Global))
2136 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2138 Collect_Subprogram_Inputs_Outputs
2139 (Subp_Id => Context,
2140 Subp_Inputs => Inputs,
2141 Subp_Outputs => Outputs,
2142 Global_Seen => Dummy);
2144 -- The item is classified as In_Out or Output but appears as
2145 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2147 if Appears_In (Inputs, Item_Id)
2148 and then not Appears_In (Outputs, Item_Id)
2151 ("global item & cannot have mode In_Out or Output",
2154 ("\item already appears as input of subprogram &",
2157 -- Stop the traversal once an error has been detected
2163 Context := Scope (Context);
2165 end Check_Mode_Restriction_In_Enclosing_Context;
2167 ----------------------------------------
2168 -- Check_Mode_Restriction_In_Function --
2169 ----------------------------------------
2171 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2173 if Ekind (Spec_Id) = E_Function then
2175 ("global mode & is not applicable to functions", Mode);
2177 end Check_Mode_Restriction_In_Function;
2185 -- Start of processing for Analyze_Global_List
2188 if Nkind (List) = N_Null then
2189 Set_Analyzed (List);
2191 -- Single global item declaration
2193 elsif Nkind_In (List, N_Expanded_Name,
2195 N_Selected_Component)
2197 Analyze_Global_Item (List, Global_Mode);
2199 -- Simple global list or moded global list declaration
2201 elsif Nkind (List) = N_Aggregate then
2202 Set_Analyzed (List);
2204 -- The declaration of a simple global list appear as a collection
2207 if Present (Expressions (List)) then
2208 if Present (Component_Associations (List)) then
2210 ("cannot mix moded and non-moded global lists", List);
2213 Item := First (Expressions (List));
2214 while Present (Item) loop
2215 Analyze_Global_Item (Item, Global_Mode);
2220 -- The declaration of a moded global list appears as a collection
2221 -- of component associations where individual choices denote
2224 elsif Present (Component_Associations (List)) then
2225 if Present (Expressions (List)) then
2227 ("cannot mix moded and non-moded global lists", List);
2230 Assoc := First (Component_Associations (List));
2231 while Present (Assoc) loop
2232 Mode := First (Choices (Assoc));
2234 if Nkind (Mode) = N_Identifier then
2235 if Chars (Mode) = Name_In_Out then
2236 Check_Duplicate_Mode (Mode, In_Out_Seen);
2237 Check_Mode_Restriction_In_Function (Mode);
2239 elsif Chars (Mode) = Name_Input then
2240 Check_Duplicate_Mode (Mode, Input_Seen);
2242 elsif Chars (Mode) = Name_Output then
2243 Check_Duplicate_Mode (Mode, Output_Seen);
2244 Check_Mode_Restriction_In_Function (Mode);
2246 elsif Chars (Mode) = Name_Proof_In then
2247 Check_Duplicate_Mode (Mode, Proof_Seen);
2250 SPARK_Msg_N ("invalid mode selector", Mode);
2254 SPARK_Msg_N ("invalid mode selector", Mode);
2257 -- Items in a moded list appear as a collection of
2258 -- expressions. Reuse the existing machinery to analyze
2262 (List => Expression (Assoc),
2263 Global_Mode => Chars (Mode));
2271 raise Program_Error;
2274 -- Any other attempt to declare a global item is illegal. This is a
2275 -- syntax error, always report.
2278 Error_Msg_N ("malformed global list", List);
2280 end Analyze_Global_List;
2284 Items : constant Node_Id :=
2285 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2286 Subp_Decl : Node_Id;
2288 Restore_Scope : Boolean := False;
2289 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2291 -- Start of processing for Analyze_Global_In_Decl_List
2295 Check_SPARK_Aspect_For_ASIS (N);
2297 Subp_Decl := Find_Related_Subprogram_Or_Body (N);
2298 Subp_Id := Defining_Entity (Subp_Decl);
2300 -- The logic in this routine is used to analyze both pragma Global and
2301 -- pragma Refined_Global since they have the same syntax and base
2302 -- semantics. Find the entity of the corresponding spec when analyzing
2305 if Nkind (Subp_Decl) = N_Subprogram_Body
2306 and then Present (Corresponding_Spec (Subp_Decl))
2308 Spec_Id := Corresponding_Spec (Subp_Decl);
2310 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
2311 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
2313 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
2319 -- There is nothing to be done for a null global list
2321 if Nkind (Items) = N_Null then
2322 Set_Analyzed (Items);
2324 -- Analyze the various forms of global lists and items. Note that some
2325 -- of these may be malformed in which case the analysis emits error
2329 -- Ensure that the formal parameters are visible when processing an
2330 -- item. This falls out of the general rule of aspects pertaining to
2331 -- subprogram declarations.
2333 if not In_Open_Scopes (Spec_Id) then
2334 Restore_Scope := True;
2335 Push_Scope (Spec_Id);
2336 Install_Formals (Spec_Id);
2339 Analyze_Global_List (Items);
2341 if Restore_Scope then
2346 -- Ensure that a state and a corresponding constituent do not appear
2347 -- together in pragma [Refined_]Global.
2349 Check_State_And_Constituent_Use
2350 (States => States_Seen,
2351 Constits => Constits_Seen,
2353 end Analyze_Global_In_Decl_Part;
2355 --------------------------------------------
2356 -- Analyze_Initial_Condition_In_Decl_Part --
2357 --------------------------------------------
2359 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2360 Expr : constant Node_Id :=
2361 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2366 -- The expression is preanalyzed because it has not been moved to its
2367 -- final place yet. A direct analysis may generate side effects and this
2368 -- is not desired at this point.
2370 Preanalyze_And_Resolve (Expr, Standard_Boolean);
2371 end Analyze_Initial_Condition_In_Decl_Part;
2373 --------------------------------------
2374 -- Analyze_Initializes_In_Decl_Part --
2375 --------------------------------------
2377 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2378 Pack_Spec : constant Node_Id := Parent (N);
2379 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec));
2381 Constits_Seen : Elist_Id := No_Elist;
2382 -- A list containing the entities of all constituents processed so far.
2383 -- It aids in detecting illegal usage of a state and a corresponding
2384 -- constituent in pragma Initializes.
2386 Items_Seen : Elist_Id := No_Elist;
2387 -- A list of all initialization items processed so far. This list is
2388 -- used to detect duplicate items.
2390 Non_Null_Seen : Boolean := False;
2391 Null_Seen : Boolean := False;
2392 -- Flags used to check the legality of a null initialization list
2394 States_And_Vars : Elist_Id := No_Elist;
2395 -- A list of all abstract states and variables declared in the visible
2396 -- declarations of the related package. This list is used to detect the
2397 -- legality of initialization items.
2399 States_Seen : Elist_Id := No_Elist;
2400 -- A list containing the entities of all states processed so far. It
2401 -- helps in detecting illegal usage of a state and a corresponding
2402 -- constituent in pragma Initializes.
2404 procedure Analyze_Initialization_Item (Item : Node_Id);
2405 -- Verify the legality of a single initialization item
2407 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2408 -- Verify the legality of a single initialization item followed by a
2409 -- list of input items.
2411 procedure Collect_States_And_Variables;
2412 -- Inspect the visible declarations of the related package and gather
2413 -- the entities of all abstract states and variables in States_And_Vars.
2415 ---------------------------------
2416 -- Analyze_Initialization_Item --
2417 ---------------------------------
2419 procedure Analyze_Initialization_Item (Item : Node_Id) is
2420 Item_Id : Entity_Id;
2423 -- Null initialization list
2425 if Nkind (Item) = N_Null then
2427 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2429 elsif Non_Null_Seen then
2431 ("cannot mix null and non-null initialization items", Item);
2436 -- Initialization item
2439 Non_Null_Seen := True;
2443 ("cannot mix null and non-null initialization items", Item);
2447 Resolve_State (Item);
2449 if Is_Entity_Name (Item) then
2450 Item_Id := Entity_Of (Item);
2452 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
2454 -- The state or variable must be declared in the visible
2455 -- declarations of the package (SPARK RM 7.1.5(7)).
2457 if not Contains (States_And_Vars, Item_Id) then
2458 Error_Msg_Name_1 := Chars (Pack_Id);
2460 ("initialization item & must appear in the visible "
2461 & "declarations of package %", Item, Item_Id);
2463 -- Detect a duplicate use of the same initialization item
2464 -- (SPARK RM 7.1.5(5)).
2466 elsif Contains (Items_Seen, Item_Id) then
2467 SPARK_Msg_N ("duplicate initialization item", Item);
2469 -- The item is legal, add it to the list of processed states
2473 Add_Item (Item_Id, Items_Seen);
2475 if Ekind (Item_Id) = E_Abstract_State then
2476 Add_Item (Item_Id, States_Seen);
2479 if Present (Encapsulating_State (Item_Id)) then
2480 Add_Item (Item_Id, Constits_Seen);
2484 -- The item references something that is not a state or a
2485 -- variable (SPARK RM 7.1.5(3)).
2489 ("initialization item must denote variable or state",
2493 -- Some form of illegal construct masquerading as a name
2494 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2498 ("initialization item must denote variable or state", Item);
2501 end Analyze_Initialization_Item;
2503 ---------------------------------------------
2504 -- Analyze_Initialization_Item_With_Inputs --
2505 ---------------------------------------------
2507 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2508 Inputs_Seen : Elist_Id := No_Elist;
2509 -- A list of all inputs processed so far. This list is used to detect
2510 -- duplicate uses of an input.
2512 Non_Null_Seen : Boolean := False;
2513 Null_Seen : Boolean := False;
2514 -- Flags used to check the legality of an input list
2516 procedure Analyze_Input_Item (Input : Node_Id);
2517 -- Verify the legality of a single input item
2519 ------------------------
2520 -- Analyze_Input_Item --
2521 ------------------------
2523 procedure Analyze_Input_Item (Input : Node_Id) is
2524 Input_Id : Entity_Id;
2529 if Nkind (Input) = N_Null then
2532 ("multiple null initializations not allowed", Item);
2534 elsif Non_Null_Seen then
2536 ("cannot mix null and non-null initialization item", Item);
2544 Non_Null_Seen := True;
2548 ("cannot mix null and non-null initialization item", Item);
2552 Resolve_State (Input);
2554 if Is_Entity_Name (Input) then
2555 Input_Id := Entity_Of (Input);
2557 if Ekind_In (Input_Id, E_Abstract_State,
2563 -- The input cannot denote states or variables declared
2564 -- within the related package.
2566 if Within_Scope (Input_Id, Current_Scope) then
2567 Error_Msg_Name_1 := Chars (Pack_Id);
2569 ("input item & cannot denote a visible variable or "
2570 & "state of package % (SPARK RM 7.1.5(4))",
2573 -- Detect a duplicate use of the same input item
2574 -- (SPARK RM 7.1.5(5)).
2576 elsif Contains (Inputs_Seen, Input_Id) then
2577 SPARK_Msg_N ("duplicate input item", Input);
2579 -- Input is legal, add it to the list of processed inputs
2582 Add_Item (Input_Id, Inputs_Seen);
2584 if Ekind (Input_Id) = E_Abstract_State then
2585 Add_Item (Input_Id, States_Seen);
2588 if Ekind_In (Input_Id, E_Abstract_State, E_Variable)
2589 and then Present (Encapsulating_State (Input_Id))
2591 Add_Item (Input_Id, Constits_Seen);
2595 -- The input references something that is not a state or a
2596 -- variable (SPARK RM 7.1.5(3)).
2600 ("input item must denote variable or state", Input);
2603 -- Some form of illegal construct masquerading as a name
2604 -- (SPARK RM 7.1.5(3)).
2608 ("input item must denote variable or state", Input);
2611 end Analyze_Input_Item;
2615 Inputs : constant Node_Id := Expression (Item);
2619 Name_Seen : Boolean := False;
2620 -- A flag used to detect multiple item names
2622 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2625 -- Inspect the name of an item with inputs
2627 Elmt := First (Choices (Item));
2628 while Present (Elmt) loop
2630 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2633 Analyze_Initialization_Item (Elmt);
2639 -- Multiple input items appear as an aggregate
2641 if Nkind (Inputs) = N_Aggregate then
2642 if Present (Expressions (Inputs)) then
2643 Input := First (Expressions (Inputs));
2644 while Present (Input) loop
2645 Analyze_Input_Item (Input);
2650 if Present (Component_Associations (Inputs)) then
2652 ("inputs must appear in named association form", Inputs);
2655 -- Single input item
2658 Analyze_Input_Item (Inputs);
2660 end Analyze_Initialization_Item_With_Inputs;
2662 ----------------------------------
2663 -- Collect_States_And_Variables --
2664 ----------------------------------
2666 procedure Collect_States_And_Variables is
2670 -- Collect the abstract states defined in the package (if any)
2672 if Present (Abstract_States (Pack_Id)) then
2673 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id));
2676 -- Collect all variables the appear in the visible declarations of
2677 -- the related package.
2679 if Present (Visible_Declarations (Pack_Spec)) then
2680 Decl := First (Visible_Declarations (Pack_Spec));
2681 while Present (Decl) loop
2682 if Nkind (Decl) = N_Object_Declaration
2683 and then Ekind (Defining_Entity (Decl)) = E_Variable
2684 and then Comes_From_Source (Decl)
2686 Add_Item (Defining_Entity (Decl), States_And_Vars);
2692 end Collect_States_And_Variables;
2696 Inits : constant Node_Id :=
2697 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
2700 -- Start of processing for Analyze_Initializes_In_Decl_Part
2705 Check_SPARK_Aspect_For_ASIS (N);
2707 -- Nothing to do when the initialization list is empty
2709 if Nkind (Inits) = N_Null then
2713 -- Single and multiple initialization clauses appear as an aggregate. If
2714 -- this is not the case, then either the parser or the analysis of the
2715 -- pragma failed to produce an aggregate.
2717 pragma Assert (Nkind (Inits) = N_Aggregate);
2719 -- Initialize the various lists used during analysis
2721 Collect_States_And_Variables;
2723 if Present (Expressions (Inits)) then
2724 Init := First (Expressions (Inits));
2725 while Present (Init) loop
2726 Analyze_Initialization_Item (Init);
2731 if Present (Component_Associations (Inits)) then
2732 Init := First (Component_Associations (Inits));
2733 while Present (Init) loop
2734 Analyze_Initialization_Item_With_Inputs (Init);
2739 -- Ensure that a state and a corresponding constituent do not appear
2740 -- together in pragma Initializes.
2742 Check_State_And_Constituent_Use
2743 (States => States_Seen,
2744 Constits => Constits_Seen,
2746 end Analyze_Initializes_In_Decl_Part;
2748 --------------------
2749 -- Analyze_Pragma --
2750 --------------------
2752 procedure Analyze_Pragma (N : Node_Id) is
2753 Loc : constant Source_Ptr := Sloc (N);
2754 Prag_Id : Pragma_Id;
2757 -- Name of the source pragma, or name of the corresponding aspect for
2758 -- pragmas which originate in a source aspect. In the latter case, the
2759 -- name may be different from the pragma name.
2761 Pragma_Exit : exception;
2762 -- This exception is used to exit pragma processing completely. It
2763 -- is used when an error is detected, and no further processing is
2764 -- required. It is also used if an earlier error has left the tree in
2765 -- a state where the pragma should not be processed.
2768 -- Number of pragma argument associations
2774 -- First four pragma arguments (pragma argument association nodes, or
2775 -- Empty if the corresponding argument does not exist).
2777 type Name_List is array (Natural range <>) of Name_Id;
2778 type Args_List is array (Natural range <>) of Node_Id;
2779 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2781 -----------------------
2782 -- Local Subprograms --
2783 -----------------------
2785 procedure Acquire_Warning_Match_String (Arg : Node_Id);
2786 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2787 -- get the given string argument, and place it in Name_Buffer, adding
2788 -- leading and trailing asterisks if they are not already present. The
2789 -- caller has already checked that Arg is a static string expression.
2791 procedure Ada_2005_Pragma;
2792 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2793 -- Ada 95 mode, these are implementation defined pragmas, so should be
2794 -- caught by the No_Implementation_Pragmas restriction.
2796 procedure Ada_2012_Pragma;
2797 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2798 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2799 -- should be caught by the No_Implementation_Pragmas restriction.
2801 procedure Analyze_Part_Of
2802 (Item_Id : Entity_Id;
2805 Legal : out Boolean);
2806 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2807 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2808 -- an abstract state, variable or package instantiation. State is the
2809 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2810 -- set when the indicator is legal.
2812 procedure Analyze_Refined_Pragma
2813 (Spec_Id : out Entity_Id;
2814 Body_Id : out Entity_Id;
2815 Legal : out Boolean);
2816 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2817 -- Refined_Global and Refined_Post. Check the placement and related
2818 -- context of the pragma. Spec_Id is the entity of the related
2819 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2820 -- Legal is set when the pragma is properly placed.
2822 procedure Check_Ada_83_Warning;
2823 -- Issues a warning message for the current pragma if operating in Ada
2824 -- 83 mode (used for language pragmas that are not a standard part of
2825 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
2828 procedure Check_Arg_Count (Required : Nat);
2829 -- Check argument count for pragma is equal to given parameter. If not,
2830 -- then issue an error message and raise Pragma_Exit.
2832 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2833 -- Arg which can either be a pragma argument association, in which case
2834 -- the check is applied to the expression of the association or an
2835 -- expression directly.
2837 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
2838 -- Check that an argument has the right form for an EXTERNAL_NAME
2839 -- parameter of an extended import/export pragma. The rule is that the
2840 -- name must be an identifier or string literal (in Ada 83 mode) or a
2841 -- static string expression (in Ada 95 mode).
2843 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
2844 -- Check the specified argument Arg to make sure that it is an
2845 -- identifier. If not give error and raise Pragma_Exit.
2847 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
2848 -- Check the specified argument Arg to make sure that it is an integer
2849 -- literal. If not give error and raise Pragma_Exit.
2851 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
2852 -- Check the specified argument Arg to make sure that it has the proper
2853 -- syntactic form for a local name and meets the semantic requirements
2854 -- for a local name. The local name is analyzed as part of the
2855 -- processing for this call. In addition, the local name is required
2856 -- to represent an entity at the library level.
2858 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
2859 -- Check the specified argument Arg to make sure that it has the proper
2860 -- syntactic form for a local name and meets the semantic requirements
2861 -- for a local name. The local name is analyzed as part of the
2862 -- processing for this call.
2864 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
2865 -- Check the specified argument Arg to make sure that it is a valid
2866 -- locking policy name. If not give error and raise Pragma_Exit.
2868 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
2869 -- Check the specified argument Arg to make sure that it is a valid
2870 -- elaboration policy name. If not give error and raise Pragma_Exit.
2872 procedure Check_Arg_Is_One_Of
2875 procedure Check_Arg_Is_One_Of
2877 N1, N2, N3 : Name_Id);
2878 procedure Check_Arg_Is_One_Of
2880 N1, N2, N3, N4 : Name_Id);
2881 procedure Check_Arg_Is_One_Of
2883 N1, N2, N3, N4, N5 : Name_Id);
2884 -- Check the specified argument Arg to make sure that it is an
2885 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2886 -- present). If not then give error and raise Pragma_Exit.
2888 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
2889 -- Check the specified argument Arg to make sure that it is a valid
2890 -- queuing policy name. If not give error and raise Pragma_Exit.
2892 procedure Check_Arg_Is_OK_Static_Expression
2894 Typ : Entity_Id := Empty);
2895 -- Check the specified argument Arg to make sure that it is a static
2896 -- expression of the given type (i.e. it will be analyzed and resolved
2897 -- using this type, which can be any valid argument to Resolve, e.g.
2898 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2899 -- Typ is left Empty, then any static expression is allowed. Includes
2900 -- checking that the argument does not raise Constraint_Error.
2902 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
2903 -- Check the specified argument Arg to make sure that it is a valid task
2904 -- dispatching policy name. If not give error and raise Pragma_Exit.
2906 procedure Check_Arg_Order (Names : Name_List);
2907 -- Checks for an instance of two arguments with identifiers for the
2908 -- current pragma which are not in the sequence indicated by Names,
2909 -- and if so, generates a fatal message about bad order of arguments.
2911 procedure Check_At_Least_N_Arguments (N : Nat);
2912 -- Check there are at least N arguments present
2914 procedure Check_At_Most_N_Arguments (N : Nat);
2915 -- Check there are no more than N arguments present
2917 procedure Check_Component
2920 In_Variant_Part : Boolean := False);
2921 -- Examine an Unchecked_Union component for correct use of per-object
2922 -- constrained subtypes, and for restrictions on finalizable components.
2923 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2924 -- should be set when Comp comes from a record variant.
2926 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id);
2927 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2928 -- Initial_Condition and Initializes. Determine whether pragma First
2929 -- appears before pragma Second. If this is not the case, emit an error.
2931 procedure Check_Duplicate_Pragma (E : Entity_Id);
2932 -- Check if a rep item of the same name as the current pragma is already
2933 -- chained as a rep pragma to the given entity. If so give a message
2934 -- about the duplicate, and then raise Pragma_Exit so does not return.
2935 -- Note that if E is a type, then this routine avoids flagging a pragma
2936 -- which applies to a parent type from which E is derived.
2938 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
2939 -- Nam is an N_String_Literal node containing the external name set by
2940 -- an Import or Export pragma (or extended Import or Export pragma).
2941 -- This procedure checks for possible duplications if this is the export
2942 -- case, and if found, issues an appropriate error message.
2944 procedure Check_Expr_Is_OK_Static_Expression
2946 Typ : Entity_Id := Empty);
2947 -- Check the specified expression Expr to make sure that it is a static
2948 -- expression of the given type (i.e. it will be analyzed and resolved
2949 -- using this type, which can be any valid argument to Resolve, e.g.
2950 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2951 -- Typ is left Empty, then any static expression is allowed. Includes
2952 -- checking that the expression does not raise Constraint_Error.
2954 procedure Check_First_Subtype (Arg : Node_Id);
2955 -- Checks that Arg, whose expression is an entity name, references a
2958 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
2959 -- Checks that the given argument has an identifier, and if so, requires
2960 -- it to match the given identifier name. If there is no identifier, or
2961 -- a non-matching identifier, then an error message is given and
2962 -- Pragma_Exit is raised.
2964 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
2965 -- Checks that the given argument has an identifier, and if so, requires
2966 -- it to match one of the given identifier names. If there is no
2967 -- identifier, or a non-matching identifier, then an error message is
2968 -- given and Pragma_Exit is raised.
2970 procedure Check_In_Main_Program;
2971 -- Common checks for pragmas that appear within a main program
2972 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2974 procedure Check_Interrupt_Or_Attach_Handler;
2975 -- Common processing for first argument of pragma Interrupt_Handler or
2976 -- pragma Attach_Handler.
2978 procedure Check_Loop_Pragma_Placement;
2979 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2980 -- appear immediately within a construct restricted to loops, and that
2981 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2983 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
2984 -- Check that pragma appears in a declarative part, or in a package
2985 -- specification, i.e. that it does not occur in a statement sequence
2988 procedure Check_No_Identifier (Arg : Node_Id);
2989 -- Checks that the given argument does not have an identifier. If
2990 -- an identifier is present, then an error message is issued, and
2991 -- Pragma_Exit is raised.
2993 procedure Check_No_Identifiers;
2994 -- Checks that none of the arguments to the pragma has an identifier.
2995 -- If any argument has an identifier, then an error message is issued,
2996 -- and Pragma_Exit is raised.
2998 procedure Check_No_Link_Name;
2999 -- Checks that no link name is specified
3001 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3002 -- Checks if the given argument has an identifier, and if so, requires
3003 -- it to match the given identifier name. If there is a non-matching
3004 -- identifier, then an error message is given and Pragma_Exit is raised.
3006 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3007 -- Checks if the given argument has an identifier, and if so, requires
3008 -- it to match the given identifier name. If there is a non-matching
3009 -- identifier, then an error message is given and Pragma_Exit is raised.
3010 -- In this version of the procedure, the identifier name is given as
3011 -- a string with lower case letters.
3013 procedure Check_Pre_Post;
3014 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class
3015 -- pragmas. These are processed by transformation to equivalent
3016 -- Precondition and Postcondition pragmas, but Pre and Post need an
3017 -- additional check that they are not used in a subprogram body when
3018 -- there is a separate spec present.
3020 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
3021 -- Called to process a precondition or postcondition pragma. There are
3024 -- The pragma appears after a subprogram spec
3026 -- If the corresponding check is not enabled, the pragma is analyzed
3027 -- but otherwise ignored and control returns with In_Body set False.
3029 -- If the check is enabled, then the first step is to analyze the
3030 -- pragma, but this is skipped if the subprogram spec appears within
3031 -- a package specification (because this is the case where we delay
3032 -- analysis till the end of the spec). Then (whether or not it was
3033 -- analyzed), the pragma is chained to the subprogram in question
3034 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
3035 -- to the caller with In_Body set False.
3037 -- The pragma appears at the start of subprogram body declarations
3039 -- In this case an immediate return to the caller is made with
3040 -- In_Body set True, and the pragma is NOT analyzed.
3042 -- In all other cases, an error message for bad placement is given
3044 procedure Check_Static_Constraint (Constr : Node_Id);
3045 -- Constr is a constraint from an N_Subtype_Indication node from a
3046 -- component constraint in an Unchecked_Union type. This routine checks
3047 -- that the constraint is static as required by the restrictions for
3050 procedure Check_Test_Case;
3051 -- Called to process a test-case pragma. It starts with checking pragma
3052 -- arguments, and the rest of the treatment is similar to the one for
3053 -- pre- and postcondition in Check_Precondition_Postcondition, except
3054 -- the placement rules for the test-case pragma are stricter. These
3055 -- pragmas may only occur after a subprogram spec declared directly
3056 -- in a package spec unit. In this case, the pragma is chained to the
3057 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
3058 -- and analysis of the pragma is delayed till the end of the spec. In
3059 -- all other cases, an error message for bad placement is given.
3061 procedure Check_Valid_Configuration_Pragma;
3062 -- Legality checks for placement of a configuration pragma
3064 procedure Check_Valid_Library_Unit_Pragma;
3065 -- Legality checks for library unit pragmas. A special case arises for
3066 -- pragmas in generic instances that come from copies of the original
3067 -- library unit pragmas in the generic templates. In the case of other
3068 -- than library level instantiations these can appear in contexts which
3069 -- would normally be invalid (they only apply to the original template
3070 -- and to library level instantiations), and they are simply ignored,
3071 -- which is implemented by rewriting them as null statements.
3073 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3074 -- Check an Unchecked_Union variant for lack of nested variants and
3075 -- presence of at least one component. UU_Typ is the related Unchecked_
3078 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3079 -- Subsidiary routine to the processing of pragmas Abstract_State,
3080 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3081 -- Refined_Global and Refined_State. Transform argument Arg into an
3082 -- aggregate if not one already. N_Null is never transformed.
3084 procedure Error_Pragma (Msg : String);
3085 pragma No_Return (Error_Pragma);
3086 -- Outputs error message for current pragma. The message contains a %
3087 -- that will be replaced with the pragma name, and the flag is placed
3088 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3089 -- calls Fix_Error (see spec of that procedure for details).
3091 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3092 pragma No_Return (Error_Pragma_Arg);
3093 -- Outputs error message for current pragma. The message may contain
3094 -- a % that will be replaced with the pragma name. The parameter Arg
3095 -- may either be a pragma argument association, in which case the flag
3096 -- is placed on the expression of this association, or an expression,
3097 -- in which case the flag is placed directly on the expression. The
3098 -- message is placed using Error_Msg_N, so the message may also contain
3099 -- an & insertion character which will reference the given Arg value.
3100 -- After placing the message, Pragma_Exit is raised. Note: this routine
3101 -- calls Fix_Error (see spec of that procedure for details).
3103 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3104 pragma No_Return (Error_Pragma_Arg);
3105 -- Similar to above form of Error_Pragma_Arg except that two messages
3106 -- are provided, the second is a continuation comment starting with \.
3108 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3109 pragma No_Return (Error_Pragma_Arg_Ident);
3110 -- Outputs error message for current pragma. The message may contain a %
3111 -- that will be replaced with the pragma name. The parameter Arg must be
3112 -- a pragma argument association with a non-empty identifier (i.e. its
3113 -- Chars field must be set), and the error message is placed on the
3114 -- identifier. The message is placed using Error_Msg_N so the message
3115 -- may also contain an & insertion character which will reference
3116 -- the identifier. After placing the message, Pragma_Exit is raised.
3117 -- Note: this routine calls Fix_Error (see spec of that procedure for
3120 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3121 pragma No_Return (Error_Pragma_Ref);
3122 -- Outputs error message for current pragma. The message may contain
3123 -- a % that will be replaced with the pragma name. The parameter Ref
3124 -- must be an entity whose name can be referenced by & and sloc by #.
3125 -- After placing the message, Pragma_Exit is raised. Note: this routine
3126 -- calls Fix_Error (see spec of that procedure for details).
3128 function Find_Lib_Unit_Name return Entity_Id;
3129 -- Used for a library unit pragma to find the entity to which the
3130 -- library unit pragma applies, returns the entity found.
3132 procedure Find_Program_Unit_Name (Id : Node_Id);
3133 -- If the pragma is a compilation unit pragma, the id must denote the
3134 -- compilation unit in the same compilation, and the pragma must appear
3135 -- in the list of preceding or trailing pragmas. If it is a program
3136 -- unit pragma that is not a compilation unit pragma, then the
3137 -- identifier must be visible.
3139 function Find_Unique_Parameterless_Procedure
3141 Arg : Node_Id) return Entity_Id;
3142 -- Used for a procedure pragma to find the unique parameterless
3143 -- procedure identified by Name, returns it if it exists, otherwise
3144 -- errors out and uses Arg as the pragma argument for the message.
3146 function Fix_Error (Msg : String) return String;
3147 -- This is called prior to issuing an error message. Msg is the normal
3148 -- error message issued in the pragma case. This routine checks for the
3149 -- case of a pragma coming from an aspect in the source, and returns a
3150 -- message suitable for the aspect case as follows:
3152 -- Each substring "pragma" is replaced by "aspect"
3154 -- If "argument of" is at the start of the error message text, it is
3155 -- replaced by "entity for".
3157 -- If "argument" is at the start of the error message text, it is
3158 -- replaced by "entity".
3160 -- So for example, "argument of pragma X must be discrete type"
3161 -- returns "entity for aspect X must be a discrete type".
3163 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3164 -- be different from the pragma name). If the current pragma results
3165 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3166 -- original pragma name.
3168 procedure Gather_Associations
3170 Args : out Args_List);
3171 -- This procedure is used to gather the arguments for a pragma that
3172 -- permits arbitrary ordering of parameters using the normal rules
3173 -- for named and positional parameters. The Names argument is a list
3174 -- of Name_Id values that corresponds to the allowed pragma argument
3175 -- association identifiers in order. The result returned in Args is
3176 -- a list of corresponding expressions that are the pragma arguments.
3177 -- Note that this is a list of expressions, not of pragma argument
3178 -- associations (Gather_Associations has completely checked all the
3179 -- optional identifiers when it returns). An entry in Args is Empty
3180 -- on return if the corresponding argument is not present.
3182 procedure GNAT_Pragma;
3183 -- Called for all GNAT defined pragmas to check the relevant restriction
3184 -- (No_Implementation_Pragmas).
3186 function Is_Before_First_Decl
3187 (Pragma_Node : Node_Id;
3188 Decls : List_Id) return Boolean;
3189 -- Return True if Pragma_Node is before the first declarative item in
3190 -- Decls where Decls is the list of declarative items.
3192 function Is_Configuration_Pragma return Boolean;
3193 -- Determines if the placement of the current pragma is appropriate
3194 -- for a configuration pragma.
3196 function Is_In_Context_Clause return Boolean;
3197 -- Returns True if pragma appears within the context clause of a unit,
3198 -- and False for any other placement (does not generate any messages).
3200 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3201 -- Analyzes the argument, and determines if it is a static string
3202 -- expression, returns True if so, False if non-static or not String.
3204 procedure Pragma_Misplaced;
3205 pragma No_Return (Pragma_Misplaced);
3206 -- Issue fatal error message for misplaced pragma
3208 procedure Process_Atomic_Shared_Volatile;
3209 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
3210 -- Shared is an obsolete Ada 83 pragma, treated as being identical
3211 -- in effect to pragma Atomic.
3213 procedure Process_Compile_Time_Warning_Or_Error;
3214 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3216 procedure Process_Convention
3217 (C : out Convention_Id;
3218 Ent : out Entity_Id);
3219 -- Common processing for Convention, Interface, Import and Export.
3220 -- Checks first two arguments of pragma, and sets the appropriate
3221 -- convention value in the specified entity or entities. On return
3222 -- C is the convention, Ent is the referenced entity.
3224 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3225 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3226 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3228 procedure Process_Extended_Import_Export_Exception_Pragma
3229 (Arg_Internal : Node_Id;
3230 Arg_External : Node_Id;
3232 Arg_Code : Node_Id);
3233 -- Common processing for the pragmas Import/Export_Exception. The three
3234 -- arguments correspond to the three named parameters of the pragma. An
3235 -- argument is empty if the corresponding parameter is not present in
3238 procedure Process_Extended_Import_Export_Object_Pragma
3239 (Arg_Internal : Node_Id;
3240 Arg_External : Node_Id;
3241 Arg_Size : Node_Id);
3242 -- Common processing for the pragmas Import/Export_Object. The three
3243 -- arguments correspond to the three named parameters of the pragmas. An
3244 -- argument is empty if the corresponding parameter is not present in
3247 procedure Process_Extended_Import_Export_Internal_Arg
3248 (Arg_Internal : Node_Id := Empty);
3249 -- Common processing for all extended Import and Export pragmas. The
3250 -- argument is the pragma parameter for the Internal argument. If
3251 -- Arg_Internal is empty or inappropriate, an error message is posted.
3252 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3253 -- set to identify the referenced entity.
3255 procedure Process_Extended_Import_Export_Subprogram_Pragma
3256 (Arg_Internal : Node_Id;
3257 Arg_External : Node_Id;
3258 Arg_Parameter_Types : Node_Id;
3259 Arg_Result_Type : Node_Id := Empty;
3260 Arg_Mechanism : Node_Id;
3261 Arg_Result_Mechanism : Node_Id := Empty;
3262 Arg_First_Optional_Parameter : Node_Id := Empty);
3263 -- Common processing for all extended Import and Export pragmas applying
3264 -- to subprograms. The caller omits any arguments that do not apply to
3265 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3266 -- only in the Import_Function and Export_Function cases). The argument
3267 -- names correspond to the allowed pragma association identifiers.
3269 procedure Process_Generic_List;
3270 -- Common processing for Share_Generic and Inline_Generic
3272 procedure Process_Import_Or_Interface;
3273 -- Common processing for Import of Interface
3275 procedure Process_Import_Predefined_Type;
3276 -- Processing for completing a type with pragma Import. This is used
3277 -- to declare types that match predefined C types, especially for cases
3278 -- without corresponding Ada predefined type.
3280 type Inline_Status is (Suppressed, Disabled, Enabled);
3281 -- Inline status of a subprogram, indicated as follows:
3282 -- Suppressed: inlining is suppressed for the subprogram
3283 -- Disabled: no inlining is requested for the subprogram
3284 -- Enabled: inlining is requested/required for the subprogram
3286 procedure Process_Inline (Status : Inline_Status);
3287 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3288 -- indicates the inline status specified by the pragma.
3290 procedure Process_Interface_Name
3291 (Subprogram_Def : Entity_Id;
3293 Link_Arg : Node_Id);
3294 -- Given the last two arguments of pragma Import, pragma Export, or
3295 -- pragma Interface_Name, performs validity checks and sets the
3296 -- Interface_Name field of the given subprogram entity to the
3297 -- appropriate external or link name, depending on the arguments given.
3298 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3299 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3300 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3301 -- nor Link_Arg is present, the interface name is set to the default
3302 -- from the subprogram name.
3304 procedure Process_Interrupt_Or_Attach_Handler;
3305 -- Common processing for Interrupt and Attach_Handler pragmas
3307 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3308 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3309 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3310 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3311 -- is not set in the Restrictions case.
3313 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3314 -- Common processing for Suppress and Unsuppress. The boolean parameter
3315 -- Suppress_Case is True for the Suppress case, and False for the
3318 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3319 -- This procedure sets the Is_Exported flag for the given entity,
3320 -- checking that the entity was not previously imported. Arg is
3321 -- the argument that specified the entity. A check is also made
3322 -- for exporting inappropriate entities.
3324 procedure Set_Extended_Import_Export_External_Name
3325 (Internal_Ent : Entity_Id;
3326 Arg_External : Node_Id);
3327 -- Common processing for all extended import export pragmas. The first
3328 -- argument, Internal_Ent, is the internal entity, which has already
3329 -- been checked for validity by the caller. Arg_External is from the
3330 -- Import or Export pragma, and may be null if no External parameter
3331 -- was present. If Arg_External is present and is a non-null string
3332 -- (a null string is treated as the default), then the Interface_Name
3333 -- field of Internal_Ent is set appropriately.
3335 procedure Set_Imported (E : Entity_Id);
3336 -- This procedure sets the Is_Imported flag for the given entity,
3337 -- checking that it is not previously exported or imported.
3339 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3340 -- Mech is a parameter passing mechanism (see Import_Function syntax
3341 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3342 -- has the right form, and if not issues an error message. If the
3343 -- argument has the right form then the Mechanism field of Ent is
3344 -- set appropriately.
3346 procedure Set_Rational_Profile;
3347 -- Activate the set of configuration pragmas and permissions that make
3348 -- up the Rational profile.
3350 procedure Set_Ravenscar_Profile (N : Node_Id);
3351 -- Activate the set of configuration pragmas and restrictions that make
3352 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3353 -- is used for error messages on any constructs violating the profile.
3355 ----------------------------------
3356 -- Acquire_Warning_Match_String --
3357 ----------------------------------
3359 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3361 String_To_Name_Buffer
3362 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3364 -- Add asterisk at start if not already there
3366 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3367 Name_Buffer (2 .. Name_Len + 1) :=
3368 Name_Buffer (1 .. Name_Len);
3369 Name_Buffer (1) := '*';
3370 Name_Len := Name_Len + 1;
3373 -- Add asterisk at end if not already there
3375 if Name_Buffer (Name_Len) /= '*' then
3376 Name_Len := Name_Len + 1;
3377 Name_Buffer (Name_Len) := '*';
3379 end Acquire_Warning_Match_String;
3381 ---------------------
3382 -- Ada_2005_Pragma --
3383 ---------------------
3385 procedure Ada_2005_Pragma is
3387 if Ada_Version <= Ada_95 then
3388 Check_Restriction (No_Implementation_Pragmas, N);
3390 end Ada_2005_Pragma;
3392 ---------------------
3393 -- Ada_2012_Pragma --
3394 ---------------------
3396 procedure Ada_2012_Pragma is
3398 if Ada_Version <= Ada_2005 then
3399 Check_Restriction (No_Implementation_Pragmas, N);
3401 end Ada_2012_Pragma;
3403 ---------------------
3404 -- Analyze_Part_Of --
3405 ---------------------
3407 procedure Analyze_Part_Of
3408 (Item_Id : Entity_Id;
3411 Legal : out Boolean)
3413 Pack_Id : Entity_Id;
3414 Placement : State_Space_Kind;
3415 Parent_Unit : Entity_Id;
3416 State_Id : Entity_Id;
3419 -- Assume that the pragma/option is illegal
3423 if Nkind_In (State, N_Expanded_Name,
3425 N_Selected_Component)
3428 Resolve_State (State);
3430 if Is_Entity_Name (State)
3431 and then Ekind (Entity (State)) = E_Abstract_State
3433 State_Id := Entity (State);
3437 ("indicator Part_Of must denote an abstract state", State);
3441 -- This is a syntax error, always report
3445 ("indicator Part_Of must denote an abstract state", State);
3449 -- Determine where the state, variable or the package instantiation
3450 -- lives with respect to the enclosing packages or package bodies (if
3451 -- any). This placement dictates the legality of the encapsulating
3454 Find_Placement_In_State_Space
3455 (Item_Id => Item_Id,
3456 Placement => Placement,
3457 Pack_Id => Pack_Id);
3459 -- The item appears in a non-package construct with a declarative
3460 -- part (subprogram, block, etc). As such, the item is not allowed
3461 -- to be a part of an encapsulating state because the item is not
3464 if Placement = Not_In_Package then
3466 ("indicator Part_Of cannot appear in this context "
3467 & "(SPARK RM 7.2.6(5))", Indic);
3468 Error_Msg_Name_1 := Chars (Scope (State_Id));
3470 ("\& is not part of the hidden state of package %",
3473 -- The item appears in the visible state space of some package. In
3474 -- general this scenario does not warrant Part_Of except when the
3475 -- package is a private child unit and the encapsulating state is
3476 -- declared in a parent unit or a public descendant of that parent
3479 elsif Placement = Visible_State_Space then
3480 if Is_Child_Unit (Pack_Id)
3481 and then Is_Private_Descendant (Pack_Id)
3483 -- A variable or state abstraction which is part of the
3484 -- visible state of a private child unit (or a public
3485 -- descendant thereof) shall have its Part_Of indicator
3486 -- specified; the Part_Of indicator shall denote a state
3487 -- abstraction declared by either the parent unit of the
3488 -- private unit or by a public descendant of that parent unit.
3490 -- Find nearest nearest private ancestor (which can be the
3491 -- current unit itself).
3493 Parent_Unit := Pack_Id;
3494 while Present (Parent_Unit) loop
3495 exit when Private_Present
3496 (Parent (Unit_Declaration_Node (Parent_Unit)));
3497 Parent_Unit := Scope (Parent_Unit);
3500 Parent_Unit := Scope (Parent_Unit);
3502 if not Is_Child_Or_Sibling (Pack_Id, Scope (State_Id)) then
3504 ("indicator Part_Of must denote an abstract state of& "
3505 & "or public descendant (SPARK RM 7.2.6(3))",
3506 Indic, Parent_Unit);
3508 elsif Scope (State_Id) = Parent_Unit
3509 or else (Is_Ancestor_Package (Parent_Unit, Scope (State_Id))
3511 not Is_Private_Descendant (Scope (State_Id)))
3517 ("indicator Part_Of must denote an abstract state of& "
3518 & "or public descendant (SPARK RM 7.2.6(3))",
3519 Indic, Parent_Unit);
3522 -- Indicator Part_Of is not needed when the related package is not
3523 -- a private child unit or a public descendant thereof.
3527 ("indicator Part_Of cannot appear in this context "
3528 & "(SPARK RM 7.2.6(5))", Indic);
3529 Error_Msg_Name_1 := Chars (Pack_Id);
3531 ("\& is declared in the visible part of package %",
3535 -- When the item appears in the private state space of a package, the
3536 -- encapsulating state must be declared in the same package.
3538 elsif Placement = Private_State_Space then
3539 if Scope (State_Id) /= Pack_Id then
3541 ("indicator Part_Of must designate an abstract state of "
3542 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3543 Error_Msg_Name_1 := Chars (Pack_Id);
3545 ("\& is declared in the private part of package %",
3549 -- Items declared in the body state space of a package do not need
3550 -- Part_Of indicators as the refinement has already been seen.
3554 ("indicator Part_Of cannot appear in this context "
3555 & "(SPARK RM 7.2.6(5))", Indic);
3557 if Scope (State_Id) = Pack_Id then
3558 Error_Msg_Name_1 := Chars (Pack_Id);
3560 ("\& is declared in the body of package %", Indic, Item_Id);
3565 end Analyze_Part_Of;
3567 ----------------------------
3568 -- Analyze_Refined_Pragma --
3569 ----------------------------
3571 procedure Analyze_Refined_Pragma
3572 (Spec_Id : out Entity_Id;
3573 Body_Id : out Entity_Id;
3574 Legal : out Boolean)
3576 Body_Decl : Node_Id;
3577 Spec_Decl : Node_Id;
3580 -- Assume that the pragma is illegal
3587 Check_Arg_Count (1);
3588 Check_No_Identifiers;
3590 if Nam_In (Pname, Name_Refined_Depends,
3591 Name_Refined_Global,
3594 Ensure_Aggregate_Form (Arg1);
3597 -- Verify the placement of the pragma and check for duplicates. The
3598 -- pragma must apply to a subprogram body [stub].
3600 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
3602 -- Extract the entities of the spec and body
3604 if Nkind (Body_Decl) = N_Subprogram_Body then
3605 Body_Id := Defining_Entity (Body_Decl);
3606 Spec_Id := Corresponding_Spec (Body_Decl);
3608 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
3609 Body_Id := Defining_Entity (Body_Decl);
3610 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
3617 -- The pragma must apply to the second declaration of a subprogram.
3618 -- In other words, the body [stub] cannot acts as a spec.
3620 if No (Spec_Id) then
3621 Error_Pragma ("pragma % cannot apply to a stand alone body");
3624 -- Catch the case where the subprogram body is a subunit and acts as
3625 -- the third declaration of the subprogram.
3627 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
3628 Error_Pragma ("pragma % cannot apply to a subunit");
3632 -- The pragma can only apply to the body [stub] of a subprogram
3633 -- declared in the visible part of a package. Retrieve the context of
3634 -- the subprogram declaration.
3636 Spec_Decl := Parent (Parent (Spec_Id));
3638 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
3640 ("pragma % must apply to the body of a subprogram declared in a "
3641 & "package specification");
3645 -- If we get here, then the pragma is legal
3648 end Analyze_Refined_Pragma;
3650 --------------------------
3651 -- Check_Ada_83_Warning --
3652 --------------------------
3654 procedure Check_Ada_83_Warning is
3656 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3657 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
3659 end Check_Ada_83_Warning;
3661 ---------------------
3662 -- Check_Arg_Count --
3663 ---------------------
3665 procedure Check_Arg_Count (Required : Nat) is
3667 if Arg_Count /= Required then
3668 Error_Pragma ("wrong number of arguments for pragma%");
3670 end Check_Arg_Count;
3672 --------------------------------
3673 -- Check_Arg_Is_External_Name --
3674 --------------------------------
3676 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
3677 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3680 if Nkind (Argx) = N_Identifier then
3684 Analyze_And_Resolve (Argx, Standard_String);
3686 if Is_OK_Static_Expression (Argx) then
3689 elsif Etype (Argx) = Any_Type then
3692 -- An interesting special case, if we have a string literal and
3693 -- we are in Ada 83 mode, then we allow it even though it will
3694 -- not be flagged as static. This allows expected Ada 83 mode
3695 -- use of external names which are string literals, even though
3696 -- technically these are not static in Ada 83.
3698 elsif Ada_Version = Ada_83
3699 and then Nkind (Argx) = N_String_Literal
3703 -- Static expression that raises Constraint_Error. This has
3704 -- already been flagged, so just exit from pragma processing.
3706 elsif Is_OK_Static_Expression (Argx) then
3709 -- Here we have a real error (non-static expression)
3712 Error_Msg_Name_1 := Pname;
3715 Msg : constant String :=
3716 "argument for pragma% must be a identifier or "
3717 & "static string expression!";
3719 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
3724 end Check_Arg_Is_External_Name;
3726 -----------------------------
3727 -- Check_Arg_Is_Identifier --
3728 -----------------------------
3730 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
3731 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3733 if Nkind (Argx) /= N_Identifier then
3735 ("argument for pragma% must be identifier", Argx);
3737 end Check_Arg_Is_Identifier;
3739 ----------------------------------
3740 -- Check_Arg_Is_Integer_Literal --
3741 ----------------------------------
3743 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
3744 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3746 if Nkind (Argx) /= N_Integer_Literal then
3748 ("argument for pragma% must be integer literal", Argx);
3750 end Check_Arg_Is_Integer_Literal;
3752 -------------------------------------------
3753 -- Check_Arg_Is_Library_Level_Local_Name --
3754 -------------------------------------------
3758 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3759 -- | library_unit_NAME
3761 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
3763 Check_Arg_Is_Local_Name (Arg);
3765 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
3766 and then Comes_From_Source (N)
3769 ("argument for pragma% must be library level entity", Arg);
3771 end Check_Arg_Is_Library_Level_Local_Name;
3773 -----------------------------
3774 -- Check_Arg_Is_Local_Name --
3775 -----------------------------
3779 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3780 -- | library_unit_NAME
3782 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
3783 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3788 if Nkind (Argx) not in N_Direct_Name
3789 and then (Nkind (Argx) /= N_Attribute_Reference
3790 or else Present (Expressions (Argx))
3791 or else Nkind (Prefix (Argx)) /= N_Identifier)
3792 and then (not Is_Entity_Name (Argx)
3793 or else not Is_Compilation_Unit (Entity (Argx)))
3795 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
3798 -- No further check required if not an entity name
3800 if not Is_Entity_Name (Argx) then
3806 Ent : constant Entity_Id := Entity (Argx);
3807 Scop : constant Entity_Id := Scope (Ent);
3810 -- Case of a pragma applied to a compilation unit: pragma must
3811 -- occur immediately after the program unit in the compilation.
3813 if Is_Compilation_Unit (Ent) then
3815 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
3818 -- Case of pragma placed immediately after spec
3820 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
3823 -- Case of pragma placed immediately after body
3825 elsif Nkind (Decl) = N_Subprogram_Declaration
3826 and then Present (Corresponding_Body (Decl))
3830 (Parent (Unit_Declaration_Node
3831 (Corresponding_Body (Decl))));
3833 -- All other cases are illegal
3840 -- Special restricted placement rule from 10.2.1(11.8/2)
3842 elsif Is_Generic_Formal (Ent)
3843 and then Prag_Id = Pragma_Preelaborable_Initialization
3845 OK := List_Containing (N) =
3846 Generic_Formal_Declarations
3847 (Unit_Declaration_Node (Scop));
3849 -- If this is an aspect applied to a subprogram body, the
3850 -- pragma is inserted in its declarative part.
3852 elsif From_Aspect_Specification (N)
3854 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
3855 and then Ent = Current_Scope
3859 -- If the aspect is a predicate (possibly others ???) and the
3860 -- context is a record type, this is a discriminant expression
3861 -- within a type declaration, that freezes the predicated
3864 elsif From_Aspect_Specification (N)
3865 and then Prag_Id = Pragma_Predicate
3866 and then Ekind (Current_Scope) = E_Record_Type
3867 and then Scop = Scope (Current_Scope)
3871 -- Default case, just check that the pragma occurs in the scope
3872 -- of the entity denoted by the name.
3875 OK := Current_Scope = Scop;
3880 ("pragma% argument must be in same declarative part", Arg);
3884 end Check_Arg_Is_Local_Name;
3886 ---------------------------------
3887 -- Check_Arg_Is_Locking_Policy --
3888 ---------------------------------
3890 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
3891 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3894 Check_Arg_Is_Identifier (Argx);
3896 if not Is_Locking_Policy_Name (Chars (Argx)) then
3897 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
3899 end Check_Arg_Is_Locking_Policy;
3901 -----------------------------------------------
3902 -- Check_Arg_Is_Partition_Elaboration_Policy --
3903 -----------------------------------------------
3905 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
3906 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3909 Check_Arg_Is_Identifier (Argx);
3911 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
3913 ("& is not a valid partition elaboration policy name", Argx);
3915 end Check_Arg_Is_Partition_Elaboration_Policy;
3917 -------------------------
3918 -- Check_Arg_Is_One_Of --
3919 -------------------------
3921 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
3922 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3925 Check_Arg_Is_Identifier (Argx);
3927 if not Nam_In (Chars (Argx), N1, N2) then
3928 Error_Msg_Name_2 := N1;
3929 Error_Msg_Name_3 := N2;
3930 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
3932 end Check_Arg_Is_One_Of;
3934 procedure Check_Arg_Is_One_Of
3936 N1, N2, N3 : Name_Id)
3938 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3941 Check_Arg_Is_Identifier (Argx);
3943 if not Nam_In (Chars (Argx), N1, N2, N3) then
3944 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3946 end Check_Arg_Is_One_Of;
3948 procedure Check_Arg_Is_One_Of
3950 N1, N2, N3, N4 : Name_Id)
3952 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3955 Check_Arg_Is_Identifier (Argx);
3957 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
3958 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3960 end Check_Arg_Is_One_Of;
3962 procedure Check_Arg_Is_One_Of
3964 N1, N2, N3, N4, N5 : Name_Id)
3966 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3969 Check_Arg_Is_Identifier (Argx);
3971 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
3972 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
3974 end Check_Arg_Is_One_Of;
3976 ---------------------------------
3977 -- Check_Arg_Is_Queuing_Policy --
3978 ---------------------------------
3980 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
3981 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
3984 Check_Arg_Is_Identifier (Argx);
3986 if not Is_Queuing_Policy_Name (Chars (Argx)) then
3987 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
3989 end Check_Arg_Is_Queuing_Policy;
3991 ---------------------------------------
3992 -- Check_Arg_Is_OK_Static_Expression --
3993 ---------------------------------------
3995 procedure Check_Arg_Is_OK_Static_Expression
3997 Typ : Entity_Id := Empty)
4000 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4001 end Check_Arg_Is_OK_Static_Expression;
4003 ------------------------------------------
4004 -- Check_Arg_Is_Task_Dispatching_Policy --
4005 ------------------------------------------
4007 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4008 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4011 Check_Arg_Is_Identifier (Argx);
4013 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4015 ("& is not an allowed task dispatching policy name", Argx);
4017 end Check_Arg_Is_Task_Dispatching_Policy;
4019 ---------------------
4020 -- Check_Arg_Order --
4021 ---------------------
4023 procedure Check_Arg_Order (Names : Name_List) is
4026 Highest_So_Far : Natural := 0;
4027 -- Highest index in Names seen do far
4031 for J in 1 .. Arg_Count loop
4032 if Chars (Arg) /= No_Name then
4033 for K in Names'Range loop
4034 if Chars (Arg) = Names (K) then
4035 if K < Highest_So_Far then
4036 Error_Msg_Name_1 := Pname;
4038 ("parameters out of order for pragma%", Arg);
4039 Error_Msg_Name_1 := Names (K);
4040 Error_Msg_Name_2 := Names (Highest_So_Far);
4041 Error_Msg_N ("\% must appear before %", Arg);
4045 Highest_So_Far := K;
4053 end Check_Arg_Order;
4055 --------------------------------
4056 -- Check_At_Least_N_Arguments --
4057 --------------------------------
4059 procedure Check_At_Least_N_Arguments (N : Nat) is
4061 if Arg_Count < N then
4062 Error_Pragma ("too few arguments for pragma%");
4064 end Check_At_Least_N_Arguments;
4066 -------------------------------
4067 -- Check_At_Most_N_Arguments --
4068 -------------------------------
4070 procedure Check_At_Most_N_Arguments (N : Nat) is
4073 if Arg_Count > N then
4075 for J in 1 .. N loop
4077 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4080 end Check_At_Most_N_Arguments;
4082 ---------------------
4083 -- Check_Component --
4084 ---------------------
4086 procedure Check_Component
4089 In_Variant_Part : Boolean := False)
4091 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4092 Sindic : constant Node_Id :=
4093 Subtype_Indication (Component_Definition (Comp));
4094 Typ : constant Entity_Id := Etype (Comp_Id);
4097 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4098 -- object constraint, then the component type shall be an Unchecked_
4101 if Nkind (Sindic) = N_Subtype_Indication
4102 and then Has_Per_Object_Constraint (Comp_Id)
4103 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4106 ("component subtype subject to per-object constraint "
4107 & "must be an Unchecked_Union", Comp);
4109 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4110 -- the body of a generic unit, or within the body of any of its
4111 -- descendant library units, no part of the type of a component
4112 -- declared in a variant_part of the unchecked union type shall be of
4113 -- a formal private type or formal private extension declared within
4114 -- the formal part of the generic unit.
4116 elsif Ada_Version >= Ada_2012
4117 and then In_Generic_Body (UU_Typ)
4118 and then In_Variant_Part
4119 and then Is_Private_Type (Typ)
4120 and then Is_Generic_Type (Typ)
4123 ("component of unchecked union cannot be of generic type", Comp);
4125 elsif Needs_Finalization (Typ) then
4127 ("component of unchecked union cannot be controlled", Comp);
4129 elsif Has_Task (Typ) then
4131 ("component of unchecked union cannot have tasks", Comp);
4133 end Check_Component;
4135 -----------------------------
4136 -- Check_Declaration_Order --
4137 -----------------------------
4139 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is
4140 procedure Check_Aspect_Specification_Order;
4141 -- Inspect the aspect specifications of the context to determine the
4144 --------------------------------------
4145 -- Check_Aspect_Specification_Order --
4146 --------------------------------------
4148 procedure Check_Aspect_Specification_Order is
4149 Asp_First : constant Node_Id := Corresponding_Aspect (First);
4150 Asp_Second : constant Node_Id := Corresponding_Aspect (Second);
4154 -- Both aspects must be part of the same aspect specification list
4157 (List_Containing (Asp_First) = List_Containing (Asp_Second));
4159 -- Try to reach Second starting from First in a left to right
4160 -- traversal of the aspect specifications.
4162 Asp := Next (Asp_First);
4163 while Present (Asp) loop
4165 -- The order is ok, First is followed by Second
4167 if Asp = Asp_Second then
4174 -- If we get here, then the aspects are out of order
4176 SPARK_Msg_N ("aspect % cannot come after aspect %", First);
4177 end Check_Aspect_Specification_Order;
4183 -- Start of processing for Check_Declaration_Order
4186 -- Cannot check the order if one of the pragmas is missing
4188 if No (First) or else No (Second) then
4192 -- Set up the error names in case the order is incorrect
4194 Error_Msg_Name_1 := Pragma_Name (First);
4195 Error_Msg_Name_2 := Pragma_Name (Second);
4197 if From_Aspect_Specification (First) then
4199 -- Both pragmas are actually aspects, check their declaration
4200 -- order in the associated aspect specification list. Otherwise
4201 -- First is an aspect and Second a source pragma.
4203 if From_Aspect_Specification (Second) then
4204 Check_Aspect_Specification_Order;
4207 -- Abstract_States is a source pragma
4210 if From_Aspect_Specification (Second) then
4211 SPARK_Msg_N ("pragma % cannot come after aspect %", First);
4213 -- Both pragmas are source constructs. Try to reach First from
4214 -- Second by traversing the declarations backwards.
4217 Stmt := Prev (Second);
4218 while Present (Stmt) loop
4220 -- The order is ok, First is followed by Second
4222 if Stmt = First then
4229 -- If we get here, then the pragmas are out of order
4231 SPARK_Msg_N ("pragma % cannot come after pragma %", First);
4234 end Check_Declaration_Order;
4236 ----------------------------
4237 -- Check_Duplicate_Pragma --
4238 ----------------------------
4240 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4241 Id : Entity_Id := E;
4245 -- Nothing to do if this pragma comes from an aspect specification,
4246 -- since we could not be duplicating a pragma, and we dealt with the
4247 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4249 if From_Aspect_Specification (N) then
4253 -- Otherwise current pragma may duplicate previous pragma or a
4254 -- previously given aspect specification or attribute definition
4255 -- clause for the same pragma.
4257 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4261 -- If the entity is a type, then we have to make sure that the
4262 -- ostensible duplicate is not for a parent type from which this
4266 if Nkind (P) = N_Pragma then
4268 Args : constant List_Id :=
4269 Pragma_Argument_Associations (P);
4272 and then Is_Entity_Name (Expression (First (Args)))
4273 and then Is_Type (Entity (Expression (First (Args))))
4274 and then Entity (Expression (First (Args))) /= E
4280 elsif Nkind (P) = N_Aspect_Specification
4281 and then Is_Type (Entity (P))
4282 and then Entity (P) /= E
4288 -- Here we have a definite duplicate
4290 Error_Msg_Name_1 := Pragma_Name (N);
4291 Error_Msg_Sloc := Sloc (P);
4293 -- For a single protected or a single task object, the error is
4294 -- issued on the original entity.
4296 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
4297 Id := Defining_Identifier (Original_Node (Parent (Id)));
4300 if Nkind (P) = N_Aspect_Specification
4301 or else From_Aspect_Specification (P)
4303 Error_Msg_NE ("aspect% for & previously given#", N, Id);
4305 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
4310 end Check_Duplicate_Pragma;
4312 ----------------------------------
4313 -- Check_Duplicated_Export_Name --
4314 ----------------------------------
4316 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
4317 String_Val : constant String_Id := Strval (Nam);
4320 -- We are only interested in the export case, and in the case of
4321 -- generics, it is the instance, not the template, that is the
4322 -- problem (the template will generate a warning in any case).
4324 if not Inside_A_Generic
4325 and then (Prag_Id = Pragma_Export
4327 Prag_Id = Pragma_Export_Procedure
4329 Prag_Id = Pragma_Export_Valued_Procedure
4331 Prag_Id = Pragma_Export_Function)
4333 for J in Externals.First .. Externals.Last loop
4334 if String_Equal (String_Val, Strval (Externals.Table (J))) then
4335 Error_Msg_Sloc := Sloc (Externals.Table (J));
4336 Error_Msg_N ("external name duplicates name given#", Nam);
4341 Externals.Append (Nam);
4343 end Check_Duplicated_Export_Name;
4345 ----------------------------------------
4346 -- Check_Expr_Is_OK_Static_Expression --
4347 ----------------------------------------
4349 procedure Check_Expr_Is_OK_Static_Expression
4351 Typ : Entity_Id := Empty)
4354 if Present (Typ) then
4355 Analyze_And_Resolve (Expr, Typ);
4357 Analyze_And_Resolve (Expr);
4360 if Is_OK_Static_Expression (Expr) then
4363 elsif Etype (Expr) = Any_Type then
4366 -- An interesting special case, if we have a string literal and we
4367 -- are in Ada 83 mode, then we allow it even though it will not be
4368 -- flagged as static. This allows the use of Ada 95 pragmas like
4369 -- Import in Ada 83 mode. They will of course be flagged with
4370 -- warnings as usual, but will not cause errors.
4372 elsif Ada_Version = Ada_83
4373 and then Nkind (Expr) = N_String_Literal
4377 -- Static expression that raises Constraint_Error. This has already
4378 -- been flagged, so just exit from pragma processing.
4380 elsif Is_OK_Static_Expression (Expr) then
4383 -- Finally, we have a real error
4386 Error_Msg_Name_1 := Pname;
4387 Flag_Non_Static_Expr
4388 (Fix_Error ("argument for pragma% must be a static expression!"),
4392 end Check_Expr_Is_OK_Static_Expression;
4394 -------------------------
4395 -- Check_First_Subtype --
4396 -------------------------
4398 procedure Check_First_Subtype (Arg : Node_Id) is
4399 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4400 Ent : constant Entity_Id := Entity (Argx);
4403 if Is_First_Subtype (Ent) then
4406 elsif Is_Type (Ent) then
4408 ("pragma% cannot apply to subtype", Argx);
4410 elsif Is_Object (Ent) then
4412 ("pragma% cannot apply to object, requires a type", Argx);
4416 ("pragma% cannot apply to&, requires a type", Argx);
4418 end Check_First_Subtype;
4420 ----------------------
4421 -- Check_Identifier --
4422 ----------------------
4424 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
4427 and then Nkind (Arg) = N_Pragma_Argument_Association
4429 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
4430 Error_Msg_Name_1 := Pname;
4431 Error_Msg_Name_2 := Id;
4432 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4436 end Check_Identifier;
4438 --------------------------------
4439 -- Check_Identifier_Is_One_Of --
4440 --------------------------------
4442 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4445 and then Nkind (Arg) = N_Pragma_Argument_Association
4447 if Chars (Arg) = No_Name then
4448 Error_Msg_Name_1 := Pname;
4449 Error_Msg_N ("pragma% argument expects an identifier", Arg);
4452 elsif Chars (Arg) /= N1
4453 and then Chars (Arg) /= N2
4455 Error_Msg_Name_1 := Pname;
4456 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
4460 end Check_Identifier_Is_One_Of;
4462 ---------------------------
4463 -- Check_In_Main_Program --
4464 ---------------------------
4466 procedure Check_In_Main_Program is
4467 P : constant Node_Id := Parent (N);
4470 -- Must be at in subprogram body
4472 if Nkind (P) /= N_Subprogram_Body then
4473 Error_Pragma ("% pragma allowed only in subprogram");
4475 -- Otherwise warn if obviously not main program
4477 elsif Present (Parameter_Specifications (Specification (P)))
4478 or else not Is_Compilation_Unit (Defining_Entity (P))
4480 Error_Msg_Name_1 := Pname;
4482 ("??pragma% is only effective in main program", N);
4484 end Check_In_Main_Program;
4486 ---------------------------------------
4487 -- Check_Interrupt_Or_Attach_Handler --
4488 ---------------------------------------
4490 procedure Check_Interrupt_Or_Attach_Handler is
4491 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4492 Handler_Proc, Proc_Scope : Entity_Id;
4497 if Prag_Id = Pragma_Interrupt_Handler then
4498 Check_Restriction (No_Dynamic_Attachment, N);
4501 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
4502 Proc_Scope := Scope (Handler_Proc);
4504 -- On AAMP only, a pragma Interrupt_Handler is supported for
4505 -- nonprotected parameterless procedures.
4507 if not AAMP_On_Target
4508 or else Prag_Id = Pragma_Attach_Handler
4510 if Ekind (Proc_Scope) /= E_Protected_Type then
4512 ("argument of pragma% must be protected procedure", Arg1);
4515 -- For pragma case (as opposed to access case), check placement.
4516 -- We don't need to do that for aspects, because we have the
4517 -- check that they aspect applies an appropriate procedure.
4519 if not From_Aspect_Specification (N)
4520 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
4522 Error_Pragma ("pragma% must be in protected definition");
4526 if not Is_Library_Level_Entity (Proc_Scope)
4527 or else (AAMP_On_Target
4528 and then not Is_Library_Level_Entity (Handler_Proc))
4531 ("argument for pragma% must be library level entity", Arg1);
4534 -- AI05-0033: A pragma cannot appear within a generic body, because
4535 -- instance can be in a nested scope. The check that protected type
4536 -- is itself a library-level declaration is done elsewhere.
4538 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4539 -- handle code prior to AI-0033. Analysis tools typically are not
4540 -- interested in this pragma in any case, so no need to worry too
4541 -- much about its placement.
4543 if Inside_A_Generic then
4544 if Ekind (Scope (Current_Scope)) = E_Generic_Package
4545 and then In_Package_Body (Scope (Current_Scope))
4546 and then not Relaxed_RM_Semantics
4548 Error_Pragma ("pragma% cannot be used inside a generic");
4551 end Check_Interrupt_Or_Attach_Handler;
4553 ---------------------------------
4554 -- Check_Loop_Pragma_Placement --
4555 ---------------------------------
4557 procedure Check_Loop_Pragma_Placement is
4558 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
4559 -- Verify whether the current pragma is properly grouped with other
4560 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4561 -- related loop where the pragma appears.
4563 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
4564 -- Determine whether an arbitrary statement Stmt denotes pragma
4565 -- Loop_Invariant or Loop_Variant.
4567 procedure Placement_Error (Constr : Node_Id);
4568 pragma No_Return (Placement_Error);
4569 -- Node Constr denotes the last loop restricted construct before we
4570 -- encountered an illegal relation between enclosing constructs. Emit
4571 -- an error depending on what Constr was.
4573 --------------------------------
4574 -- Check_Loop_Pragma_Grouping --
4575 --------------------------------
4577 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
4578 Stop_Search : exception;
4579 -- This exception is used to terminate the recursive descent of
4580 -- routine Check_Grouping.
4582 procedure Check_Grouping (L : List_Id);
4583 -- Find the first group of pragmas in list L and if successful,
4584 -- ensure that the current pragma is part of that group. The
4585 -- routine raises Stop_Search once such a check is performed to
4586 -- halt the recursive descent.
4588 procedure Grouping_Error (Prag : Node_Id);
4589 pragma No_Return (Grouping_Error);
4590 -- Emit an error concerning the current pragma indicating that it
4591 -- should be placed after pragma Prag.
4593 --------------------
4594 -- Check_Grouping --
4595 --------------------
4597 procedure Check_Grouping (L : List_Id) is
4603 -- Inspect the list of declarations or statements looking for
4604 -- the first grouping of pragmas:
4607 -- pragma Loop_Invariant ...;
4608 -- pragma Loop_Variant ...;
4610 -- pragma Loop_Variant ...; -- current pragma
4612 -- If the current pragma is not in the grouping, then it must
4613 -- either appear in a different declarative or statement list
4614 -- or the construct at (1) is separating the pragma from the
4618 while Present (Stmt) loop
4620 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4621 -- inside a loop or a block housed inside a loop. Inspect
4622 -- the declarations and statements of the block as they may
4623 -- contain the first grouping.
4625 if Nkind (Stmt) = N_Block_Statement then
4626 HSS := Handled_Statement_Sequence (Stmt);
4628 Check_Grouping (Declarations (Stmt));
4630 if Present (HSS) then
4631 Check_Grouping (Statements (HSS));
4634 -- First pragma of the first topmost grouping has been found
4636 elsif Is_Loop_Pragma (Stmt) then
4638 -- The group and the current pragma are not in the same
4639 -- declarative or statement list.
4641 if List_Containing (Stmt) /= List_Containing (N) then
4642 Grouping_Error (Stmt);
4644 -- Try to reach the current pragma from the first pragma
4645 -- of the grouping while skipping other members:
4647 -- pragma Loop_Invariant ...; -- first pragma
4648 -- pragma Loop_Variant ...; -- member
4650 -- pragma Loop_Variant ...; -- current pragma
4653 while Present (Stmt) loop
4655 -- The current pragma is either the first pragma
4656 -- of the group or is a member of the group. Stop
4657 -- the search as the placement is legal.
4662 -- Skip group members, but keep track of the last
4663 -- pragma in the group.
4665 elsif Is_Loop_Pragma (Stmt) then
4668 -- A non-pragma is separating the group from the
4669 -- current pragma, the placement is illegal.
4672 Grouping_Error (Prag);
4678 -- If the traversal did not reach the current pragma,
4679 -- then the list must be malformed.
4681 raise Program_Error;
4689 --------------------
4690 -- Grouping_Error --
4691 --------------------
4693 procedure Grouping_Error (Prag : Node_Id) is
4695 Error_Msg_Sloc := Sloc (Prag);
4696 Error_Pragma ("pragma% must appear next to pragma#");
4699 -- Start of processing for Check_Loop_Pragma_Grouping
4702 -- Inspect the statements of the loop or nested blocks housed
4703 -- within to determine whether the current pragma is part of the
4704 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4706 Check_Grouping (Statements (Loop_Stmt));
4709 when Stop_Search => null;
4710 end Check_Loop_Pragma_Grouping;
4712 --------------------
4713 -- Is_Loop_Pragma --
4714 --------------------
4716 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
4718 -- Inspect the original node as Loop_Invariant and Loop_Variant
4719 -- pragmas are rewritten to null when assertions are disabled.
4721 if Nkind (Original_Node (Stmt)) = N_Pragma then
4723 Nam_In (Pragma_Name (Original_Node (Stmt)),
4724 Name_Loop_Invariant,
4731 ---------------------
4732 -- Placement_Error --
4733 ---------------------
4735 procedure Placement_Error (Constr : Node_Id) is
4736 LA : constant String := " with Loop_Entry";
4739 if Prag_Id = Pragma_Assert then
4740 Error_Msg_String (1 .. LA'Length) := LA;
4741 Error_Msg_Strlen := LA'Length;
4743 Error_Msg_Strlen := 0;
4746 if Nkind (Constr) = N_Pragma then
4748 ("pragma %~ must appear immediately within the statements "
4752 ("block containing pragma %~ must appear immediately within "
4753 & "the statements of a loop", Constr);
4755 end Placement_Error;
4757 -- Local declarations
4762 -- Start of processing for Check_Loop_Pragma_Placement
4765 -- Check that pragma appears immediately within a loop statement,
4766 -- ignoring intervening block statements.
4770 while Present (Stmt) loop
4772 -- The pragma or previous block must appear immediately within the
4773 -- current block's declarative or statement part.
4775 if Nkind (Stmt) = N_Block_Statement then
4776 if (No (Declarations (Stmt))
4777 or else List_Containing (Prev) /= Declarations (Stmt))
4779 List_Containing (Prev) /=
4780 Statements (Handled_Statement_Sequence (Stmt))
4782 Placement_Error (Prev);
4785 -- Keep inspecting the parents because we are now within a
4786 -- chain of nested blocks.
4790 Stmt := Parent (Stmt);
4793 -- The pragma or previous block must appear immediately within the
4794 -- statements of the loop.
4796 elsif Nkind (Stmt) = N_Loop_Statement then
4797 if List_Containing (Prev) /= Statements (Stmt) then
4798 Placement_Error (Prev);
4801 -- Stop the traversal because we reached the innermost loop
4802 -- regardless of whether we encountered an error or not.
4806 -- Ignore a handled statement sequence. Note that this node may
4807 -- be related to a subprogram body in which case we will emit an
4808 -- error on the next iteration of the search.
4810 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
4811 Stmt := Parent (Stmt);
4813 -- Any other statement breaks the chain from the pragma to the
4817 Placement_Error (Prev);
4822 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4823 -- grouped together with other such pragmas.
4825 if Is_Loop_Pragma (N) then
4827 -- The previous check should have located the related loop
4829 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
4830 Check_Loop_Pragma_Grouping (Stmt);
4832 end Check_Loop_Pragma_Placement;
4834 -------------------------------------------
4835 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4836 -------------------------------------------
4838 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
4847 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4850 elsif Nkind_In (P, N_Package_Specification,
4855 -- Note: the following tests seem a little peculiar, because
4856 -- they test for bodies, but if we were in the statement part
4857 -- of the body, we would already have hit the handled statement
4858 -- sequence, so the only way we get here is by being in the
4859 -- declarative part of the body.
4861 elsif Nkind_In (P, N_Subprogram_Body,
4872 Error_Pragma ("pragma% is not in declarative part or package spec");
4873 end Check_Is_In_Decl_Part_Or_Package_Spec;
4875 -------------------------
4876 -- Check_No_Identifier --
4877 -------------------------
4879 procedure Check_No_Identifier (Arg : Node_Id) is
4881 if Nkind (Arg) = N_Pragma_Argument_Association
4882 and then Chars (Arg) /= No_Name
4884 Error_Pragma_Arg_Ident
4885 ("pragma% does not permit identifier& here", Arg);
4887 end Check_No_Identifier;
4889 --------------------------
4890 -- Check_No_Identifiers --
4891 --------------------------
4893 procedure Check_No_Identifiers is
4897 for J in 1 .. Arg_Count loop
4898 Check_No_Identifier (Arg_Node);
4901 end Check_No_Identifiers;
4903 ------------------------
4904 -- Check_No_Link_Name --
4905 ------------------------
4907 procedure Check_No_Link_Name is
4909 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
4913 if Present (Arg4) then
4915 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
4917 end Check_No_Link_Name;
4919 -------------------------------
4920 -- Check_Optional_Identifier --
4921 -------------------------------
4923 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
4926 and then Nkind (Arg) = N_Pragma_Argument_Association
4927 and then Chars (Arg) /= No_Name
4929 if Chars (Arg) /= Id then
4930 Error_Msg_Name_1 := Pname;
4931 Error_Msg_Name_2 := Id;
4932 Error_Msg_N ("pragma% argument expects identifier%", Arg);
4936 end Check_Optional_Identifier;
4938 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
4940 Name_Buffer (1 .. Id'Length) := Id;
4941 Name_Len := Id'Length;
4942 Check_Optional_Identifier (Arg, Name_Find);
4943 end Check_Optional_Identifier;
4945 --------------------
4946 -- Check_Pre_Post --
4947 --------------------
4949 procedure Check_Pre_Post is
4954 if not Is_List_Member (N) then
4958 -- If we are within an inlined body, the legality of the pragma
4959 -- has been checked already.
4961 if In_Inlined_Body then
4965 -- Search prior declarations
4968 while Present (Prev (P)) loop
4971 -- If the previous node is a generic subprogram, do not go to to
4972 -- the original node, which is the unanalyzed tree: we need to
4973 -- attach the pre/postconditions to the analyzed version at this
4974 -- point. They get propagated to the original tree when analyzing
4975 -- the corresponding body.
4977 if Nkind (P) not in N_Generic_Declaration then
4978 PO := Original_Node (P);
4983 -- Skip past prior pragma
4985 if Nkind (PO) = N_Pragma then
4988 -- Skip stuff not coming from source
4990 elsif not Comes_From_Source (PO) then
4992 -- The condition may apply to a subprogram instantiation
4994 if Nkind (PO) = N_Subprogram_Declaration
4995 and then Present (Generic_Parent (Specification (PO)))
4999 elsif Nkind (PO) = N_Subprogram_Declaration
5000 and then In_Instance
5004 -- For all other cases of non source code, do nothing
5010 -- Only remaining possibility is subprogram declaration
5017 -- If we fall through loop, pragma is at start of list, so see if it
5018 -- is at the start of declarations of a subprogram body.
5022 if Nkind (PO) = N_Subprogram_Body
5023 and then List_Containing (N) = Declarations (PO)
5025 -- This is only allowed if there is no separate specification
5027 if Present (Corresponding_Spec (PO)) then
5029 ("pragma% must apply to subprogram specification");
5036 --------------------------------------
5037 -- Check_Precondition_Postcondition --
5038 --------------------------------------
5040 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
5044 procedure Chain_PPC (PO : Node_Id);
5045 -- If PO is an entry or a [generic] subprogram declaration node, then
5046 -- the precondition/postcondition applies to this subprogram and the
5047 -- processing for the pragma is completed. Otherwise the pragma is
5054 procedure Chain_PPC (PO : Node_Id) is
5058 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
5059 if not From_Aspect_Specification (N) then
5061 ("pragma% cannot be applied to abstract subprogram");
5063 elsif Class_Present (N) then
5068 ("aspect % requires ''Class for abstract subprogram");
5071 -- AI05-0230: The same restriction applies to null procedures. For
5072 -- compatibility with earlier uses of the Ada pragma, apply this
5073 -- rule only to aspect specifications.
5075 -- The above discrepency needs documentation. Robert is dubious
5076 -- about whether it is a good idea ???
5078 elsif Nkind (PO) = N_Subprogram_Declaration
5079 and then Nkind (Specification (PO)) = N_Procedure_Specification
5080 and then Null_Present (Specification (PO))
5081 and then From_Aspect_Specification (N)
5082 and then not Class_Present (N)
5085 ("aspect % requires ''Class for null procedure");
5087 -- Pre/postconditions are legal on a subprogram body if it is not
5088 -- a completion of a declaration. They are also legal on a stub
5089 -- with no previous declarations (this is checked when processing
5090 -- the corresponding aspects).
5092 elsif Nkind (PO) = N_Subprogram_Body
5093 and then Acts_As_Spec (PO)
5097 elsif Nkind (PO) = N_Subprogram_Body_Stub then
5100 elsif not Nkind_In (PO, N_Subprogram_Declaration,
5101 N_Expression_Function,
5102 N_Generic_Subprogram_Declaration,
5103 N_Entry_Declaration)
5108 -- Here if we have [generic] subprogram or entry declaration
5110 if Nkind (PO) = N_Entry_Declaration then
5111 S := Defining_Entity (PO);
5113 S := Defining_Unit_Name (Specification (PO));
5115 if Nkind (S) = N_Defining_Program_Unit_Name then
5116 S := Defining_Identifier (S);
5120 -- Note: we do not analyze the pragma at this point. Instead we
5121 -- delay this analysis until the end of the declarative part in
5122 -- which the pragma appears. This implements the required delay
5123 -- in this analysis, allowing forward references. The analysis
5124 -- happens at the end of Analyze_Declarations.
5126 -- Chain spec PPC pragma to list for subprogram
5128 Add_Contract_Item (N, S);
5130 -- Return indicating spec case
5136 -- Start of processing for Check_Precondition_Postcondition
5139 if not Is_List_Member (N) then
5143 -- Preanalyze message argument if present. Visibility in this
5144 -- argument is established at the point of pragma occurrence.
5146 if Arg_Count = 2 then
5147 Check_Optional_Identifier (Arg2, Name_Message);
5148 Preanalyze_Spec_Expression
5149 (Get_Pragma_Arg (Arg2), Standard_String);
5152 -- For a pragma PPC in the extended main source unit, record enabled
5155 if Is_Checked (N) and then not Split_PPC (N) then
5156 Set_SCO_Pragma_Enabled (Loc);
5159 -- If we are within an inlined body, the legality of the pragma
5160 -- has been checked already.
5162 if In_Inlined_Body then
5167 -- Search prior declarations
5170 while Present (Prev (P)) loop
5173 -- If the previous node is a generic subprogram, do not go to to
5174 -- the original node, which is the unanalyzed tree: we need to
5175 -- attach the pre/postconditions to the analyzed version at this
5176 -- point. They get propagated to the original tree when analyzing
5177 -- the corresponding body.
5179 if Nkind (P) not in N_Generic_Declaration then
5180 PO := Original_Node (P);
5185 -- Skip past prior pragma
5187 if Nkind (PO) = N_Pragma then
5190 -- Skip stuff not coming from source
5192 elsif not Comes_From_Source (PO) then
5194 -- The condition may apply to a subprogram instantiation
5196 if Nkind (PO) = N_Subprogram_Declaration
5197 and then Present (Generic_Parent (Specification (PO)))
5202 elsif Nkind (PO) = N_Subprogram_Declaration
5203 and then In_Instance
5208 -- For all other cases of non source code, do nothing
5214 -- Only remaining possibility is subprogram declaration
5222 -- If we fall through loop, pragma is at start of list, so see if it
5223 -- is at the start of declarations of a subprogram body.
5227 if Nkind (PO) = N_Subprogram_Body
5228 and then List_Containing (N) = Declarations (PO)
5230 if Operating_Mode /= Generate_Code or else Inside_A_Generic then
5232 -- Analyze pragma expression for correctness and for ASIS use
5234 Preanalyze_Assert_Expression
5235 (Get_Pragma_Arg (Arg1), Standard_Boolean);
5237 -- In ASIS mode, for a pragma generated from a source aspect,
5238 -- also analyze the original aspect expression.
5240 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
5241 Preanalyze_Assert_Expression
5242 (Expression (Corresponding_Aspect (N)), Standard_Boolean);
5246 -- Retain copy of the pre/postcondition pragma in GNATprove mode.
5247 -- The copy is needed because the pragma is expanded into other
5248 -- constructs which are not acceptable in the N_Contract node.
5250 if Acts_As_Spec (PO) and then GNATprove_Mode then
5252 Prag : constant Node_Id := New_Copy_Tree (N);
5255 -- Preanalyze the pragma
5257 Preanalyze_Assert_Expression
5259 (First (Pragma_Argument_Associations (Prag))),
5262 -- Preanalyze the corresponding aspect (if any)
5264 if Present (Corresponding_Aspect (Prag)) then
5265 Preanalyze_Assert_Expression
5266 (Expression (Corresponding_Aspect (Prag)),
5270 -- Chain the copy on the contract of the body
5273 (Prag, Defining_Unit_Name (Specification (PO)));
5280 -- See if it is in the pragmas after a library level subprogram
5282 elsif Nkind (PO) = N_Compilation_Unit_Aux then
5284 -- In GNATprove mode, analyze pragma expression for correctness,
5285 -- as it is not expanded later. Ditto in ASIS_Mode where there is
5286 -- no later point at which the aspect will be analyzed.
5288 if GNATprove_Mode or ASIS_Mode then
5289 Analyze_Pre_Post_Condition_In_Decl_Part
5290 (N, Defining_Entity (Unit (Parent (PO))));
5293 Chain_PPC (Unit (Parent (PO)));
5297 -- If we fall through, pragma was misplaced
5300 end Check_Precondition_Postcondition;
5302 -----------------------------
5303 -- Check_Static_Constraint --
5304 -----------------------------
5306 -- Note: for convenience in writing this procedure, in addition to
5307 -- the officially (i.e. by spec) allowed argument which is always a
5308 -- constraint, it also allows ranges and discriminant associations.
5309 -- Above is not clear ???
5311 procedure Check_Static_Constraint (Constr : Node_Id) is
5313 procedure Require_Static (E : Node_Id);
5314 -- Require given expression to be static expression
5316 --------------------
5317 -- Require_Static --
5318 --------------------
5320 procedure Require_Static (E : Node_Id) is
5322 if not Is_OK_Static_Expression (E) then
5323 Flag_Non_Static_Expr
5324 ("non-static constraint not allowed in Unchecked_Union!", E);
5329 -- Start of processing for Check_Static_Constraint
5332 case Nkind (Constr) is
5333 when N_Discriminant_Association =>
5334 Require_Static (Expression (Constr));
5337 Require_Static (Low_Bound (Constr));
5338 Require_Static (High_Bound (Constr));
5340 when N_Attribute_Reference =>
5341 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5342 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5344 when N_Range_Constraint =>
5345 Check_Static_Constraint (Range_Expression (Constr));
5347 when N_Index_Or_Discriminant_Constraint =>
5351 IDC := First (Constraints (Constr));
5352 while Present (IDC) loop
5353 Check_Static_Constraint (IDC);
5361 end Check_Static_Constraint;
5363 ---------------------
5364 -- Check_Test_Case --
5365 ---------------------
5367 procedure Check_Test_Case is
5371 procedure Chain_CTC (PO : Node_Id);
5372 -- If PO is a [generic] subprogram declaration node, then the
5373 -- test-case applies to this subprogram and the processing for
5374 -- the pragma is completed. Otherwise the pragma is misplaced.
5380 procedure Chain_CTC (PO : Node_Id) is
5384 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
5386 ("pragma% cannot be applied to abstract subprogram");
5388 elsif Nkind (PO) = N_Entry_Declaration then
5389 Error_Pragma ("pragma% cannot be applied to entry");
5391 elsif not Nkind_In (PO, N_Subprogram_Declaration,
5392 N_Generic_Subprogram_Declaration)
5397 -- Here if we have [generic] subprogram declaration
5399 S := Defining_Unit_Name (Specification (PO));
5401 -- Note: we do not analyze the pragma at this point. Instead we
5402 -- delay this analysis until the end of the declarative part in
5403 -- which the pragma appears. This implements the required delay
5404 -- in this analysis, allowing forward references. The analysis
5405 -- happens at the end of Analyze_Declarations.
5407 -- There should not be another test-case with the same name
5408 -- associated to this subprogram.
5411 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
5415 CTC := Contract_Test_Cases (Contract (S));
5416 while Present (CTC) loop
5418 -- Omit pragma Contract_Cases because it does not introduce
5419 -- a unique case name and it does not follow the syntax of
5422 if Pragma_Name (CTC) = Name_Contract_Cases then
5426 (Name, Get_Name_From_CTC_Pragma (CTC))
5428 Error_Msg_Sloc := Sloc (CTC);
5429 Error_Pragma ("name for pragma% is already used#");
5432 CTC := Next_Pragma (CTC);
5436 -- Chain spec CTC pragma to list for subprogram
5438 Add_Contract_Item (N, S);
5441 -- Start of processing for Check_Test_Case
5444 -- First check pragma arguments
5446 Check_At_Least_N_Arguments (2);
5447 Check_At_Most_N_Arguments (4);
5449 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
5451 Check_Optional_Identifier (Arg1, Name_Name);
5452 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
5454 -- In ASIS mode, for a pragma generated from a source aspect, also
5455 -- analyze the original aspect expression.
5457 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
5458 Check_Expr_Is_OK_Static_Expression
5459 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
5462 Check_Optional_Identifier (Arg2, Name_Mode);
5463 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
5465 if Arg_Count = 4 then
5466 Check_Identifier (Arg3, Name_Requires);
5467 Check_Identifier (Arg4, Name_Ensures);
5469 elsif Arg_Count = 3 then
5470 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
5473 -- Check pragma placement
5475 if not Is_List_Member (N) then
5479 -- Test-case should only appear in package spec unit
5481 if Get_Source_Unit (N) = No_Unit
5482 or else not Nkind_In (Sinfo.Unit (Cunit (Current_Sem_Unit)),
5483 N_Package_Declaration,
5484 N_Generic_Package_Declaration)
5489 -- Search prior declarations
5492 while Present (Prev (P)) loop
5495 -- If the previous node is a generic subprogram, do not go to to
5496 -- the original node, which is the unanalyzed tree: we need to
5497 -- attach the test-case to the analyzed version at this point.
5498 -- They get propagated to the original tree when analyzing the
5499 -- corresponding body.
5501 if Nkind (P) not in N_Generic_Declaration then
5502 PO := Original_Node (P);
5507 -- Skip past prior pragma
5509 if Nkind (PO) = N_Pragma then
5512 -- Skip stuff not coming from source
5514 elsif not Comes_From_Source (PO) then
5517 -- Only remaining possibility is subprogram declaration. First
5518 -- check that it is declared directly in a package declaration.
5519 -- This may be either the package declaration for the current unit
5520 -- being defined or a local package declaration.
5522 elsif not Present (Parent (Parent (PO)))
5523 or else not Present (Parent (Parent (Parent (PO))))
5524 or else not Nkind_In (Parent (Parent (PO)),
5525 N_Package_Declaration,
5526 N_Generic_Package_Declaration)
5536 -- If we fall through, pragma was misplaced
5539 end Check_Test_Case;
5541 --------------------------------------
5542 -- Check_Valid_Configuration_Pragma --
5543 --------------------------------------
5545 -- A configuration pragma must appear in the context clause of a
5546 -- compilation unit, and only other pragmas may precede it. Note that
5547 -- the test also allows use in a configuration pragma file.
5549 procedure Check_Valid_Configuration_Pragma is
5551 if not Is_Configuration_Pragma then
5552 Error_Pragma ("incorrect placement for configuration pragma%");
5554 end Check_Valid_Configuration_Pragma;
5556 -------------------------------------
5557 -- Check_Valid_Library_Unit_Pragma --
5558 -------------------------------------
5560 procedure Check_Valid_Library_Unit_Pragma is
5562 Parent_Node : Node_Id;
5563 Unit_Name : Entity_Id;
5564 Unit_Kind : Node_Kind;
5565 Unit_Node : Node_Id;
5566 Sindex : Source_File_Index;
5569 if not Is_List_Member (N) then
5573 Plist := List_Containing (N);
5574 Parent_Node := Parent (Plist);
5576 if Parent_Node = Empty then
5579 -- Case of pragma appearing after a compilation unit. In this case
5580 -- it must have an argument with the corresponding name and must
5581 -- be part of the following pragmas of its parent.
5583 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5584 if Plist /= Pragmas_After (Parent_Node) then
5587 elsif Arg_Count = 0 then
5589 ("argument required if outside compilation unit");
5592 Check_No_Identifiers;
5593 Check_Arg_Count (1);
5594 Unit_Node := Unit (Parent (Parent_Node));
5595 Unit_Kind := Nkind (Unit_Node);
5597 Analyze (Get_Pragma_Arg (Arg1));
5599 if Unit_Kind = N_Generic_Subprogram_Declaration
5600 or else Unit_Kind = N_Subprogram_Declaration
5602 Unit_Name := Defining_Entity (Unit_Node);
5604 elsif Unit_Kind in N_Generic_Instantiation then
5605 Unit_Name := Defining_Entity (Unit_Node);
5608 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5611 if Chars (Unit_Name) /=
5612 Chars (Entity (Get_Pragma_Arg (Arg1)))
5615 ("pragma% argument is not current unit name", Arg1);
5618 if Ekind (Unit_Name) = E_Package
5619 and then Present (Renamed_Entity (Unit_Name))
5621 Error_Pragma ("pragma% not allowed for renamed package");
5625 -- Pragma appears other than after a compilation unit
5628 -- Here we check for the generic instantiation case and also
5629 -- for the case of processing a generic formal package. We
5630 -- detect these cases by noting that the Sloc on the node
5631 -- does not belong to the current compilation unit.
5633 Sindex := Source_Index (Current_Sem_Unit);
5635 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5636 Rewrite (N, Make_Null_Statement (Loc));
5639 -- If before first declaration, the pragma applies to the
5640 -- enclosing unit, and the name if present must be this name.
5642 elsif Is_Before_First_Decl (N, Plist) then
5643 Unit_Node := Unit_Declaration_Node (Current_Scope);
5644 Unit_Kind := Nkind (Unit_Node);
5646 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5649 elsif Unit_Kind = N_Subprogram_Body
5650 and then not Acts_As_Spec (Unit_Node)
5654 elsif Nkind (Parent_Node) = N_Package_Body then
5657 elsif Nkind (Parent_Node) = N_Package_Specification
5658 and then Plist = Private_Declarations (Parent_Node)
5662 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5663 or else Nkind (Parent_Node) =
5664 N_Generic_Subprogram_Declaration)
5665 and then Plist = Generic_Formal_Declarations (Parent_Node)
5669 elsif Arg_Count > 0 then
5670 Analyze (Get_Pragma_Arg (Arg1));
5672 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5674 ("name in pragma% must be enclosing unit", Arg1);
5677 -- It is legal to have no argument in this context
5683 -- Error if not before first declaration. This is because a
5684 -- library unit pragma argument must be the name of a library
5685 -- unit (RM 10.1.5(7)), but the only names permitted in this
5686 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5687 -- generic subprogram declarations or generic instantiations.
5691 ("pragma% misplaced, must be before first declaration");
5695 end Check_Valid_Library_Unit_Pragma;
5701 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5702 Clist : constant Node_Id := Component_List (Variant);
5706 Comp := First (Component_Items (Clist));
5707 while Present (Comp) loop
5708 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5713 ---------------------------
5714 -- Ensure_Aggregate_Form --
5715 ---------------------------
5717 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5718 Expr : constant Node_Id := Get_Pragma_Arg (Arg);
5719 Loc : constant Source_Ptr := Sloc (Arg);
5720 Nam : constant Name_Id := Chars (Arg);
5721 Comps : List_Id := No_List;
5722 Exprs : List_Id := No_List;
5725 -- The argument is already in aggregate form, but the presence of a
5726 -- name causes this to be interpreted as a named association which in
5727 -- turn must be converted into an aggregate.
5729 -- pragma Global (In_Out => (A, B, C))
5733 -- pragma Global ((In_Out => (A, B, C)))
5735 -- aggregate aggregate
5737 if Nkind (Expr) = N_Aggregate then
5738 if Nam = No_Name then
5742 -- Do not transform a null argument into an aggregate as N_Null has
5743 -- special meaning in formal verification pragmas.
5745 elsif Nkind (Expr) = N_Null then
5749 -- Positional argument is transformed into an aggregate with an
5750 -- Expressions list.
5752 if Nam = No_Name then
5753 Exprs := New_List (Relocate_Node (Expr));
5755 -- An associative argument is transformed into an aggregate with
5756 -- Component_Associations.
5760 Make_Component_Association (Loc,
5761 Choices => New_List (Make_Identifier (Loc, Chars (Arg))),
5762 Expression => Relocate_Node (Expr)));
5766 -- Remove the pragma argument name as this information has been
5767 -- captured in the aggregate.
5769 Set_Chars (Arg, No_Name);
5771 Set_Expression (Arg,
5772 Make_Aggregate (Loc,
5773 Component_Associations => Comps,
5774 Expressions => Exprs));
5775 end Ensure_Aggregate_Form;
5781 procedure Error_Pragma (Msg : String) is
5783 Error_Msg_Name_1 := Pname;
5784 Error_Msg_N (Fix_Error (Msg), N);
5788 ----------------------
5789 -- Error_Pragma_Arg --
5790 ----------------------
5792 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5794 Error_Msg_Name_1 := Pname;
5795 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5797 end Error_Pragma_Arg;
5799 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
5801 Error_Msg_Name_1 := Pname;
5802 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
5803 Error_Pragma_Arg (Msg2, Arg);
5804 end Error_Pragma_Arg;
5806 ----------------------------
5807 -- Error_Pragma_Arg_Ident --
5808 ----------------------------
5810 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
5812 Error_Msg_Name_1 := Pname;
5813 Error_Msg_N (Fix_Error (Msg), Arg);
5815 end Error_Pragma_Arg_Ident;
5817 ----------------------
5818 -- Error_Pragma_Ref --
5819 ----------------------
5821 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
5823 Error_Msg_Name_1 := Pname;
5824 Error_Msg_Sloc := Sloc (Ref);
5825 Error_Msg_NE (Fix_Error (Msg), N, Ref);
5827 end Error_Pragma_Ref;
5829 ------------------------
5830 -- Find_Lib_Unit_Name --
5831 ------------------------
5833 function Find_Lib_Unit_Name return Entity_Id is
5835 -- Return inner compilation unit entity, for case of nested
5836 -- categorization pragmas. This happens in generic unit.
5838 if Nkind (Parent (N)) = N_Package_Specification
5839 and then Defining_Entity (Parent (N)) /= Current_Scope
5841 return Defining_Entity (Parent (N));
5843 return Current_Scope;
5845 end Find_Lib_Unit_Name;
5847 ----------------------------
5848 -- Find_Program_Unit_Name --
5849 ----------------------------
5851 procedure Find_Program_Unit_Name (Id : Node_Id) is
5852 Unit_Name : Entity_Id;
5853 Unit_Kind : Node_Kind;
5854 P : constant Node_Id := Parent (N);
5857 if Nkind (P) = N_Compilation_Unit then
5858 Unit_Kind := Nkind (Unit (P));
5860 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
5861 N_Package_Declaration)
5862 or else Unit_Kind in N_Generic_Declaration
5864 Unit_Name := Defining_Entity (Unit (P));
5866 if Chars (Id) = Chars (Unit_Name) then
5867 Set_Entity (Id, Unit_Name);
5868 Set_Etype (Id, Etype (Unit_Name));
5870 Set_Etype (Id, Any_Type);
5872 ("cannot find program unit referenced by pragma%");
5876 Set_Etype (Id, Any_Type);
5877 Error_Pragma ("pragma% inapplicable to this unit");
5883 end Find_Program_Unit_Name;
5885 -----------------------------------------
5886 -- Find_Unique_Parameterless_Procedure --
5887 -----------------------------------------
5889 function Find_Unique_Parameterless_Procedure
5891 Arg : Node_Id) return Entity_Id
5893 Proc : Entity_Id := Empty;
5896 -- The body of this procedure needs some comments ???
5898 if not Is_Entity_Name (Name) then
5900 ("argument of pragma% must be entity name", Arg);
5902 elsif not Is_Overloaded (Name) then
5903 Proc := Entity (Name);
5905 if Ekind (Proc) /= E_Procedure
5906 or else Present (First_Formal (Proc))
5909 ("argument of pragma% must be parameterless procedure", Arg);
5914 Found : Boolean := False;
5916 Index : Interp_Index;
5919 Get_First_Interp (Name, Index, It);
5920 while Present (It.Nam) loop
5923 if Ekind (Proc) = E_Procedure
5924 and then No (First_Formal (Proc))
5928 Set_Entity (Name, Proc);
5929 Set_Is_Overloaded (Name, False);
5932 ("ambiguous handler name for pragma% ", Arg);
5936 Get_Next_Interp (Index, It);
5941 ("argument of pragma% must be parameterless procedure",
5944 Proc := Entity (Name);
5950 end Find_Unique_Parameterless_Procedure;
5956 function Fix_Error (Msg : String) return String is
5957 Res : String (Msg'Range) := Msg;
5958 Res_Last : Natural := Msg'Last;
5962 -- If we have a rewriting of another pragma, go to that pragma
5964 if Is_Rewrite_Substitution (N)
5965 and then Nkind (Original_Node (N)) = N_Pragma
5967 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
5970 -- Case where pragma comes from an aspect specification
5972 if From_Aspect_Specification (N) then
5974 -- Change appearence of "pragma" in message to "aspect"
5977 while J <= Res_Last - 5 loop
5978 if Res (J .. J + 5) = "pragma" then
5979 Res (J .. J + 5) := "aspect";
5987 -- Change "argument of" at start of message to "entity for"
5990 and then Res (Res'First .. Res'First + 10) = "argument of"
5992 Res (Res'First .. Res'First + 9) := "entity for";
5993 Res (Res'First + 10 .. Res_Last - 1) :=
5994 Res (Res'First + 11 .. Res_Last);
5995 Res_Last := Res_Last - 1;
5998 -- Change "argument" at start of message to "entity"
6001 and then Res (Res'First .. Res'First + 7) = "argument"
6003 Res (Res'First .. Res'First + 5) := "entity";
6004 Res (Res'First + 6 .. Res_Last - 2) :=
6005 Res (Res'First + 8 .. Res_Last);
6006 Res_Last := Res_Last - 2;
6009 -- Get name from corresponding aspect
6011 Error_Msg_Name_1 := Original_Aspect_Name (N);
6014 -- Return possibly modified message
6016 return Res (Res'First .. Res_Last);
6019 -------------------------
6020 -- Gather_Associations --
6021 -------------------------
6023 procedure Gather_Associations
6025 Args : out Args_List)
6030 -- Initialize all parameters to Empty
6032 for J in Args'Range loop
6036 -- That's all we have to do if there are no argument associations
6038 if No (Pragma_Argument_Associations (N)) then
6042 -- Otherwise first deal with any positional parameters present
6044 Arg := First (Pragma_Argument_Associations (N));
6045 for Index in Args'Range loop
6046 exit when No (Arg) or else Chars (Arg) /= No_Name;
6047 Args (Index) := Get_Pragma_Arg (Arg);
6051 -- Positional parameters all processed, if any left, then we
6052 -- have too many positional parameters.
6054 if Present (Arg) and then Chars (Arg) = No_Name then
6056 ("too many positional associations for pragma%", Arg);
6059 -- Process named parameters if any are present
6061 while Present (Arg) loop
6062 if Chars (Arg) = No_Name then
6064 ("positional association cannot follow named association",
6068 for Index in Names'Range loop
6069 if Names (Index) = Chars (Arg) then
6070 if Present (Args (Index)) then
6072 ("duplicate argument association for pragma%", Arg);
6074 Args (Index) := Get_Pragma_Arg (Arg);
6079 if Index = Names'Last then
6080 Error_Msg_Name_1 := Pname;
6081 Error_Msg_N ("pragma% does not allow & argument", Arg);
6083 -- Check for possible misspelling
6085 for Index1 in Names'Range loop
6086 if Is_Bad_Spelling_Of
6087 (Chars (Arg), Names (Index1))
6089 Error_Msg_Name_1 := Names (Index1);
6090 Error_Msg_N -- CODEFIX
6091 ("\possible misspelling of%", Arg);
6103 end Gather_Associations;
6109 procedure GNAT_Pragma is
6111 -- We need to check the No_Implementation_Pragmas restriction for
6112 -- the case of a pragma from source. Note that the case of aspects
6113 -- generating corresponding pragmas marks these pragmas as not being
6114 -- from source, so this test also catches that case.
6116 if Comes_From_Source (N) then
6117 Check_Restriction (No_Implementation_Pragmas, N);
6121 --------------------------
6122 -- Is_Before_First_Decl --
6123 --------------------------
6125 function Is_Before_First_Decl
6126 (Pragma_Node : Node_Id;
6127 Decls : List_Id) return Boolean
6129 Item : Node_Id := First (Decls);
6132 -- Only other pragmas can come before this pragma
6135 if No (Item) or else Nkind (Item) /= N_Pragma then
6138 elsif Item = Pragma_Node then
6144 end Is_Before_First_Decl;
6146 -----------------------------
6147 -- Is_Configuration_Pragma --
6148 -----------------------------
6150 -- A configuration pragma must appear in the context clause of a
6151 -- compilation unit, and only other pragmas may precede it. Note that
6152 -- the test below also permits use in a configuration pragma file.
6154 function Is_Configuration_Pragma return Boolean is
6155 Lis : constant List_Id := List_Containing (N);
6156 Par : constant Node_Id := Parent (N);
6160 -- If no parent, then we are in the configuration pragma file,
6161 -- so the placement is definitely appropriate.
6166 -- Otherwise we must be in the context clause of a compilation unit
6167 -- and the only thing allowed before us in the context list is more
6168 -- configuration pragmas.
6170 elsif Nkind (Par) = N_Compilation_Unit
6171 and then Context_Items (Par) = Lis
6178 elsif Nkind (Prg) /= N_Pragma then
6188 end Is_Configuration_Pragma;
6190 --------------------------
6191 -- Is_In_Context_Clause --
6192 --------------------------
6194 function Is_In_Context_Clause return Boolean is
6196 Parent_Node : Node_Id;
6199 if not Is_List_Member (N) then
6203 Plist := List_Containing (N);
6204 Parent_Node := Parent (Plist);
6206 if Parent_Node = Empty
6207 or else Nkind (Parent_Node) /= N_Compilation_Unit
6208 or else Context_Items (Parent_Node) /= Plist
6215 end Is_In_Context_Clause;
6217 ---------------------------------
6218 -- Is_Static_String_Expression --
6219 ---------------------------------
6221 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6222 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6225 Analyze_And_Resolve (Argx);
6226 return Is_OK_Static_Expression (Argx)
6227 and then Nkind (Argx) = N_String_Literal;
6228 end Is_Static_String_Expression;
6230 ----------------------
6231 -- Pragma_Misplaced --
6232 ----------------------
6234 procedure Pragma_Misplaced is
6236 Error_Pragma ("incorrect placement of pragma%");
6237 end Pragma_Misplaced;
6239 ------------------------------------
6240 -- Process_Atomic_Shared_Volatile --
6241 ------------------------------------
6243 procedure Process_Atomic_Shared_Volatile is
6250 procedure Set_Atomic (E : Entity_Id);
6251 -- Set given type as atomic, and if no explicit alignment was given,
6252 -- set alignment to unknown, since back end knows what the alignment
6253 -- requirements are for atomic arrays. Note: this step is necessary
6254 -- for derived types.
6260 procedure Set_Atomic (E : Entity_Id) is
6264 if not Has_Alignment_Clause (E) then
6265 Set_Alignment (E, Uint_0);
6269 -- Start of processing for Process_Atomic_Shared_Volatile
6272 Check_Ada_83_Warning;
6273 Check_No_Identifiers;
6274 Check_Arg_Count (1);
6275 Check_Arg_Is_Local_Name (Arg1);
6276 E_Id := Get_Pragma_Arg (Arg1);
6278 if Etype (E_Id) = Any_Type then
6283 D := Declaration_Node (E);
6286 -- Check duplicate before we chain ourselves
6288 Check_Duplicate_Pragma (E);
6290 -- Now check appropriateness of the entity
6293 if Rep_Item_Too_Early (E, N)
6295 Rep_Item_Too_Late (E, N)
6299 Check_First_Subtype (Arg1);
6302 if Prag_Id /= Pragma_Volatile then
6304 Set_Atomic (Underlying_Type (E));
6305 Set_Atomic (Base_Type (E));
6308 -- Attribute belongs on the base type. If the view of the type is
6309 -- currently private, it also belongs on the underlying type.
6311 Set_Is_Volatile (Base_Type (E));
6312 Set_Is_Volatile (Underlying_Type (E));
6314 Set_Treat_As_Volatile (E);
6315 Set_Treat_As_Volatile (Underlying_Type (E));
6317 elsif K = N_Object_Declaration
6318 or else (K = N_Component_Declaration
6319 and then Original_Record_Component (E) = E)
6321 if Rep_Item_Too_Late (E, N) then
6325 if Prag_Id /= Pragma_Volatile then
6328 -- If the object declaration has an explicit initialization, a
6329 -- temporary may have to be created to hold the expression, to
6330 -- ensure that access to the object remain atomic.
6332 if Nkind (Parent (E)) = N_Object_Declaration
6333 and then Present (Expression (Parent (E)))
6335 Set_Has_Delayed_Freeze (E);
6338 -- An interesting improvement here. If an object of composite
6339 -- type X is declared atomic, and the type X isn't, that's a
6340 -- pity, since it may not have appropriate alignment etc. We
6341 -- can rescue this in the special case where the object and
6342 -- type are in the same unit by just setting the type as
6343 -- atomic, so that the back end will process it as atomic.
6345 -- Note: we used to do this for elementary types as well,
6346 -- but that turns out to be a bad idea and can have unwanted
6347 -- effects, most notably if the type is elementary, the object
6348 -- a simple component within a record, and both are in a spec:
6349 -- every object of this type in the entire program will be
6350 -- treated as atomic, thus incurring a potentially costly
6351 -- synchronization operation for every access.
6353 -- Of course it would be best if the back end could just adjust
6354 -- the alignment etc for the specific object, but that's not
6355 -- something we are capable of doing at this point.
6357 Utyp := Underlying_Type (Etype (E));
6360 and then Is_Composite_Type (Utyp)
6361 and then Sloc (E) > No_Location
6362 and then Sloc (Utyp) > No_Location
6364 Get_Source_File_Index (Sloc (E)) =
6365 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
6367 Set_Is_Atomic (Underlying_Type (Etype (E)));
6371 Set_Is_Volatile (E);
6372 Set_Treat_As_Volatile (E);
6375 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6378 -- The following check is only relevant when SPARK_Mode is on as
6379 -- this is not a standard Ada legality rule. Pragma Volatile can
6380 -- only apply to a full type declaration or an object declaration
6381 -- (SPARK RM C.6(1)).
6384 and then Prag_Id = Pragma_Volatile
6385 and then not Nkind_In (K, N_Full_Type_Declaration,
6386 N_Object_Declaration)
6389 ("argument of pragma % must denote a full type or object "
6390 & "declaration", Arg1);
6392 end Process_Atomic_Shared_Volatile;
6394 -------------------------------------------
6395 -- Process_Compile_Time_Warning_Or_Error --
6396 -------------------------------------------
6398 procedure Process_Compile_Time_Warning_Or_Error is
6399 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6402 Check_Arg_Count (2);
6403 Check_No_Identifiers;
6404 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6405 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6407 if Compile_Time_Known_Value (Arg1x) then
6408 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6410 Str : constant String_Id :=
6411 Strval (Get_Pragma_Arg (Arg2));
6412 Len : constant Int := String_Length (Str);
6417 Cent : constant Entity_Id :=
6418 Cunit_Entity (Current_Sem_Unit);
6420 Force : constant Boolean :=
6421 Prag_Id = Pragma_Compile_Time_Warning
6423 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6424 and then (Ekind (Cent) /= E_Package
6425 or else not In_Private_Part (Cent));
6426 -- Set True if this is the warning case, and we are in the
6427 -- visible part of a package spec, or in a subprogram spec,
6428 -- in which case we want to force the client to see the
6429 -- warning, even though it is not in the main unit.
6432 -- Loop through segments of message separated by line feeds.
6433 -- We output these segments as separate messages with
6434 -- continuation marks for all but the first.
6439 Error_Msg_Strlen := 0;
6441 -- Loop to copy characters from argument to error message
6445 exit when Ptr > Len;
6446 CC := Get_String_Char (Str, Ptr);
6449 -- Ignore wide chars ??? else store character
6451 if In_Character_Range (CC) then
6452 C := Get_Character (CC);
6453 exit when C = ASCII.LF;
6454 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6455 Error_Msg_String (Error_Msg_Strlen) := C;
6459 -- Here with one line ready to go
6461 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6463 -- If this is a warning in a spec, then we want clients
6464 -- to see the warning, so mark the message with the
6465 -- special sequence !! to force the warning. In the case
6466 -- of a package spec, we do not force this if we are in
6467 -- the private part of the spec.
6470 if Cont = False then
6471 Error_Msg_N ("<<~!!", Arg1);
6474 Error_Msg_N ("\<<~!!", Arg1);
6477 -- Error, rather than warning, or in a body, so we do not
6478 -- need to force visibility for client (error will be
6479 -- output in any case, and this is the situation in which
6480 -- we do not want a client to get a warning, since the
6481 -- warning is in the body or the spec private part).
6484 if Cont = False then
6485 Error_Msg_N ("<<~", Arg1);
6488 Error_Msg_N ("\<<~", Arg1);
6492 exit when Ptr > Len;
6497 end Process_Compile_Time_Warning_Or_Error;
6499 ------------------------
6500 -- Process_Convention --
6501 ------------------------
6503 procedure Process_Convention
6504 (C : out Convention_Id;
6505 Ent : out Entity_Id)
6511 Comp_Unit : Unit_Number_Type;
6513 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6514 -- Called if we have more than one Export/Import/Convention pragma.
6515 -- This is generally illegal, but we have a special case of allowing
6516 -- Import and Interface to coexist if they specify the convention in
6517 -- a consistent manner. We are allowed to do this, since Interface is
6518 -- an implementation defined pragma, and we choose to do it since we
6519 -- know Rational allows this combination. S is the entity id of the
6520 -- subprogram in question. This procedure also sets the special flag
6521 -- Import_Interface_Present in both pragmas in the case where we do
6522 -- have matching Import and Interface pragmas.
6524 procedure Set_Convention_From_Pragma (E : Entity_Id);
6525 -- Set convention in entity E, and also flag that the entity has a
6526 -- convention pragma. If entity is for a private or incomplete type,
6527 -- also set convention and flag on underlying type. This procedure
6528 -- also deals with the special case of C_Pass_By_Copy convention,
6529 -- and error checks for inappropriate convention specification.
6531 -------------------------------
6532 -- Diagnose_Multiple_Pragmas --
6533 -------------------------------
6535 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6536 Pdec : constant Node_Id := Declaration_Node (S);
6540 function Same_Convention (Decl : Node_Id) return Boolean;
6541 -- Decl is a pragma node. This function returns True if this
6542 -- pragma has a first argument that is an identifier with a
6543 -- Chars field corresponding to the Convention_Id C.
6545 function Same_Name (Decl : Node_Id) return Boolean;
6546 -- Decl is a pragma node. This function returns True if this
6547 -- pragma has a second argument that is an identifier with a
6548 -- Chars field that matches the Chars of the current subprogram.
6550 ---------------------
6551 -- Same_Convention --
6552 ---------------------
6554 function Same_Convention (Decl : Node_Id) return Boolean is
6555 Arg1 : constant Node_Id :=
6556 First (Pragma_Argument_Associations (Decl));
6559 if Present (Arg1) then
6561 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6563 if Nkind (Arg) = N_Identifier
6564 and then Is_Convention_Name (Chars (Arg))
6565 and then Get_Convention_Id (Chars (Arg)) = C
6573 end Same_Convention;
6579 function Same_Name (Decl : Node_Id) return Boolean is
6580 Arg1 : constant Node_Id :=
6581 First (Pragma_Argument_Associations (Decl));
6589 Arg2 := Next (Arg1);
6596 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6598 if Nkind (Arg) = N_Identifier
6599 and then Chars (Arg) = Chars (S)
6608 -- Start of processing for Diagnose_Multiple_Pragmas
6613 -- Definitely give message if we have Convention/Export here
6615 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6618 -- If we have an Import or Export, scan back from pragma to
6619 -- find any previous pragma applying to the same procedure.
6620 -- The scan will be terminated by the start of the list, or
6621 -- hitting the subprogram declaration. This won't allow one
6622 -- pragma to appear in the public part and one in the private
6623 -- part, but that seems very unlikely in practice.
6627 while Present (Decl) and then Decl /= Pdec loop
6629 -- Look for pragma with same name as us
6631 if Nkind (Decl) = N_Pragma
6632 and then Same_Name (Decl)
6634 -- Give error if same as our pragma or Export/Convention
6636 if Nam_In (Pragma_Name (Decl), Name_Export,
6642 -- Case of Import/Interface or the other way round
6644 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6647 -- Here we know that we have Import and Interface. It
6648 -- doesn't matter which way round they are. See if
6649 -- they specify the same convention. If so, all OK,
6650 -- and set special flags to stop other messages
6652 if Same_Convention (Decl) then
6653 Set_Import_Interface_Present (N);
6654 Set_Import_Interface_Present (Decl);
6657 -- If different conventions, special message
6660 Error_Msg_Sloc := Sloc (Decl);
6662 ("convention differs from that given#", Arg1);
6672 -- Give message if needed if we fall through those tests
6673 -- except on Relaxed_RM_Semantics where we let go: either this
6674 -- is a case accepted/ignored by other Ada compilers (e.g.
6675 -- a mix of Convention and Import), or another error will be
6676 -- generated later (e.g. using both Import and Export).
6678 if Err and not Relaxed_RM_Semantics then
6680 ("at most one Convention/Export/Import pragma is allowed",
6683 end Diagnose_Multiple_Pragmas;
6685 --------------------------------
6686 -- Set_Convention_From_Pragma --
6687 --------------------------------
6689 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6691 -- Ghost convention is allowed only for functions
6693 if Ekind (E) /= E_Function and then C = Convention_Ghost then
6695 ("& may not have Ghost convention", E);
6697 ("\only functions are permitted to have Ghost convention",
6702 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6703 -- for an overridden dispatching operation. Technically this is
6704 -- an amendment and should only be done in Ada 2005 mode. However,
6705 -- this is clearly a mistake, since the problem that is addressed
6706 -- by this AI is that there is a clear gap in the RM.
6708 if Is_Dispatching_Operation (E)
6709 and then Present (Overridden_Operation (E))
6710 and then C /= Convention (Overridden_Operation (E))
6712 -- An attempt to override a function with a ghost function
6713 -- appears as a mismatch in conventions.
6715 if C = Convention_Ghost then
6716 Error_Msg_N ("ghost function & cannot be overriding", E);
6719 ("cannot change convention for overridden dispatching "
6720 & "operation", Arg1);
6724 -- Special checks for Convention_Stdcall
6726 if C = Convention_Stdcall then
6728 -- A dispatching call is not allowed. A dispatching subprogram
6729 -- cannot be used to interface to the Win32 API, so in fact
6730 -- this check does not impose any effective restriction.
6732 if Is_Dispatching_Operation (E) then
6733 Error_Msg_Sloc := Sloc (E);
6735 -- Note: make this unconditional so that if there is more
6736 -- than one call to which the pragma applies, we get a
6737 -- message for each call. Also don't use Error_Pragma,
6738 -- so that we get multiple messages.
6741 ("dispatching subprogram# cannot use Stdcall convention!",
6744 -- Subprogram is allowed, but not a generic subprogram
6746 elsif not Is_Subprogram (E)
6747 and then not Is_Generic_Subprogram (E)
6751 and then Ekind (E) /= E_Variable
6753 -- An access to subprogram is also allowed
6757 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
6759 -- Allow internal call to set convention of subprogram type
6761 and then not (Ekind (E) = E_Subprogram_Type)
6764 ("second argument of pragma% must be subprogram (type)",
6769 -- Set the convention
6771 Set_Convention (E, C);
6772 Set_Has_Convention_Pragma (E);
6774 -- For the case of a record base type, also set the convention of
6775 -- any anonymous access types declared in the record which do not
6776 -- currently have a specified convention.
6778 if Is_Record_Type (E) and then Is_Base_Type (E) then
6783 Comp := First_Component (E);
6784 while Present (Comp) loop
6785 if Present (Etype (Comp))
6786 and then Ekind_In (Etype (Comp),
6787 E_Anonymous_Access_Type,
6788 E_Anonymous_Access_Subprogram_Type)
6789 and then not Has_Convention_Pragma (Comp)
6791 Set_Convention (Comp, C);
6794 Next_Component (Comp);
6799 -- Deal with incomplete/private type case, where underlying type
6800 -- is available, so set convention of that underlying type.
6802 if Is_Incomplete_Or_Private_Type (E)
6803 and then Present (Underlying_Type (E))
6805 Set_Convention (Underlying_Type (E), C);
6806 Set_Has_Convention_Pragma (Underlying_Type (E), True);
6809 -- A class-wide type should inherit the convention of the specific
6810 -- root type (although this isn't specified clearly by the RM).
6812 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
6813 Set_Convention (Class_Wide_Type (E), C);
6816 -- If the entity is a record type, then check for special case of
6817 -- C_Pass_By_Copy, which is treated the same as C except that the
6818 -- special record flag is set. This convention is only permitted
6819 -- on record types (see AI95-00131).
6821 if Cname = Name_C_Pass_By_Copy then
6822 if Is_Record_Type (E) then
6823 Set_C_Pass_By_Copy (Base_Type (E));
6824 elsif Is_Incomplete_Or_Private_Type (E)
6825 and then Is_Record_Type (Underlying_Type (E))
6827 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
6830 ("C_Pass_By_Copy convention allowed only for record type",
6835 -- If the entity is a derived boolean type, check for the special
6836 -- case of convention C, C++, or Fortran, where we consider any
6837 -- nonzero value to represent true.
6839 if Is_Discrete_Type (E)
6840 and then Root_Type (Etype (E)) = Standard_Boolean
6846 C = Convention_Fortran)
6848 Set_Nonzero_Is_True (Base_Type (E));
6850 end Set_Convention_From_Pragma;
6852 -- Start of processing for Process_Convention
6855 Check_At_Least_N_Arguments (2);
6856 Check_Optional_Identifier (Arg1, Name_Convention);
6857 Check_Arg_Is_Identifier (Arg1);
6858 Cname := Chars (Get_Pragma_Arg (Arg1));
6860 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6861 -- tested again below to set the critical flag).
6863 if Cname = Name_C_Pass_By_Copy then
6866 -- Otherwise we must have something in the standard convention list
6868 elsif Is_Convention_Name (Cname) then
6869 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
6871 -- In DEC VMS, it seems that there is an undocumented feature that
6872 -- any unrecognized convention is treated as the default, which for
6873 -- us is convention C. It does not seem so terrible to do this
6874 -- unconditionally, silently in the VMS case, and with a warning
6875 -- in the non-VMS case.
6878 if Warn_On_Export_Import and not OpenVMS_On_Target then
6880 ("??unrecognized convention name, C assumed",
6881 Get_Pragma_Arg (Arg1));
6887 Check_Optional_Identifier (Arg2, Name_Entity);
6888 Check_Arg_Is_Local_Name (Arg2);
6890 Id := Get_Pragma_Arg (Arg2);
6893 if not Is_Entity_Name (Id) then
6894 Error_Pragma_Arg ("entity name required", Arg2);
6899 -- Set entity to return
6903 -- Ada_Pass_By_Copy special checking
6905 if C = Convention_Ada_Pass_By_Copy then
6906 if not Is_First_Subtype (E) then
6908 ("convention `Ada_Pass_By_Copy` only allowed for types",
6912 if Is_By_Reference_Type (E) then
6914 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6919 -- Ada_Pass_By_Reference special checking
6921 if C = Convention_Ada_Pass_By_Reference then
6922 if not Is_First_Subtype (E) then
6924 ("convention `Ada_Pass_By_Reference` only allowed for types",
6928 if Is_By_Copy_Type (E) then
6930 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6935 -- Ghost special checking
6937 if Is_Ghost_Subprogram (E)
6938 and then Present (Overridden_Operation (E))
6940 Error_Msg_N ("ghost function & cannot be overriding", E);
6943 -- Go to renamed subprogram if present, since convention applies to
6944 -- the actual renamed entity, not to the renaming entity. If the
6945 -- subprogram is inherited, go to parent subprogram.
6947 if Is_Subprogram (E)
6948 and then Present (Alias (E))
6950 if Nkind (Parent (Declaration_Node (E))) =
6951 N_Subprogram_Renaming_Declaration
6953 if Scope (E) /= Scope (Alias (E)) then
6955 ("cannot apply pragma% to non-local entity&#", E);
6960 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
6961 N_Private_Extension_Declaration)
6962 and then Scope (E) = Scope (Alias (E))
6966 -- Return the parent subprogram the entity was inherited from
6972 -- Check that we are not applying this to a specless body
6973 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
6976 if Is_Subprogram (E)
6977 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
6978 and then not Relaxed_RM_Semantics
6981 ("pragma% requires separate spec and must come before body");
6984 -- Check that we are not applying this to a named constant
6986 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
6987 Error_Msg_Name_1 := Pname;
6989 ("cannot apply pragma% to named constant!",
6990 Get_Pragma_Arg (Arg2));
6992 ("\supply appropriate type for&!", Arg2);
6995 if Ekind (E) = E_Enumeration_Literal then
6996 Error_Pragma ("enumeration literal not allowed for pragma%");
6999 -- Check for rep item appearing too early or too late
7001 if Etype (E) = Any_Type
7002 or else Rep_Item_Too_Early (E, N)
7006 elsif Present (Underlying_Type (E)) then
7007 E := Underlying_Type (E);
7010 if Rep_Item_Too_Late (E, N) then
7014 if Has_Convention_Pragma (E) then
7015 Diagnose_Multiple_Pragmas (E);
7017 elsif Convention (E) = Convention_Protected
7018 or else Ekind (Scope (E)) = E_Protected_Type
7021 ("a protected operation cannot be given a different convention",
7025 -- For Intrinsic, a subprogram is required
7027 if C = Convention_Intrinsic
7028 and then not Is_Subprogram (E)
7029 and then not Is_Generic_Subprogram (E)
7032 ("second argument of pragma% must be a subprogram", Arg2);
7035 -- Deal with non-subprogram cases
7037 if not Is_Subprogram (E)
7038 and then not Is_Generic_Subprogram (E)
7040 Set_Convention_From_Pragma (E);
7043 Check_First_Subtype (Arg2);
7044 Set_Convention_From_Pragma (Base_Type (E));
7046 -- For access subprograms, we must set the convention on the
7047 -- internally generated directly designated type as well.
7049 if Ekind (E) = E_Access_Subprogram_Type then
7050 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7054 -- For the subprogram case, set proper convention for all homonyms
7055 -- in same scope and the same declarative part, i.e. the same
7056 -- compilation unit.
7059 Comp_Unit := Get_Source_Unit (E);
7060 Set_Convention_From_Pragma (E);
7062 -- Treat a pragma Import as an implicit body, and pragma import
7063 -- as implicit reference (for navigation in GPS).
7065 if Prag_Id = Pragma_Import then
7066 Generate_Reference (E, Id, 'b');
7068 -- For exported entities we restrict the generation of references
7069 -- to entities exported to foreign languages since entities
7070 -- exported to Ada do not provide further information to GPS and
7071 -- add undesired references to the output of the gnatxref tool.
7073 elsif Prag_Id = Pragma_Export
7074 and then Convention (E) /= Convention_Ada
7076 Generate_Reference (E, Id, 'i');
7079 -- If the pragma comes from from an aspect, it only applies to the
7080 -- given entity, not its homonyms.
7082 if From_Aspect_Specification (N) then
7086 -- Otherwise Loop through the homonyms of the pragma argument's
7087 -- entity, an apply convention to those in the current scope.
7093 exit when No (E1) or else Scope (E1) /= Current_Scope;
7095 -- Ignore entry for which convention is already set
7097 if Has_Convention_Pragma (E1) then
7101 -- Do not set the pragma on inherited operations or on formal
7104 if Comes_From_Source (E1)
7105 and then Comp_Unit = Get_Source_Unit (E1)
7106 and then not Is_Formal_Subprogram (E1)
7107 and then Nkind (Original_Node (Parent (E1))) /=
7108 N_Full_Type_Declaration
7110 if Present (Alias (E1))
7111 and then Scope (E1) /= Scope (Alias (E1))
7114 ("cannot apply pragma% to non-local entity& declared#",
7118 Set_Convention_From_Pragma (E1);
7120 if Prag_Id = Pragma_Import then
7121 Generate_Reference (E1, Id, 'b');
7129 end Process_Convention;
7131 ----------------------------------------
7132 -- Process_Disable_Enable_Atomic_Sync --
7133 ----------------------------------------
7135 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7137 Check_No_Identifiers;
7138 Check_At_Most_N_Arguments (1);
7140 -- Modeled internally as
7141 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7145 Pragma_Identifier =>
7146 Make_Identifier (Loc, Nam),
7147 Pragma_Argument_Associations => New_List (
7148 Make_Pragma_Argument_Association (Loc,
7150 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7152 if Present (Arg1) then
7153 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7157 end Process_Disable_Enable_Atomic_Sync;
7159 -----------------------------------------------------
7160 -- Process_Extended_Import_Export_Exception_Pragma --
7161 -----------------------------------------------------
7163 procedure Process_Extended_Import_Export_Exception_Pragma
7164 (Arg_Internal : Node_Id;
7165 Arg_External : Node_Id;
7173 if not OpenVMS_On_Target then
7175 ("??pragma% ignored (applies only to Open'V'M'S)");
7178 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7179 Def_Id := Entity (Arg_Internal);
7181 if Ekind (Def_Id) /= E_Exception then
7183 ("pragma% must refer to declared exception", Arg_Internal);
7186 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7188 if Present (Arg_Form) then
7189 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
7192 if Present (Arg_Form)
7193 and then Chars (Arg_Form) = Name_Ada
7197 Set_Is_VMS_Exception (Def_Id);
7198 Set_Exception_Code (Def_Id, No_Uint);
7201 if Present (Arg_Code) then
7202 if not Is_VMS_Exception (Def_Id) then
7204 ("Code option for pragma% not allowed for Ada case",
7208 Check_Arg_Is_OK_Static_Expression (Arg_Code, Any_Integer);
7209 Code_Val := Expr_Value (Arg_Code);
7211 if not UI_Is_In_Int_Range (Code_Val) then
7213 ("Code option for pragma% must be in 32-bit range",
7217 Set_Exception_Code (Def_Id, Code_Val);
7220 end Process_Extended_Import_Export_Exception_Pragma;
7222 -------------------------------------------------
7223 -- Process_Extended_Import_Export_Internal_Arg --
7224 -------------------------------------------------
7226 procedure Process_Extended_Import_Export_Internal_Arg
7227 (Arg_Internal : Node_Id := Empty)
7230 if No (Arg_Internal) then
7231 Error_Pragma ("Internal parameter required for pragma%");
7234 if Nkind (Arg_Internal) = N_Identifier then
7237 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7238 and then (Prag_Id = Pragma_Import_Function
7240 Prag_Id = Pragma_Export_Function)
7246 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7249 Check_Arg_Is_Local_Name (Arg_Internal);
7250 end Process_Extended_Import_Export_Internal_Arg;
7252 --------------------------------------------------
7253 -- Process_Extended_Import_Export_Object_Pragma --
7254 --------------------------------------------------
7256 procedure Process_Extended_Import_Export_Object_Pragma
7257 (Arg_Internal : Node_Id;
7258 Arg_External : Node_Id;
7264 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7265 Def_Id := Entity (Arg_Internal);
7267 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7269 ("pragma% must designate an object", Arg_Internal);
7272 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7274 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7277 ("previous Common/Psect_Object applies, pragma % not permitted",
7281 if Rep_Item_Too_Late (Def_Id, N) then
7285 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7287 if Present (Arg_Size) then
7288 Check_Arg_Is_External_Name (Arg_Size);
7291 -- Export_Object case
7293 if Prag_Id = Pragma_Export_Object then
7294 if not Is_Library_Level_Entity (Def_Id) then
7296 ("argument for pragma% must be library level entity",
7300 if Ekind (Current_Scope) = E_Generic_Package then
7301 Error_Pragma ("pragma& cannot appear in a generic unit");
7304 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7306 ("exported object must have compile time known size",
7310 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7311 Error_Msg_N ("??duplicate Export_Object pragma", N);
7313 Set_Exported (Def_Id, Arg_Internal);
7316 -- Import_Object case
7319 if Is_Concurrent_Type (Etype (Def_Id)) then
7321 ("cannot use pragma% for task/protected object",
7325 if Ekind (Def_Id) = E_Constant then
7327 ("cannot import a constant", Arg_Internal);
7330 if Warn_On_Export_Import
7331 and then Has_Discriminants (Etype (Def_Id))
7334 ("imported value must be initialized??", Arg_Internal);
7337 if Warn_On_Export_Import
7338 and then Is_Access_Type (Etype (Def_Id))
7341 ("cannot import object of an access type??", Arg_Internal);
7344 if Warn_On_Export_Import
7345 and then Is_Imported (Def_Id)
7347 Error_Msg_N ("??duplicate Import_Object pragma", N);
7349 -- Check for explicit initialization present. Note that an
7350 -- initialization generated by the code generator, e.g. for an
7351 -- access type, does not count here.
7353 elsif Present (Expression (Parent (Def_Id)))
7356 (Original_Node (Expression (Parent (Def_Id))))
7358 Error_Msg_Sloc := Sloc (Def_Id);
7360 ("imported entities cannot be initialized (RM B.1(24))",
7361 "\no initialization allowed for & declared#", Arg1);
7363 Set_Imported (Def_Id);
7364 Note_Possible_Modification (Arg_Internal, Sure => False);
7367 end Process_Extended_Import_Export_Object_Pragma;
7369 ------------------------------------------------------
7370 -- Process_Extended_Import_Export_Subprogram_Pragma --
7371 ------------------------------------------------------
7373 procedure Process_Extended_Import_Export_Subprogram_Pragma
7374 (Arg_Internal : Node_Id;
7375 Arg_External : Node_Id;
7376 Arg_Parameter_Types : Node_Id;
7377 Arg_Result_Type : Node_Id := Empty;
7378 Arg_Mechanism : Node_Id;
7379 Arg_Result_Mechanism : Node_Id := Empty;
7380 Arg_First_Optional_Parameter : Node_Id := Empty)
7386 Ambiguous : Boolean;
7390 function Same_Base_Type
7392 Formal : Entity_Id) return Boolean;
7393 -- Determines if Ptype references the type of Formal. Note that only
7394 -- the base types need to match according to the spec. Ptype here is
7395 -- the argument from the pragma, which is either a type name, or an
7396 -- access attribute.
7398 --------------------
7399 -- Same_Base_Type --
7400 --------------------
7402 function Same_Base_Type
7404 Formal : Entity_Id) return Boolean
7406 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7410 -- Case where pragma argument is typ'Access
7412 if Nkind (Ptype) = N_Attribute_Reference
7413 and then Attribute_Name (Ptype) = Name_Access
7415 Pref := Prefix (Ptype);
7418 if not Is_Entity_Name (Pref)
7419 or else Entity (Pref) = Any_Type
7424 -- We have a match if the corresponding argument is of an
7425 -- anonymous access type, and its designated type matches the
7426 -- type of the prefix of the access attribute
7428 return Ekind (Ftyp) = E_Anonymous_Access_Type
7429 and then Base_Type (Entity (Pref)) =
7430 Base_Type (Etype (Designated_Type (Ftyp)));
7432 -- Case where pragma argument is a type name
7437 if not Is_Entity_Name (Ptype)
7438 or else Entity (Ptype) = Any_Type
7443 -- We have a match if the corresponding argument is of the type
7444 -- given in the pragma (comparing base types)
7446 return Base_Type (Entity (Ptype)) = Ftyp;
7450 -- Start of processing for
7451 -- Process_Extended_Import_Export_Subprogram_Pragma
7454 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7458 -- Loop through homonyms (overloadings) of the entity
7460 Hom_Id := Entity (Arg_Internal);
7461 while Present (Hom_Id) loop
7462 Def_Id := Get_Base_Subprogram (Hom_Id);
7464 -- We need a subprogram in the current scope
7466 if not Is_Subprogram (Def_Id)
7467 or else Scope (Def_Id) /= Current_Scope
7474 -- Pragma cannot apply to subprogram body
7476 if Is_Subprogram (Def_Id)
7477 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7481 ("pragma% requires separate spec"
7482 & " and must come before body");
7485 -- Test result type if given, note that the result type
7486 -- parameter can only be present for the function cases.
7488 if Present (Arg_Result_Type)
7489 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7493 elsif Etype (Def_Id) /= Standard_Void_Type
7495 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7499 -- Test parameter types if given. Note that this parameter
7500 -- has not been analyzed (and must not be, since it is
7501 -- semantic nonsense), so we get it as the parser left it.
7503 elsif Present (Arg_Parameter_Types) then
7504 Check_Matching_Types : declare
7509 Formal := First_Formal (Def_Id);
7511 if Nkind (Arg_Parameter_Types) = N_Null then
7512 if Present (Formal) then
7516 -- A list of one type, e.g. (List) is parsed as
7517 -- a parenthesized expression.
7519 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7520 and then Paren_Count (Arg_Parameter_Types) = 1
7523 or else Present (Next_Formal (Formal))
7528 Same_Base_Type (Arg_Parameter_Types, Formal);
7531 -- A list of more than one type is parsed as a aggregate
7533 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7534 and then Paren_Count (Arg_Parameter_Types) = 0
7536 Ptype := First (Expressions (Arg_Parameter_Types));
7537 while Present (Ptype) or else Present (Formal) loop
7540 or else not Same_Base_Type (Ptype, Formal)
7545 Next_Formal (Formal);
7550 -- Anything else is of the wrong form
7554 ("wrong form for Parameter_Types parameter",
7555 Arg_Parameter_Types);
7557 end Check_Matching_Types;
7560 -- Match is now False if the entry we found did not match
7561 -- either a supplied Parameter_Types or Result_Types argument
7567 -- Ambiguous case, the flag Ambiguous shows if we already
7568 -- detected this and output the initial messages.
7571 if not Ambiguous then
7573 Error_Msg_Name_1 := Pname;
7575 ("pragma% does not uniquely identify subprogram!",
7577 Error_Msg_Sloc := Sloc (Ent);
7578 Error_Msg_N ("matching subprogram #!", N);
7582 Error_Msg_Sloc := Sloc (Def_Id);
7583 Error_Msg_N ("matching subprogram #!", N);
7588 Hom_Id := Homonym (Hom_Id);
7591 -- See if we found an entry
7594 if not Ambiguous then
7595 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7597 ("pragma% cannot be given for generic subprogram");
7600 ("pragma% does not identify local subprogram");
7607 -- Import pragmas must be for imported entities
7609 if Prag_Id = Pragma_Import_Function
7611 Prag_Id = Pragma_Import_Procedure
7613 Prag_Id = Pragma_Import_Valued_Procedure
7615 if not Is_Imported (Ent) then
7617 ("pragma Import or Interface must precede pragma%");
7620 -- Here we have the Export case which can set the entity as exported
7622 -- But does not do so if the specified external name is null, since
7623 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7624 -- compatible) to request no external name.
7626 elsif Nkind (Arg_External) = N_String_Literal
7627 and then String_Length (Strval (Arg_External)) = 0
7631 -- In all other cases, set entity as exported
7634 Set_Exported (Ent, Arg_Internal);
7637 -- Special processing for Valued_Procedure cases
7639 if Prag_Id = Pragma_Import_Valued_Procedure
7641 Prag_Id = Pragma_Export_Valued_Procedure
7643 Formal := First_Formal (Ent);
7646 Error_Pragma ("at least one parameter required for pragma%");
7648 elsif Ekind (Formal) /= E_Out_Parameter then
7649 Error_Pragma ("first parameter must have mode out for pragma%");
7652 Set_Is_Valued_Procedure (Ent);
7656 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7658 -- Process Result_Mechanism argument if present. We have already
7659 -- checked that this is only allowed for the function case.
7661 if Present (Arg_Result_Mechanism) then
7662 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7665 -- Process Mechanism parameter if present. Note that this parameter
7666 -- is not analyzed, and must not be analyzed since it is semantic
7667 -- nonsense, so we get it in exactly as the parser left it.
7669 if Present (Arg_Mechanism) then
7677 -- A single mechanism association without a formal parameter
7678 -- name is parsed as a parenthesized expression. All other
7679 -- cases are parsed as aggregates, so we rewrite the single
7680 -- parameter case as an aggregate for consistency.
7682 if Nkind (Arg_Mechanism) /= N_Aggregate
7683 and then Paren_Count (Arg_Mechanism) = 1
7685 Rewrite (Arg_Mechanism,
7686 Make_Aggregate (Sloc (Arg_Mechanism),
7687 Expressions => New_List (
7688 Relocate_Node (Arg_Mechanism))));
7691 -- Case of only mechanism name given, applies to all formals
7693 if Nkind (Arg_Mechanism) /= N_Aggregate then
7694 Formal := First_Formal (Ent);
7695 while Present (Formal) loop
7696 Set_Mechanism_Value (Formal, Arg_Mechanism);
7697 Next_Formal (Formal);
7700 -- Case of list of mechanism associations given
7703 if Null_Record_Present (Arg_Mechanism) then
7705 ("inappropriate form for Mechanism parameter",
7709 -- Deal with positional ones first
7711 Formal := First_Formal (Ent);
7713 if Present (Expressions (Arg_Mechanism)) then
7714 Mname := First (Expressions (Arg_Mechanism));
7715 while Present (Mname) loop
7718 ("too many mechanism associations", Mname);
7721 Set_Mechanism_Value (Formal, Mname);
7722 Next_Formal (Formal);
7727 -- Deal with named entries
7729 if Present (Component_Associations (Arg_Mechanism)) then
7730 Massoc := First (Component_Associations (Arg_Mechanism));
7731 while Present (Massoc) loop
7732 Choice := First (Choices (Massoc));
7734 if Nkind (Choice) /= N_Identifier
7735 or else Present (Next (Choice))
7738 ("incorrect form for mechanism association",
7742 Formal := First_Formal (Ent);
7746 ("parameter name & not present", Choice);
7749 if Chars (Choice) = Chars (Formal) then
7751 (Formal, Expression (Massoc));
7753 -- Set entity on identifier (needed by ASIS)
7755 Set_Entity (Choice, Formal);
7760 Next_Formal (Formal);
7770 -- Process First_Optional_Parameter argument if present. We have
7771 -- already checked that this is only allowed for the Import case.
7773 if Present (Arg_First_Optional_Parameter) then
7774 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
7776 ("first optional parameter must be formal parameter name",
7777 Arg_First_Optional_Parameter);
7780 Formal := First_Formal (Ent);
7784 ("specified formal parameter& not found",
7785 Arg_First_Optional_Parameter);
7788 exit when Chars (Formal) =
7789 Chars (Arg_First_Optional_Parameter);
7791 Next_Formal (Formal);
7794 Set_First_Optional_Parameter (Ent, Formal);
7796 -- Check specified and all remaining formals have right form
7798 while Present (Formal) loop
7799 if Ekind (Formal) /= E_In_Parameter then
7801 ("optional formal& is not of mode in!",
7802 Arg_First_Optional_Parameter, Formal);
7805 Dval := Default_Value (Formal);
7809 ("optional formal& does not have default value!",
7810 Arg_First_Optional_Parameter, Formal);
7812 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
7817 ("default value for optional formal& is non-static!",
7818 Arg_First_Optional_Parameter, Formal);
7822 Set_Is_Optional_Parameter (Formal);
7823 Next_Formal (Formal);
7826 end Process_Extended_Import_Export_Subprogram_Pragma;
7828 --------------------------
7829 -- Process_Generic_List --
7830 --------------------------
7832 procedure Process_Generic_List is
7837 Check_No_Identifiers;
7838 Check_At_Least_N_Arguments (1);
7840 -- Check all arguments are names of generic units or instances
7843 while Present (Arg) loop
7844 Exp := Get_Pragma_Arg (Arg);
7847 if not Is_Entity_Name (Exp)
7849 (not Is_Generic_Instance (Entity (Exp))
7851 not Is_Generic_Unit (Entity (Exp)))
7854 ("pragma% argument must be name of generic unit/instance",
7860 end Process_Generic_List;
7862 ------------------------------------
7863 -- Process_Import_Predefined_Type --
7864 ------------------------------------
7866 procedure Process_Import_Predefined_Type is
7867 Loc : constant Source_Ptr := Sloc (N);
7869 Ftyp : Node_Id := Empty;
7875 String_To_Name_Buffer (Strval (Expression (Arg3)));
7878 Elmt := First_Elmt (Predefined_Float_Types);
7879 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
7883 Ftyp := Node (Elmt);
7885 if Present (Ftyp) then
7887 -- Don't build a derived type declaration, because predefined C
7888 -- types have no declaration anywhere, so cannot really be named.
7889 -- Instead build a full type declaration, starting with an
7890 -- appropriate type definition is built
7892 if Is_Floating_Point_Type (Ftyp) then
7893 Def := Make_Floating_Point_Definition (Loc,
7894 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
7895 Make_Real_Range_Specification (Loc,
7896 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
7897 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
7899 -- Should never have a predefined type we cannot handle
7902 raise Program_Error;
7905 -- Build and insert a Full_Type_Declaration, which will be
7906 -- analyzed as soon as this list entry has been analyzed.
7908 Decl := Make_Full_Type_Declaration (Loc,
7909 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
7910 Type_Definition => Def);
7912 Insert_After (N, Decl);
7913 Mark_Rewrite_Insertion (Decl);
7916 Error_Pragma_Arg ("no matching type found for pragma%",
7919 end Process_Import_Predefined_Type;
7921 ---------------------------------
7922 -- Process_Import_Or_Interface --
7923 ---------------------------------
7925 procedure Process_Import_Or_Interface is
7931 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7932 -- pragma Import (Entity, "external name");
7934 if Relaxed_RM_Semantics
7935 and then Arg_Count = 2
7936 and then Prag_Id = Pragma_Import
7937 and then Nkind (Expression (Arg2)) = N_String_Literal
7940 Def_Id := Get_Pragma_Arg (Arg1);
7943 if not Is_Entity_Name (Def_Id) then
7944 Error_Pragma_Arg ("entity name required", Arg1);
7947 Def_Id := Entity (Def_Id);
7948 Kill_Size_Check_Code (Def_Id);
7949 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
7952 Process_Convention (C, Def_Id);
7953 Kill_Size_Check_Code (Def_Id);
7954 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
7957 if Ekind_In (Def_Id, E_Variable, E_Constant) then
7959 -- We do not permit Import to apply to a renaming declaration
7961 if Present (Renamed_Object (Def_Id)) then
7963 ("pragma% not allowed for object renaming", Arg2);
7965 -- User initialization is not allowed for imported object, but
7966 -- the object declaration may contain a default initialization,
7967 -- that will be discarded. Note that an explicit initialization
7968 -- only counts if it comes from source, otherwise it is simply
7969 -- the code generator making an implicit initialization explicit.
7971 elsif Present (Expression (Parent (Def_Id)))
7972 and then Comes_From_Source (Expression (Parent (Def_Id)))
7974 Error_Msg_Sloc := Sloc (Def_Id);
7976 ("no initialization allowed for declaration of& #",
7977 "\imported entities cannot be initialized (RM B.1(24))",
7981 Set_Imported (Def_Id);
7982 Process_Interface_Name (Def_Id, Arg3, Arg4);
7984 -- Note that we do not set Is_Public here. That's because we
7985 -- only want to set it if there is no address clause, and we
7986 -- don't know that yet, so we delay that processing till
7989 -- pragma Import completes deferred constants
7991 if Ekind (Def_Id) = E_Constant then
7992 Set_Has_Completion (Def_Id);
7995 -- It is not possible to import a constant of an unconstrained
7996 -- array type (e.g. string) because there is no simple way to
7997 -- write a meaningful subtype for it.
7999 if Is_Array_Type (Etype (Def_Id))
8000 and then not Is_Constrained (Etype (Def_Id))
8003 ("imported constant& must have a constrained subtype",
8008 elsif Is_Subprogram (Def_Id)
8009 or else Is_Generic_Subprogram (Def_Id)
8011 -- If the name is overloaded, pragma applies to all of the denoted
8012 -- entities in the same declarative part, unless the pragma comes
8013 -- from an aspect specification or was generated by the compiler
8014 -- (such as for pragma Provide_Shift_Operators).
8017 while Present (Hom_Id) loop
8019 Def_Id := Get_Base_Subprogram (Hom_Id);
8021 -- Ignore inherited subprograms because the pragma will apply
8022 -- to the parent operation, which is the one called.
8024 if Is_Overloadable (Def_Id)
8025 and then Present (Alias (Def_Id))
8029 -- If it is not a subprogram, it must be in an outer scope and
8030 -- pragma does not apply.
8032 elsif not Is_Subprogram (Def_Id)
8033 and then not Is_Generic_Subprogram (Def_Id)
8037 -- The pragma does not apply to primitives of interfaces
8039 elsif Is_Dispatching_Operation (Def_Id)
8040 and then Present (Find_Dispatching_Type (Def_Id))
8041 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8045 -- Verify that the homonym is in the same declarative part (not
8046 -- just the same scope). If the pragma comes from an aspect
8047 -- specification we know that it is part of the declaration.
8049 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8050 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8051 and then not From_Aspect_Specification (N)
8056 Set_Imported (Def_Id);
8058 -- Reject an Import applied to an abstract subprogram
8060 if Is_Subprogram (Def_Id)
8061 and then Is_Abstract_Subprogram (Def_Id)
8063 Error_Msg_Sloc := Sloc (Def_Id);
8065 ("cannot import abstract subprogram& declared#",
8069 -- Special processing for Convention_Intrinsic
8071 if C = Convention_Intrinsic then
8073 -- Link_Name argument not allowed for intrinsic
8077 Set_Is_Intrinsic_Subprogram (Def_Id);
8079 -- If no external name is present, then check that this
8080 -- is a valid intrinsic subprogram. If an external name
8081 -- is present, then this is handled by the back end.
8084 Check_Intrinsic_Subprogram
8085 (Def_Id, Get_Pragma_Arg (Arg2));
8089 -- Verify that the subprogram does not have a completion
8090 -- through a renaming declaration. For other completions the
8091 -- pragma appears as a too late representation.
8094 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8098 and then Nkind (Decl) = N_Subprogram_Declaration
8099 and then Present (Corresponding_Body (Decl))
8100 and then Nkind (Unit_Declaration_Node
8101 (Corresponding_Body (Decl))) =
8102 N_Subprogram_Renaming_Declaration
8104 Error_Msg_Sloc := Sloc (Def_Id);
8106 ("cannot import&, renaming already provided for "
8107 & "declaration #", N, Def_Id);
8111 Set_Has_Completion (Def_Id);
8112 Process_Interface_Name (Def_Id, Arg3, Arg4);
8115 if Is_Compilation_Unit (Hom_Id) then
8117 -- Its possible homonyms are not affected by the pragma.
8118 -- Such homonyms might be present in the context of other
8119 -- units being compiled.
8123 elsif From_Aspect_Specification (N) then
8126 -- If the pragma was created by the compiler, then we don't
8127 -- want it to apply to other homonyms. This kind of case can
8128 -- occur when using pragma Provide_Shift_Operators, which
8129 -- generates implicit shift and rotate operators with Import
8130 -- pragmas that might apply to earlier explicit or implicit
8131 -- declarations marked with Import (for example, coming from
8132 -- an earlier pragma Provide_Shift_Operators for another type),
8133 -- and we don't generally want other homonyms being treated
8134 -- as imported or the pragma flagged as an illegal duplicate.
8136 elsif not Comes_From_Source (N) then
8140 Hom_Id := Homonym (Hom_Id);
8144 -- When the convention is Java or CIL, we also allow Import to
8145 -- be given for packages, generic packages, exceptions, record
8146 -- components, and access to subprograms.
8148 elsif (C = Convention_Java or else C = Convention_CIL)
8150 (Is_Package_Or_Generic_Package (Def_Id)
8151 or else Ekind (Def_Id) = E_Exception
8152 or else Ekind (Def_Id) = E_Access_Subprogram_Type
8153 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
8155 Set_Imported (Def_Id);
8156 Set_Is_Public (Def_Id);
8157 Process_Interface_Name (Def_Id, Arg3, Arg4);
8159 -- Import a CPP class
8161 elsif C = Convention_CPP
8162 and then (Is_Record_Type (Def_Id)
8163 or else Ekind (Def_Id) = E_Incomplete_Type)
8165 if Ekind (Def_Id) = E_Incomplete_Type then
8166 if Present (Full_View (Def_Id)) then
8167 Def_Id := Full_View (Def_Id);
8171 ("cannot import 'C'P'P type before full declaration seen",
8172 Get_Pragma_Arg (Arg2));
8174 -- Although we have reported the error we decorate it as
8175 -- CPP_Class to avoid reporting spurious errors
8177 Set_Is_CPP_Class (Def_Id);
8182 -- Types treated as CPP classes must be declared limited (note:
8183 -- this used to be a warning but there is no real benefit to it
8184 -- since we did effectively intend to treat the type as limited
8187 if not Is_Limited_Type (Def_Id) then
8189 ("imported 'C'P'P type must be limited",
8190 Get_Pragma_Arg (Arg2));
8193 if Etype (Def_Id) /= Def_Id
8194 and then not Is_CPP_Class (Root_Type (Def_Id))
8196 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8199 Set_Is_CPP_Class (Def_Id);
8201 -- Imported CPP types must not have discriminants (because C++
8202 -- classes do not have discriminants).
8204 if Has_Discriminants (Def_Id) then
8206 ("imported 'C'P'P type cannot have discriminants",
8207 First (Discriminant_Specifications
8208 (Declaration_Node (Def_Id))));
8211 -- Check that components of imported CPP types do not have default
8212 -- expressions. For private types this check is performed when the
8213 -- full view is analyzed (see Process_Full_View).
8215 if not Is_Private_Type (Def_Id) then
8216 Check_CPP_Type_Has_No_Defaults (Def_Id);
8219 -- Import a CPP exception
8221 elsif C = Convention_CPP
8222 and then Ekind (Def_Id) = E_Exception
8226 ("'External_'Name arguments is required for 'Cpp exception",
8229 -- As only a string is allowed, Check_Arg_Is_External_Name
8232 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8235 if Present (Arg4) then
8237 ("Link_Name argument not allowed for imported Cpp exception",
8241 -- Do not call Set_Interface_Name as the name of the exception
8242 -- shouldn't be modified (and in particular it shouldn't be
8243 -- the External_Name). For exceptions, the External_Name is the
8244 -- name of the RTTI structure.
8246 -- ??? Emit an error if pragma Import/Export_Exception is present
8248 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8250 Check_Arg_Count (3);
8251 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8253 Process_Import_Predefined_Type;
8257 ("second argument of pragma% must be object, subprogram "
8258 & "or incomplete type",
8262 -- If this pragma applies to a compilation unit, then the unit, which
8263 -- is a subprogram, does not require (or allow) a body. We also do
8264 -- not need to elaborate imported procedures.
8266 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8268 Cunit : constant Node_Id := Parent (Parent (N));
8270 Set_Body_Required (Cunit, False);
8273 end Process_Import_Or_Interface;
8275 --------------------
8276 -- Process_Inline --
8277 --------------------
8279 procedure Process_Inline (Status : Inline_Status) is
8286 Effective : Boolean := False;
8287 -- Set True if inline has some effect, i.e. if there is at least one
8288 -- subprogram set as inlined as a result of the use of the pragma.
8290 procedure Make_Inline (Subp : Entity_Id);
8291 -- Subp is the defining unit name of the subprogram declaration. Set
8292 -- the flag, as well as the flag in the corresponding body, if there
8295 procedure Set_Inline_Flags (Subp : Entity_Id);
8296 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8297 -- Has_Pragma_Inline_Always for the Inline_Always case.
8299 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8300 -- Returns True if it can be determined at this stage that inlining
8301 -- is not possible, for example if the body is available and contains
8302 -- exception handlers, we prevent inlining, since otherwise we can
8303 -- get undefined symbols at link time. This function also emits a
8304 -- warning if front-end inlining is enabled and the pragma appears
8307 -- ??? is business with link symbols still valid, or does it relate
8308 -- to front end ZCX which is being phased out ???
8310 ---------------------------
8311 -- Inlining_Not_Possible --
8312 ---------------------------
8314 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8315 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8319 if Nkind (Decl) = N_Subprogram_Body then
8320 Stats := Handled_Statement_Sequence (Decl);
8321 return Present (Exception_Handlers (Stats))
8322 or else Present (At_End_Proc (Stats));
8324 elsif Nkind (Decl) = N_Subprogram_Declaration
8325 and then Present (Corresponding_Body (Decl))
8327 if Front_End_Inlining
8328 and then Analyzed (Corresponding_Body (Decl))
8330 Error_Msg_N ("pragma appears too late, ignored??", N);
8333 -- If the subprogram is a renaming as body, the body is just a
8334 -- call to the renamed subprogram, and inlining is trivially
8338 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8339 N_Subprogram_Renaming_Declaration
8345 Handled_Statement_Sequence
8346 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8349 Present (Exception_Handlers (Stats))
8350 or else Present (At_End_Proc (Stats));
8354 -- If body is not available, assume the best, the check is
8355 -- performed again when compiling enclosing package bodies.
8359 end Inlining_Not_Possible;
8365 procedure Make_Inline (Subp : Entity_Id) is
8366 Kind : constant Entity_Kind := Ekind (Subp);
8367 Inner_Subp : Entity_Id := Subp;
8370 -- Ignore if bad type, avoid cascaded error
8372 if Etype (Subp) = Any_Type then
8376 -- Ignore if all inlining is suppressed
8378 elsif Suppress_All_Inlining then
8382 -- If inlining is not possible, for now do not treat as an error
8384 elsif Status /= Suppressed
8385 and then Inlining_Not_Possible (Subp)
8390 -- Here we have a candidate for inlining, but we must exclude
8391 -- derived operations. Otherwise we would end up trying to inline
8392 -- a phantom declaration, and the result would be to drag in a
8393 -- body which has no direct inlining associated with it. That
8394 -- would not only be inefficient but would also result in the
8395 -- backend doing cross-unit inlining in cases where it was
8396 -- definitely inappropriate to do so.
8398 -- However, a simple Comes_From_Source test is insufficient, since
8399 -- we do want to allow inlining of generic instances which also do
8400 -- not come from source. We also need to recognize specs generated
8401 -- by the front-end for bodies that carry the pragma. Finally,
8402 -- predefined operators do not come from source but are not
8403 -- inlineable either.
8405 elsif Is_Generic_Instance (Subp)
8406 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8410 elsif not Comes_From_Source (Subp)
8411 and then Scope (Subp) /= Standard_Standard
8417 -- The referenced entity must either be the enclosing entity, or
8418 -- an entity declared within the current open scope.
8420 if Present (Scope (Subp))
8421 and then Scope (Subp) /= Current_Scope
8422 and then Subp /= Current_Scope
8425 ("argument of% must be entity in current scope", Assoc);
8429 -- Processing for procedure, operator or function. If subprogram
8430 -- is aliased (as for an instance) indicate that the renamed
8431 -- entity (if declared in the same unit) is inlined.
8433 if Is_Subprogram (Subp) then
8434 Inner_Subp := Ultimate_Alias (Inner_Subp);
8436 if In_Same_Source_Unit (Subp, Inner_Subp) then
8437 Set_Inline_Flags (Inner_Subp);
8439 Decl := Parent (Parent (Inner_Subp));
8441 if Nkind (Decl) = N_Subprogram_Declaration
8442 and then Present (Corresponding_Body (Decl))
8444 Set_Inline_Flags (Corresponding_Body (Decl));
8446 elsif Is_Generic_Instance (Subp) then
8448 -- Indicate that the body needs to be created for
8449 -- inlining subsequent calls. The instantiation node
8450 -- follows the declaration of the wrapper package
8453 if Scope (Subp) /= Standard_Standard
8455 Need_Subprogram_Instance_Body
8456 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
8462 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8463 -- appear in a formal part to apply to a formal subprogram.
8464 -- Do not apply check within an instance or a formal package
8465 -- the test will have been applied to the original generic.
8467 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8468 and then List_Containing (Decl) = List_Containing (N)
8469 and then not In_Instance
8472 ("Inline cannot apply to a formal subprogram", N);
8474 -- If Subp is a renaming, it is the renamed entity that
8475 -- will appear in any call, and be inlined. However, for
8476 -- ASIS uses it is convenient to indicate that the renaming
8477 -- itself is an inlined subprogram, so that some gnatcheck
8478 -- rules can be applied in the absence of expansion.
8480 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8481 Set_Inline_Flags (Subp);
8487 -- For a generic subprogram set flag as well, for use at the point
8488 -- of instantiation, to determine whether the body should be
8491 elsif Is_Generic_Subprogram (Subp) then
8492 Set_Inline_Flags (Subp);
8495 -- Literals are by definition inlined
8497 elsif Kind = E_Enumeration_Literal then
8500 -- Anything else is an error
8504 ("expect subprogram name for pragma%", Assoc);
8508 ----------------------
8509 -- Set_Inline_Flags --
8510 ----------------------
8512 procedure Set_Inline_Flags (Subp : Entity_Id) is
8514 -- First set the Has_Pragma_XXX flags and issue the appropriate
8515 -- errors and warnings for suspicious combinations.
8517 if Prag_Id = Pragma_No_Inline then
8518 if Has_Pragma_Inline_Always (Subp) then
8520 ("Inline_Always and No_Inline are mutually exclusive", N);
8521 elsif Has_Pragma_Inline (Subp) then
8523 ("Inline and No_Inline both specified for& ??",
8524 N, Entity (Subp_Id));
8527 Set_Has_Pragma_No_Inline (Subp);
8529 if Prag_Id = Pragma_Inline_Always then
8530 if Has_Pragma_No_Inline (Subp) then
8532 ("Inline_Always and No_Inline are mutually exclusive",
8536 Set_Has_Pragma_Inline_Always (Subp);
8538 if Has_Pragma_No_Inline (Subp) then
8540 ("Inline and No_Inline both specified for& ??",
8541 N, Entity (Subp_Id));
8545 if not Has_Pragma_Inline (Subp) then
8546 Set_Has_Pragma_Inline (Subp);
8551 -- Then adjust the Is_Inlined flag. It can never be set if the
8552 -- subprogram is subject to pragma No_Inline.
8556 Set_Is_Inlined (Subp, False);
8560 if not Has_Pragma_No_Inline (Subp) then
8561 Set_Is_Inlined (Subp, True);
8564 end Set_Inline_Flags;
8566 -- Start of processing for Process_Inline
8569 Check_No_Identifiers;
8570 Check_At_Least_N_Arguments (1);
8572 if Status = Enabled then
8573 Inline_Processing_Required := True;
8577 while Present (Assoc) loop
8578 Subp_Id := Get_Pragma_Arg (Assoc);
8582 if Is_Entity_Name (Subp_Id) then
8583 Subp := Entity (Subp_Id);
8585 if Subp = Any_Id then
8587 -- If previous error, avoid cascaded errors
8589 Check_Error_Detected;
8596 -- For the pragma case, climb homonym chain. This is
8597 -- what implements allowing the pragma in the renaming
8598 -- case, with the result applying to the ancestors, and
8599 -- also allows Inline to apply to all previous homonyms.
8601 if not From_Aspect_Specification (N) then
8602 while Present (Homonym (Subp))
8603 and then Scope (Homonym (Subp)) = Current_Scope
8605 Make_Inline (Homonym (Subp));
8606 Subp := Homonym (Subp);
8614 ("inappropriate argument for pragma%", Assoc);
8617 and then Warn_On_Redundant_Constructs
8618 and then not (Status = Suppressed or else Suppress_All_Inlining)
8620 if Inlining_Not_Possible (Subp) then
8622 ("pragma Inline for& is ignored?r?",
8623 N, Entity (Subp_Id));
8626 ("pragma Inline for& is redundant?r?",
8627 N, Entity (Subp_Id));
8635 ----------------------------
8636 -- Process_Interface_Name --
8637 ----------------------------
8639 procedure Process_Interface_Name
8640 (Subprogram_Def : Entity_Id;
8646 String_Val : String_Id;
8648 procedure Check_Form_Of_Interface_Name
8650 Ext_Name_Case : Boolean);
8651 -- SN is a string literal node for an interface name. This routine
8652 -- performs some minimal checks that the name is reasonable. In
8653 -- particular that no spaces or other obviously incorrect characters
8654 -- appear. This is only a warning, since any characters are allowed.
8655 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8657 ----------------------------------
8658 -- Check_Form_Of_Interface_Name --
8659 ----------------------------------
8661 procedure Check_Form_Of_Interface_Name
8663 Ext_Name_Case : Boolean)
8665 S : constant String_Id := Strval (Expr_Value_S (SN));
8666 SL : constant Nat := String_Length (S);
8671 Error_Msg_N ("interface name cannot be null string", SN);
8674 for J in 1 .. SL loop
8675 C := Get_String_Char (S, J);
8677 -- Look for dubious character and issue unconditional warning.
8678 -- Definitely dubious if not in character range.
8680 if not In_Character_Range (C)
8682 -- For all cases except CLI target,
8683 -- commas, spaces and slashes are dubious (in CLI, we use
8684 -- commas and backslashes in external names to specify
8685 -- assembly version and public key, while slashes and spaces
8686 -- can be used in names to mark nested classes and
8689 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
8690 and then (Get_Character (C) = ','
8692 Get_Character (C) = '\'))
8693 or else (VM_Target /= CLI_Target
8694 and then (Get_Character (C) = ' '
8696 Get_Character (C) = '/'))
8699 ("??interface name contains illegal character",
8700 Sloc (SN) + Source_Ptr (J));
8703 end Check_Form_Of_Interface_Name;
8705 -- Start of processing for Process_Interface_Name
8708 if No (Link_Arg) then
8709 if No (Ext_Arg) then
8710 if VM_Target = CLI_Target
8711 and then Ekind (Subprogram_Def) = E_Package
8712 and then Nkind (Parent (Subprogram_Def)) =
8713 N_Package_Specification
8714 and then Present (Generic_Parent (Parent (Subprogram_Def)))
8719 (Generic_Parent (Parent (Subprogram_Def))));
8724 elsif Chars (Ext_Arg) = Name_Link_Name then
8726 Link_Nam := Expression (Ext_Arg);
8729 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8730 Ext_Nam := Expression (Ext_Arg);
8735 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8736 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8737 Ext_Nam := Expression (Ext_Arg);
8738 Link_Nam := Expression (Link_Arg);
8741 -- Check expressions for external name and link name are static
8743 if Present (Ext_Nam) then
8744 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8745 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
8747 -- Verify that external name is not the name of a local entity,
8748 -- which would hide the imported one and could lead to run-time
8749 -- surprises. The problem can only arise for entities declared in
8750 -- a package body (otherwise the external name is fully qualified
8751 -- and will not conflict).
8759 if Prag_Id = Pragma_Import then
8760 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8762 E := Entity_Id (Get_Name_Table_Info (Nam));
8764 if Nam /= Chars (Subprogram_Def)
8765 and then Present (E)
8766 and then not Is_Overloadable (E)
8767 and then Is_Immediately_Visible (E)
8768 and then not Is_Imported (E)
8769 and then Ekind (Scope (E)) = E_Package
8772 while Present (Par) loop
8773 if Nkind (Par) = N_Package_Body then
8774 Error_Msg_Sloc := Sloc (E);
8776 ("imported entity is hidden by & declared#",
8781 Par := Parent (Par);
8788 if Present (Link_Nam) then
8789 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8790 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
8793 -- If there is no link name, just set the external name
8795 if No (Link_Nam) then
8796 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8798 -- For the Link_Name case, the given literal is preceded by an
8799 -- asterisk, which indicates to GCC that the given name should be
8800 -- taken literally, and in particular that no prepending of
8801 -- underlines should occur, even in systems where this is the
8807 if VM_Target = No_VM then
8808 Store_String_Char (Get_Char_Code ('*'));
8811 String_Val := Strval (Expr_Value_S (Link_Nam));
8812 Store_String_Chars (String_Val);
8814 Make_String_Literal (Sloc (Link_Nam),
8815 Strval => End_String);
8818 -- Set the interface name. If the entity is a generic instance, use
8819 -- its alias, which is the callable entity.
8821 if Is_Generic_Instance (Subprogram_Def) then
8822 Set_Encoded_Interface_Name
8823 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8825 Set_Encoded_Interface_Name
8826 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
8829 -- We allow duplicated export names in CIL/Java, as they are always
8830 -- enclosed in a namespace that differentiates them, and overloaded
8831 -- entities are supported by the VM.
8833 if Convention (Subprogram_Def) /= Convention_CIL
8835 Convention (Subprogram_Def) /= Convention_Java
8837 Check_Duplicated_Export_Name (Link_Nam);
8839 end Process_Interface_Name;
8841 -----------------------------------------
8842 -- Process_Interrupt_Or_Attach_Handler --
8843 -----------------------------------------
8845 procedure Process_Interrupt_Or_Attach_Handler is
8846 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
8847 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
8848 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
8851 Set_Is_Interrupt_Handler (Handler_Proc);
8853 -- If the pragma is not associated with a handler procedure within a
8854 -- protected type, then it must be for a nonprotected procedure for
8855 -- the AAMP target, in which case we don't associate a representation
8856 -- item with the procedure's scope.
8858 if Ekind (Proc_Scope) = E_Protected_Type then
8859 if Prag_Id = Pragma_Interrupt_Handler
8861 Prag_Id = Pragma_Attach_Handler
8863 Record_Rep_Item (Proc_Scope, N);
8866 end Process_Interrupt_Or_Attach_Handler;
8868 --------------------------------------------------
8869 -- Process_Restrictions_Or_Restriction_Warnings --
8870 --------------------------------------------------
8872 -- Note: some of the simple identifier cases were handled in par-prag,
8873 -- but it is harmless (and more straightforward) to simply handle all
8874 -- cases here, even if it means we repeat a bit of work in some cases.
8876 procedure Process_Restrictions_Or_Restriction_Warnings
8880 R_Id : Restriction_Id;
8886 -- Ignore all Restrictions pragmas in CodePeer mode
8888 if CodePeer_Mode then
8892 Check_Ada_83_Warning;
8893 Check_At_Least_N_Arguments (1);
8894 Check_Valid_Configuration_Pragma;
8897 while Present (Arg) loop
8899 Expr := Get_Pragma_Arg (Arg);
8901 -- Special handling for No_Elaboration_Code
8903 if Nkind (Expr) = N_Identifier
8904 and then Chars (Expr) = Name_No_Elaboration_Code
8906 if No_Elab_Code (Current_Sem_Unit) < No_Elab_Code then
8907 Set_No_Elab_Code (Current_Sem_Unit, No_Elab_Code);
8911 -- Special handling for No_Elaboration_Code_All
8913 if Nkind (Expr) = N_Identifier
8914 and then Chars (Expr) = Name_No_Elaboration_Code_All
8916 -- Must appear within a spec
8918 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
8919 N_Package_Declaration,
8920 N_Subprogram_Declaration)
8922 Error_Msg_Name_1 := Id;
8924 ("restriction% can appear only in package or "
8925 & "subprogram spec", Arg);
8928 -- Set special value in unit table
8931 New_Val : No_Elab_Code_T;
8935 New_Val := No_Elab_Code_All_Warn;
8937 New_Val := No_Elab_Code_All;
8940 if No_Elab_Code (Current_Sem_Unit) < New_Val then
8941 Set_No_Elab_Code (Current_Sem_Unit, New_Val);
8945 -- Note that in the code below, Process_Restriction_Synonym
8946 -- will treat No_Elaboration_Code_All like No_Elaboration_Code.
8950 -- Case of no restriction identifier present
8952 if Id = No_Name then
8953 if Nkind (Expr) /= N_Identifier then
8955 ("invalid form for restriction", Arg);
8960 (Process_Restriction_Synonyms (Expr));
8962 if R_Id not in All_Boolean_Restrictions then
8963 Error_Msg_Name_1 := Pname;
8965 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
8967 -- Check for possible misspelling
8969 for J in Restriction_Id loop
8971 Rnm : constant String := Restriction_Id'Image (J);
8974 Name_Buffer (1 .. Rnm'Length) := Rnm;
8975 Name_Len := Rnm'Length;
8976 Set_Casing (All_Lower_Case);
8978 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
8980 (Identifier_Casing (Current_Source_File));
8981 Error_Msg_String (1 .. Rnm'Length) :=
8982 Name_Buffer (1 .. Name_Len);
8983 Error_Msg_Strlen := Rnm'Length;
8984 Error_Msg_N -- CODEFIX
8985 ("\possible misspelling of ""~""",
8986 Get_Pragma_Arg (Arg));
8995 if Implementation_Restriction (R_Id) then
8996 Check_Restriction (No_Implementation_Restrictions, Arg);
8999 -- Special processing for No_Elaboration_Code restriction
9001 if R_Id = No_Elaboration_Code then
9003 -- Restriction is only recognized within a configuration
9004 -- pragma file, or within a unit of the main extended
9005 -- program. Note: the test for Main_Unit is needed to
9006 -- properly include the case of configuration pragma files.
9008 if not (Current_Sem_Unit = Main_Unit
9009 or else In_Extended_Main_Source_Unit (N))
9013 -- Don't allow in a subunit unless already specified in
9016 elsif Nkind (Parent (N)) = N_Compilation_Unit
9017 and then Nkind (Unit (Parent (N))) = N_Subunit
9018 and then not Restriction_Active (No_Elaboration_Code)
9021 ("invalid specification of ""No_Elaboration_Code""",
9024 ("\restriction cannot be specified in a subunit", N);
9026 ("\unless also specified in body or spec", N);
9029 -- If we have a No_Elaboration_Code pragma that we
9030 -- accept, then it needs to be added to the configuration
9031 -- restrcition set so that we get proper application to
9032 -- other units in the main extended source as required.
9035 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9039 -- If this is a warning, then set the warning unless we already
9040 -- have a real restriction active (we never want a warning to
9041 -- override a real restriction).
9044 if not Restriction_Active (R_Id) then
9045 Set_Restriction (R_Id, N);
9046 Restriction_Warnings (R_Id) := True;
9049 -- If real restriction case, then set it and make sure that the
9050 -- restriction warning flag is off, since a real restriction
9051 -- always overrides a warning.
9054 Set_Restriction (R_Id, N);
9055 Restriction_Warnings (R_Id) := False;
9058 -- Check for obsolescent restrictions in Ada 2005 mode
9061 and then Ada_Version >= Ada_2005
9062 and then (R_Id = No_Asynchronous_Control
9064 R_Id = No_Unchecked_Deallocation
9066 R_Id = No_Unchecked_Conversion)
9068 Check_Restriction (No_Obsolescent_Features, N);
9071 -- A very special case that must be processed here: pragma
9072 -- Restrictions (No_Exceptions) turns off all run-time
9073 -- checking. This is a bit dubious in terms of the formal
9074 -- language definition, but it is what is intended by RM
9075 -- H.4(12). Restriction_Warnings never affects generated code
9076 -- so this is done only in the real restriction case.
9078 -- Atomic_Synchronization is not a real check, so it is not
9079 -- affected by this processing).
9081 if R_Id = No_Exceptions and then not Warn then
9082 for J in Scope_Suppress.Suppress'Range loop
9083 if J /= Atomic_Synchronization then
9084 Scope_Suppress.Suppress (J) := True;
9089 -- Case of No_Dependence => unit-name. Note that the parser
9090 -- already made the necessary entry in the No_Dependence table.
9092 elsif Id = Name_No_Dependence then
9093 if not OK_No_Dependence_Unit_Name (Expr) then
9097 -- Case of No_Specification_Of_Aspect => Identifier.
9099 elsif Id = Name_No_Specification_Of_Aspect then
9104 if Nkind (Expr) /= N_Identifier then
9107 A_Id := Get_Aspect_Id (Chars (Expr));
9110 if A_Id = No_Aspect then
9111 Error_Pragma_Arg ("invalid restriction name", Arg);
9113 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9117 elsif Id = Name_No_Use_Of_Attribute then
9118 if Nkind (Expr) /= N_Identifier
9119 or else not Is_Attribute_Name (Chars (Expr))
9121 Error_Msg_N ("unknown attribute name??", Expr);
9124 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9127 elsif Id = Name_No_Use_Of_Pragma then
9128 if Nkind (Expr) /= N_Identifier
9129 or else not Is_Pragma_Name (Chars (Expr))
9131 Error_Msg_N ("unknown pragma name??", Expr);
9134 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9137 -- All other cases of restriction identifier present
9140 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9141 Analyze_And_Resolve (Expr, Any_Integer);
9143 if R_Id not in All_Parameter_Restrictions then
9145 ("invalid restriction parameter identifier", Arg);
9147 elsif not Is_OK_Static_Expression (Expr) then
9148 Flag_Non_Static_Expr
9149 ("value must be static expression!", Expr);
9152 elsif not Is_Integer_Type (Etype (Expr))
9153 or else Expr_Value (Expr) < 0
9156 ("value must be non-negative integer", Arg);
9159 -- Restriction pragma is active
9161 Val := Expr_Value (Expr);
9163 if not UI_Is_In_Int_Range (Val) then
9165 ("pragma ignored, value too large??", Arg);
9168 -- Warning case. If the real restriction is active, then we
9169 -- ignore the request, since warning never overrides a real
9170 -- restriction. Otherwise we set the proper warning. Note that
9171 -- this circuit sets the warning again if it is already set,
9172 -- which is what we want, since the constant may have changed.
9175 if not Restriction_Active (R_Id) then
9177 (R_Id, N, Integer (UI_To_Int (Val)));
9178 Restriction_Warnings (R_Id) := True;
9181 -- Real restriction case, set restriction and make sure warning
9182 -- flag is off since real restriction always overrides warning.
9185 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9186 Restriction_Warnings (R_Id) := False;
9192 end Process_Restrictions_Or_Restriction_Warnings;
9194 ---------------------------------
9195 -- Process_Suppress_Unsuppress --
9196 ---------------------------------
9198 -- Note: this procedure makes entries in the check suppress data
9199 -- structures managed by Sem. See spec of package Sem for full
9200 -- details on how we handle recording of check suppression.
9202 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9207 In_Package_Spec : constant Boolean :=
9208 Is_Package_Or_Generic_Package (Current_Scope)
9209 and then not In_Package_Body (Current_Scope);
9211 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9212 -- Used to suppress a single check on the given entity
9214 --------------------------------
9215 -- Suppress_Unsuppress_Echeck --
9216 --------------------------------
9218 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9220 -- Check for error of trying to set atomic synchronization for
9221 -- a non-atomic variable.
9223 if C = Atomic_Synchronization
9224 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9227 ("pragma & requires atomic type or variable",
9228 Pragma_Identifier (Original_Node (N)));
9231 Set_Checks_May_Be_Suppressed (E);
9233 if In_Package_Spec then
9234 Push_Global_Suppress_Stack_Entry
9237 Suppress => Suppress_Case);
9239 Push_Local_Suppress_Stack_Entry
9242 Suppress => Suppress_Case);
9245 -- If this is a first subtype, and the base type is distinct,
9246 -- then also set the suppress flags on the base type.
9248 if Is_First_Subtype (E) and then Etype (E) /= E then
9249 Suppress_Unsuppress_Echeck (Etype (E), C);
9251 end Suppress_Unsuppress_Echeck;
9253 -- Start of processing for Process_Suppress_Unsuppress
9256 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9257 -- on user code: we want to generate checks for analysis purposes, as
9258 -- set respectively by -gnatC and -gnatd.F
9260 if (CodePeer_Mode or GNATprove_Mode)
9261 and then Comes_From_Source (N)
9266 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9267 -- declarative part or a package spec (RM 11.5(5)).
9269 if not Is_Configuration_Pragma then
9270 Check_Is_In_Decl_Part_Or_Package_Spec;
9273 Check_At_Least_N_Arguments (1);
9274 Check_At_Most_N_Arguments (2);
9275 Check_No_Identifier (Arg1);
9276 Check_Arg_Is_Identifier (Arg1);
9278 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9280 if C = No_Check_Id then
9282 ("argument of pragma% is not valid check name", Arg1);
9285 if Arg_Count = 1 then
9287 -- Make an entry in the local scope suppress table. This is the
9288 -- table that directly shows the current value of the scope
9289 -- suppress check for any check id value.
9291 if C = All_Checks then
9293 -- For All_Checks, we set all specific predefined checks with
9294 -- the exception of Elaboration_Check, which is handled
9295 -- specially because of not wanting All_Checks to have the
9296 -- effect of deactivating static elaboration order processing.
9297 -- Atomic_Synchronization is also not affected, since this is
9298 -- not a real check.
9300 for J in Scope_Suppress.Suppress'Range loop
9301 if J /= Elaboration_Check
9303 J /= Atomic_Synchronization
9305 Scope_Suppress.Suppress (J) := Suppress_Case;
9309 -- If not All_Checks, and predefined check, then set appropriate
9310 -- scope entry. Note that we will set Elaboration_Check if this
9311 -- is explicitly specified. Atomic_Synchronization is allowed
9312 -- only if internally generated and entity is atomic.
9314 elsif C in Predefined_Check_Id
9315 and then (not Comes_From_Source (N)
9316 or else C /= Atomic_Synchronization)
9318 Scope_Suppress.Suppress (C) := Suppress_Case;
9321 -- Also make an entry in the Local_Entity_Suppress table
9323 Push_Local_Suppress_Stack_Entry
9326 Suppress => Suppress_Case);
9328 -- Case of two arguments present, where the check is suppressed for
9329 -- a specified entity (given as the second argument of the pragma)
9332 -- This is obsolescent in Ada 2005 mode
9334 if Ada_Version >= Ada_2005 then
9335 Check_Restriction (No_Obsolescent_Features, Arg2);
9338 Check_Optional_Identifier (Arg2, Name_On);
9339 E_Id := Get_Pragma_Arg (Arg2);
9342 if not Is_Entity_Name (E_Id) then
9344 ("second argument of pragma% must be entity name", Arg2);
9353 -- Enforce RM 11.5(7) which requires that for a pragma that
9354 -- appears within a package spec, the named entity must be
9355 -- within the package spec. We allow the package name itself
9356 -- to be mentioned since that makes sense, although it is not
9357 -- strictly allowed by 11.5(7).
9360 and then E /= Current_Scope
9361 and then Scope (E) /= Current_Scope
9364 ("entity in pragma% is not in package spec (RM 11.5(7))",
9368 -- Loop through homonyms. As noted below, in the case of a package
9369 -- spec, only homonyms within the package spec are considered.
9372 Suppress_Unsuppress_Echeck (E, C);
9374 if Is_Generic_Instance (E)
9375 and then Is_Subprogram (E)
9376 and then Present (Alias (E))
9378 Suppress_Unsuppress_Echeck (Alias (E), C);
9381 -- Move to next homonym if not aspect spec case
9383 exit when From_Aspect_Specification (N);
9387 -- If we are within a package specification, the pragma only
9388 -- applies to homonyms in the same scope.
9390 exit when In_Package_Spec
9391 and then Scope (E) /= Current_Scope;
9394 end Process_Suppress_Unsuppress;
9400 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9402 if Is_Imported (E) then
9404 ("cannot export entity& that was previously imported", Arg);
9406 elsif Present (Address_Clause (E))
9407 and then not Relaxed_RM_Semantics
9410 ("cannot export entity& that has an address clause", Arg);
9413 Set_Is_Exported (E);
9415 -- Generate a reference for entity explicitly, because the
9416 -- identifier may be overloaded and name resolution will not
9419 Generate_Reference (E, Arg);
9421 -- Deal with exporting non-library level entity
9423 if not Is_Library_Level_Entity (E) then
9425 -- Not allowed at all for subprograms
9427 if Is_Subprogram (E) then
9428 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9430 -- Otherwise set public and statically allocated
9434 Set_Is_Statically_Allocated (E);
9436 -- Warn if the corresponding W flag is set and the pragma comes
9437 -- from source. The latter may not be true e.g. on VMS where we
9438 -- expand export pragmas for exception codes associated with
9439 -- imported or exported exceptions. We do not want to generate
9440 -- a warning for something that the user did not write.
9442 if Warn_On_Export_Import
9443 and then Comes_From_Source (Arg)
9446 ("?x?& has been made static as a result of Export",
9449 ("\?x?this usage is non-standard and non-portable",
9455 if Warn_On_Export_Import and then Is_Type (E) then
9456 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9459 if Warn_On_Export_Import and Inside_A_Generic then
9461 ("all instances of& will have the same external name?x?",
9466 ----------------------------------------------
9467 -- Set_Extended_Import_Export_External_Name --
9468 ----------------------------------------------
9470 procedure Set_Extended_Import_Export_External_Name
9471 (Internal_Ent : Entity_Id;
9472 Arg_External : Node_Id)
9474 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9478 if No (Arg_External) then
9482 Check_Arg_Is_External_Name (Arg_External);
9484 if Nkind (Arg_External) = N_String_Literal then
9485 if String_Length (Strval (Arg_External)) = 0 then
9488 New_Name := Adjust_External_Name_Case (Arg_External);
9491 elsif Nkind (Arg_External) = N_Identifier then
9492 New_Name := Get_Default_External_Name (Arg_External);
9494 -- Check_Arg_Is_External_Name should let through only identifiers and
9495 -- string literals or static string expressions (which are folded to
9496 -- string literals).
9499 raise Program_Error;
9502 -- If we already have an external name set (by a prior normal Import
9503 -- or Export pragma), then the external names must match
9505 if Present (Interface_Name (Internal_Ent)) then
9507 -- Ignore mismatching names in CodePeer mode, to support some
9508 -- old compilers which would export the same procedure under
9509 -- different names, e.g:
9511 -- pragma Export_Procedure (P, "a");
9512 -- pragma Export_Procedure (P, "b");
9514 if CodePeer_Mode then
9518 Check_Matching_Internal_Names : declare
9519 S1 : constant String_Id := Strval (Old_Name);
9520 S2 : constant String_Id := Strval (New_Name);
9523 pragma No_Return (Mismatch);
9524 -- Called if names do not match
9530 procedure Mismatch is
9532 Error_Msg_Sloc := Sloc (Old_Name);
9534 ("external name does not match that given #",
9538 -- Start of processing for Check_Matching_Internal_Names
9541 if String_Length (S1) /= String_Length (S2) then
9545 for J in 1 .. String_Length (S1) loop
9546 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9551 end Check_Matching_Internal_Names;
9553 -- Otherwise set the given name
9556 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9557 Check_Duplicated_Export_Name (New_Name);
9559 end Set_Extended_Import_Export_External_Name;
9565 procedure Set_Imported (E : Entity_Id) is
9567 -- Error message if already imported or exported
9569 if Is_Exported (E) or else Is_Imported (E) then
9571 -- Error if being set Exported twice
9573 if Is_Exported (E) then
9574 Error_Msg_NE ("entity& was previously exported", N, E);
9576 -- Ignore error in CodePeer mode where we treat all imported
9577 -- subprograms as unknown.
9579 elsif CodePeer_Mode then
9582 -- OK if Import/Interface case
9584 elsif Import_Interface_Present (N) then
9587 -- Error if being set Imported twice
9590 Error_Msg_NE ("entity& was previously imported", N, E);
9593 Error_Msg_Name_1 := Pname;
9595 ("\(pragma% applies to all previous entities)", N);
9597 Error_Msg_Sloc := Sloc (E);
9598 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9600 -- Here if not previously imported or exported, OK to import
9603 Set_Is_Imported (E);
9605 -- For subprogram, set Import_Pragma field
9607 if Is_Subprogram (E) then
9608 Set_Import_Pragma (E, N);
9611 -- If the entity is an object that is not at the library level,
9612 -- then it is statically allocated. We do not worry about objects
9613 -- with address clauses in this context since they are not really
9614 -- imported in the linker sense.
9617 and then not Is_Library_Level_Entity (E)
9618 and then No (Address_Clause (E))
9620 Set_Is_Statically_Allocated (E);
9627 -------------------------
9628 -- Set_Mechanism_Value --
9629 -------------------------
9631 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9632 -- analyzed, since it is semantic nonsense), so we get it in the exact
9633 -- form created by the parser.
9635 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9638 Mech_Name_Id : Name_Id;
9640 procedure Bad_Class;
9641 pragma No_Return (Bad_Class);
9642 -- Signal bad descriptor class name
9644 procedure Bad_Mechanism;
9645 pragma No_Return (Bad_Mechanism);
9646 -- Signal bad mechanism name
9652 procedure Bad_Class is
9654 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
9657 -------------------------
9658 -- Bad_Mechanism_Value --
9659 -------------------------
9661 procedure Bad_Mechanism is
9663 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9666 -- Start of processing for Set_Mechanism_Value
9669 if Mechanism (Ent) /= Default_Mechanism then
9671 ("mechanism for & has already been set", Mech_Name, Ent);
9674 -- MECHANISM_NAME ::= value | reference | descriptor |
9677 if Nkind (Mech_Name) = N_Identifier then
9678 if Chars (Mech_Name) = Name_Value then
9679 Set_Mechanism (Ent, By_Copy);
9682 elsif Chars (Mech_Name) = Name_Reference then
9683 Set_Mechanism (Ent, By_Reference);
9686 elsif Chars (Mech_Name) = Name_Descriptor then
9687 Check_VMS (Mech_Name);
9689 -- Descriptor => Short_Descriptor if pragma was given
9691 if Short_Descriptors then
9692 Set_Mechanism (Ent, By_Short_Descriptor);
9694 Set_Mechanism (Ent, By_Descriptor);
9699 elsif Chars (Mech_Name) = Name_Short_Descriptor then
9700 Check_VMS (Mech_Name);
9701 Set_Mechanism (Ent, By_Short_Descriptor);
9704 elsif Chars (Mech_Name) = Name_Copy then
9706 ("bad mechanism name, Value assumed", Mech_Name);
9712 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
9713 -- short_descriptor (CLASS_NAME)
9714 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9716 -- Note: this form is parsed as an indexed component
9718 elsif Nkind (Mech_Name) = N_Indexed_Component then
9719 Class := First (Expressions (Mech_Name));
9721 if Nkind (Prefix (Mech_Name)) /= N_Identifier
9723 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
9724 Name_Short_Descriptor)
9725 or else Present (Next (Class))
9729 Mech_Name_Id := Chars (Prefix (Mech_Name));
9731 -- Change Descriptor => Short_Descriptor if pragma was given
9733 if Mech_Name_Id = Name_Descriptor
9734 and then Short_Descriptors
9736 Mech_Name_Id := Name_Short_Descriptor;
9740 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
9741 -- short_descriptor (Class => CLASS_NAME)
9742 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9744 -- Note: this form is parsed as a function call
9746 elsif Nkind (Mech_Name) = N_Function_Call then
9747 Param := First (Parameter_Associations (Mech_Name));
9749 if Nkind (Name (Mech_Name)) /= N_Identifier
9751 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
9752 Name_Short_Descriptor)
9753 or else Present (Next (Param))
9754 or else No (Selector_Name (Param))
9755 or else Chars (Selector_Name (Param)) /= Name_Class
9759 Class := Explicit_Actual_Parameter (Param);
9760 Mech_Name_Id := Chars (Name (Mech_Name));
9767 -- Fall through here with Class set to descriptor class name
9769 Check_VMS (Mech_Name);
9771 if Nkind (Class) /= N_Identifier then
9774 elsif Mech_Name_Id = Name_Descriptor
9775 and then Chars (Class) = Name_UBS
9777 Set_Mechanism (Ent, By_Descriptor_UBS);
9779 elsif Mech_Name_Id = Name_Descriptor
9780 and then Chars (Class) = Name_UBSB
9782 Set_Mechanism (Ent, By_Descriptor_UBSB);
9784 elsif Mech_Name_Id = Name_Descriptor
9785 and then Chars (Class) = Name_UBA
9787 Set_Mechanism (Ent, By_Descriptor_UBA);
9789 elsif Mech_Name_Id = Name_Descriptor
9790 and then Chars (Class) = Name_S
9792 Set_Mechanism (Ent, By_Descriptor_S);
9794 elsif Mech_Name_Id = Name_Descriptor
9795 and then Chars (Class) = Name_SB
9797 Set_Mechanism (Ent, By_Descriptor_SB);
9799 elsif Mech_Name_Id = Name_Descriptor
9800 and then Chars (Class) = Name_A
9802 Set_Mechanism (Ent, By_Descriptor_A);
9804 elsif Mech_Name_Id = Name_Descriptor
9805 and then Chars (Class) = Name_NCA
9807 Set_Mechanism (Ent, By_Descriptor_NCA);
9809 elsif Mech_Name_Id = Name_Short_Descriptor
9810 and then Chars (Class) = Name_UBS
9812 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
9814 elsif Mech_Name_Id = Name_Short_Descriptor
9815 and then Chars (Class) = Name_UBSB
9817 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
9819 elsif Mech_Name_Id = Name_Short_Descriptor
9820 and then Chars (Class) = Name_UBA
9822 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
9824 elsif Mech_Name_Id = Name_Short_Descriptor
9825 and then Chars (Class) = Name_S
9827 Set_Mechanism (Ent, By_Short_Descriptor_S);
9829 elsif Mech_Name_Id = Name_Short_Descriptor
9830 and then Chars (Class) = Name_SB
9832 Set_Mechanism (Ent, By_Short_Descriptor_SB);
9834 elsif Mech_Name_Id = Name_Short_Descriptor
9835 and then Chars (Class) = Name_A
9837 Set_Mechanism (Ent, By_Short_Descriptor_A);
9839 elsif Mech_Name_Id = Name_Short_Descriptor
9840 and then Chars (Class) = Name_NCA
9842 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
9847 end Set_Mechanism_Value;
9849 --------------------------
9850 -- Set_Rational_Profile --
9851 --------------------------
9853 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9854 -- and extension to the semantics of renaming declarations.
9856 procedure Set_Rational_Profile is
9858 Implicit_Packing := True;
9859 Overriding_Renamings := True;
9860 Use_VADS_Size := True;
9861 end Set_Rational_Profile;
9863 ---------------------------
9864 -- Set_Ravenscar_Profile --
9865 ---------------------------
9867 -- The tasks to be done here are
9869 -- Set required policies
9871 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9872 -- pragma Locking_Policy (Ceiling_Locking)
9874 -- Set Detect_Blocking mode
9876 -- Set required restrictions (see System.Rident for detailed list)
9878 -- Set the No_Dependence rules
9879 -- No_Dependence => Ada.Asynchronous_Task_Control
9880 -- No_Dependence => Ada.Calendar
9881 -- No_Dependence => Ada.Execution_Time.Group_Budget
9882 -- No_Dependence => Ada.Execution_Time.Timers
9883 -- No_Dependence => Ada.Task_Attributes
9884 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9886 procedure Set_Ravenscar_Profile (N : Node_Id) is
9887 Prefix_Entity : Entity_Id;
9888 Selector_Entity : Entity_Id;
9889 Prefix_Node : Node_Id;
9893 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9895 if Task_Dispatching_Policy /= ' '
9896 and then Task_Dispatching_Policy /= 'F'
9898 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9899 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9901 -- Set the FIFO_Within_Priorities policy, but always preserve
9902 -- System_Location since we like the error message with the run time
9906 Task_Dispatching_Policy := 'F';
9908 if Task_Dispatching_Policy_Sloc /= System_Location then
9909 Task_Dispatching_Policy_Sloc := Loc;
9913 -- pragma Locking_Policy (Ceiling_Locking)
9915 if Locking_Policy /= ' '
9916 and then Locking_Policy /= 'C'
9918 Error_Msg_Sloc := Locking_Policy_Sloc;
9919 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
9921 -- Set the Ceiling_Locking policy, but preserve System_Location since
9922 -- we like the error message with the run time name.
9925 Locking_Policy := 'C';
9927 if Locking_Policy_Sloc /= System_Location then
9928 Locking_Policy_Sloc := Loc;
9932 -- pragma Detect_Blocking
9934 Detect_Blocking := True;
9936 -- Set the corresponding restrictions
9938 Set_Profile_Restrictions
9939 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
9941 -- Set the No_Dependence restrictions
9943 -- The following No_Dependence restrictions:
9944 -- No_Dependence => Ada.Asynchronous_Task_Control
9945 -- No_Dependence => Ada.Calendar
9946 -- No_Dependence => Ada.Task_Attributes
9947 -- are already set by previous call to Set_Profile_Restrictions.
9949 -- Set the following restrictions which were added to Ada 2005:
9950 -- No_Dependence => Ada.Execution_Time.Group_Budget
9951 -- No_Dependence => Ada.Execution_Time.Timers
9953 if Ada_Version >= Ada_2005 then
9954 Name_Buffer (1 .. 3) := "ada";
9957 Prefix_Entity := Make_Identifier (Loc, Name_Find);
9959 Name_Buffer (1 .. 14) := "execution_time";
9962 Selector_Entity := Make_Identifier (Loc, Name_Find);
9965 Make_Selected_Component
9967 Prefix => Prefix_Entity,
9968 Selector_Name => Selector_Entity);
9970 Name_Buffer (1 .. 13) := "group_budgets";
9973 Selector_Entity := Make_Identifier (Loc, Name_Find);
9976 Make_Selected_Component
9978 Prefix => Prefix_Node,
9979 Selector_Name => Selector_Entity);
9981 Set_Restriction_No_Dependence
9983 Warn => Treat_Restrictions_As_Warnings,
9984 Profile => Ravenscar);
9986 Name_Buffer (1 .. 6) := "timers";
9989 Selector_Entity := Make_Identifier (Loc, Name_Find);
9992 Make_Selected_Component
9994 Prefix => Prefix_Node,
9995 Selector_Name => Selector_Entity);
9997 Set_Restriction_No_Dependence
9999 Warn => Treat_Restrictions_As_Warnings,
10000 Profile => Ravenscar);
10003 -- Set the following restrictions which was added to Ada 2012 (see
10005 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10007 if Ada_Version >= Ada_2012 then
10008 Name_Buffer (1 .. 6) := "system";
10011 Prefix_Entity := Make_Identifier (Loc, Name_Find);
10013 Name_Buffer (1 .. 15) := "multiprocessors";
10016 Selector_Entity := Make_Identifier (Loc, Name_Find);
10019 Make_Selected_Component
10021 Prefix => Prefix_Entity,
10022 Selector_Name => Selector_Entity);
10024 Name_Buffer (1 .. 19) := "dispatching_domains";
10027 Selector_Entity := Make_Identifier (Loc, Name_Find);
10030 Make_Selected_Component
10032 Prefix => Prefix_Node,
10033 Selector_Name => Selector_Entity);
10035 Set_Restriction_No_Dependence
10037 Warn => Treat_Restrictions_As_Warnings,
10038 Profile => Ravenscar);
10040 end Set_Ravenscar_Profile;
10042 -- Start of processing for Analyze_Pragma
10045 -- The following code is a defense against recursion. Not clear that
10046 -- this can happen legitimately, but perhaps some error situations
10047 -- can cause it, and we did see this recursion during testing.
10049 if Analyzed (N) then
10052 Set_Analyzed (N, True);
10055 -- Deal with unrecognized pragma
10057 Pname := Pragma_Name (N);
10059 if not Is_Pragma_Name (Pname) then
10060 if Warn_On_Unrecognized_Pragma then
10061 Error_Msg_Name_1 := Pname;
10062 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10064 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10065 if Is_Bad_Spelling_Of (Pname, PN) then
10066 Error_Msg_Name_1 := PN;
10067 Error_Msg_N -- CODEFIX
10068 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10077 -- Here to start processing for recognized pragma
10079 Prag_Id := Get_Pragma_Id (Pname);
10080 Pname := Original_Aspect_Name (N);
10082 -- Capture setting of Opt.Uneval_Old
10084 case Opt.Uneval_Old is
10086 Set_Uneval_Old_Accept (N);
10090 Set_Uneval_Old_Warn (N);
10092 raise Program_Error;
10095 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10096 -- is already set, indicating that we have already checked the policy
10097 -- at the right point. This happens for example in the case of a pragma
10098 -- that is derived from an Aspect.
10100 if Is_Ignored (N) or else Is_Checked (N) then
10103 -- For a pragma that is a rewriting of another pragma, copy the
10104 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10106 elsif Is_Rewrite_Substitution (N)
10107 and then Nkind (Original_Node (N)) = N_Pragma
10108 and then Original_Node (N) /= N
10110 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10111 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10113 -- Otherwise query the applicable policy at this point
10116 Check_Applicable_Policy (N);
10118 -- If pragma is disabled, rewrite as NULL and skip analysis
10120 if Is_Disabled (N) then
10121 Rewrite (N, Make_Null_Statement (Loc));
10127 -- Preset arguments
10135 if Present (Pragma_Argument_Associations (N)) then
10136 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10137 Arg1 := First (Pragma_Argument_Associations (N));
10139 if Present (Arg1) then
10140 Arg2 := Next (Arg1);
10142 if Present (Arg2) then
10143 Arg3 := Next (Arg2);
10145 if Present (Arg3) then
10146 Arg4 := Next (Arg3);
10152 Check_Restriction_No_Use_Of_Pragma (N);
10154 -- An enumeration type defines the pragmas that are supported by the
10155 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10156 -- into the corresponding enumeration value for the following case.
10164 -- pragma Abort_Defer;
10166 when Pragma_Abort_Defer =>
10168 Check_Arg_Count (0);
10170 -- The only required semantic processing is to check the
10171 -- placement. This pragma must appear at the start of the
10172 -- statement sequence of a handled sequence of statements.
10174 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10175 or else N /= First (Statements (Parent (N)))
10180 --------------------
10181 -- Abstract_State --
10182 --------------------
10184 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10186 -- ABSTRACT_STATE_LIST ::=
10188 -- | STATE_NAME_WITH_OPTIONS
10189 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
10191 -- STATE_NAME_WITH_OPTIONS ::=
10193 -- | (STATE_NAME with OPTION_LIST)
10195 -- OPTION_LIST ::= OPTION {, OPTION}
10199 -- | NAME_VALUE_OPTION
10201 -- SIMPLE_OPTION ::= identifier
10203 -- NAME_VALUE_OPTION ::=
10204 -- Part_Of => ABSTRACT_STATE
10205 -- | External [=> EXTERNAL_PROPERTY_LIST]
10207 -- EXTERNAL_PROPERTY_LIST ::=
10208 -- EXTERNAL_PROPERTY
10209 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
10211 -- EXTERNAL_PROPERTY ::=
10212 -- Async_Readers [=> boolean_EXPRESSION]
10213 -- | Async_Writers [=> boolean_EXPRESSION]
10214 -- | Effective_Reads [=> boolean_EXPRESSION]
10215 -- | Effective_Writes [=> boolean_EXPRESSION]
10216 -- others => boolean_EXPRESSION
10218 -- STATE_NAME ::= defining_identifier
10220 -- ABSTRACT_STATE ::= name
10222 when Pragma_Abstract_State => Abstract_State : declare
10223 Missing_Parentheses : Boolean := False;
10224 -- Flag set when a state declaration with options is not properly
10227 -- Flags used to verify the consistency of states
10229 Non_Null_Seen : Boolean := False;
10230 Null_Seen : Boolean := False;
10232 Pack_Id : Entity_Id;
10233 -- Entity of related package when pragma Abstract_State appears
10235 procedure Analyze_Abstract_State (State : Node_Id);
10236 -- Verify the legality of a single state declaration. Create and
10237 -- decorate a state abstraction entity and introduce it into the
10238 -- visibility chain.
10240 ----------------------------
10241 -- Analyze_Abstract_State --
10242 ----------------------------
10244 procedure Analyze_Abstract_State (State : Node_Id) is
10246 -- Flags used to verify the consistency of options
10248 AR_Seen : Boolean := False;
10249 AW_Seen : Boolean := False;
10250 ER_Seen : Boolean := False;
10251 EW_Seen : Boolean := False;
10252 External_Seen : Boolean := False;
10253 Others_Seen : Boolean := False;
10254 Part_Of_Seen : Boolean := False;
10256 -- Flags used to store the static value of all external states'
10259 AR_Val : Boolean := False;
10260 AW_Val : Boolean := False;
10261 ER_Val : Boolean := False;
10262 EW_Val : Boolean := False;
10264 State_Id : Entity_Id := Empty;
10265 -- The entity to be generated for the current state declaration
10267 procedure Analyze_External_Option (Opt : Node_Id);
10268 -- Verify the legality of option External
10270 procedure Analyze_External_Property
10272 Expr : Node_Id := Empty);
10273 -- Verify the legailty of a single external property. Prop
10274 -- denotes the external property. Expr is the expression used
10275 -- to set the property.
10277 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10278 -- Verify the legality of option Part_Of
10280 procedure Check_Duplicate_Option
10282 Status : in out Boolean);
10283 -- Flag Status denotes whether a particular option has been
10284 -- seen while processing a state. This routine verifies that
10285 -- Opt is not a duplicate option and sets the flag Status
10286 -- (SPARK RM 7.1.4(1)).
10288 procedure Check_Duplicate_Property
10290 Status : in out Boolean);
10291 -- Flag Status denotes whether a particular property has been
10292 -- seen while processing option External. This routine verifies
10293 -- that Prop is not a duplicate property and sets flag Status.
10294 -- Opt is not a duplicate property and sets the flag Status.
10295 -- (SPARK RM 7.1.4(2))
10297 procedure Create_Abstract_State
10301 Is_Null : Boolean);
10302 -- Generate an abstract state entity with name Nam and enter it
10303 -- into visibility. Decl is the "declaration" of the state as
10304 -- it appears in pragma Abstract_State. Loc is the location of
10305 -- the related state "declaration". Flag Is_Null should be set
10306 -- when the associated Abstract_State pragma defines a null
10309 -----------------------------
10310 -- Analyze_External_Option --
10311 -----------------------------
10313 procedure Analyze_External_Option (Opt : Node_Id) is
10314 Errors : constant Nat := Serious_Errors_Detected;
10316 Props : Node_Id := Empty;
10319 Check_Duplicate_Option (Opt, External_Seen);
10321 if Nkind (Opt) = N_Component_Association then
10322 Props := Expression (Opt);
10325 -- External state with properties
10327 if Present (Props) then
10329 -- Multiple properties appear as an aggregate
10331 if Nkind (Props) = N_Aggregate then
10333 -- Simple property form
10335 Prop := First (Expressions (Props));
10336 while Present (Prop) loop
10337 Analyze_External_Property (Prop);
10341 -- Property with expression form
10343 Prop := First (Component_Associations (Props));
10344 while Present (Prop) loop
10345 Analyze_External_Property
10346 (Prop => First (Choices (Prop)),
10347 Expr => Expression (Prop));
10355 Analyze_External_Property (Props);
10358 -- An external state defined without any properties defaults
10359 -- all properties to True.
10368 -- Once all external properties have been processed, verify
10369 -- their mutual interaction. Do not perform the check when
10370 -- at least one of the properties is illegal as this will
10371 -- produce a bogus error.
10373 if Errors = Serious_Errors_Detected then
10374 Check_External_Properties
10375 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10377 end Analyze_External_Option;
10379 -------------------------------
10380 -- Analyze_External_Property --
10381 -------------------------------
10383 procedure Analyze_External_Property
10385 Expr : Node_Id := Empty)
10387 Expr_Val : Boolean;
10390 -- Check the placement of "others" (if available)
10392 if Nkind (Prop) = N_Others_Choice then
10393 if Others_Seen then
10395 ("only one others choice allowed in option External",
10398 Others_Seen := True;
10401 elsif Others_Seen then
10403 ("others must be the last property in option External",
10406 -- The only remaining legal options are the four predefined
10407 -- external properties.
10409 elsif Nkind (Prop) = N_Identifier
10410 and then Nam_In (Chars (Prop), Name_Async_Readers,
10411 Name_Async_Writers,
10412 Name_Effective_Reads,
10413 Name_Effective_Writes)
10417 -- Otherwise the construct is not a valid property
10420 SPARK_Msg_N ("invalid external state property", Prop);
10424 -- Ensure that the expression of the external state property
10425 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10427 if Present (Expr) then
10428 Analyze_And_Resolve (Expr, Standard_Boolean);
10430 if Is_OK_Static_Expression (Expr) then
10431 Expr_Val := Is_True (Expr_Value (Expr));
10434 ("expression of external state property must be "
10438 -- The lack of expression defaults the property to True
10444 -- Named properties
10446 if Nkind (Prop) = N_Identifier then
10447 if Chars (Prop) = Name_Async_Readers then
10448 Check_Duplicate_Property (Prop, AR_Seen);
10449 AR_Val := Expr_Val;
10451 elsif Chars (Prop) = Name_Async_Writers then
10452 Check_Duplicate_Property (Prop, AW_Seen);
10453 AW_Val := Expr_Val;
10455 elsif Chars (Prop) = Name_Effective_Reads then
10456 Check_Duplicate_Property (Prop, ER_Seen);
10457 ER_Val := Expr_Val;
10460 Check_Duplicate_Property (Prop, EW_Seen);
10461 EW_Val := Expr_Val;
10464 -- The handling of property "others" must take into account
10465 -- all other named properties that have been encountered so
10466 -- far. Only those that have not been seen are affected by
10470 if not AR_Seen then
10471 AR_Val := Expr_Val;
10474 if not AW_Seen then
10475 AW_Val := Expr_Val;
10478 if not ER_Seen then
10479 ER_Val := Expr_Val;
10482 if not EW_Seen then
10483 EW_Val := Expr_Val;
10486 end Analyze_External_Property;
10488 ----------------------------
10489 -- Analyze_Part_Of_Option --
10490 ----------------------------
10492 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10493 Encaps : constant Node_Id := Expression (Opt);
10494 Encaps_Id : Entity_Id;
10498 Check_Duplicate_Option (Opt, Part_Of_Seen);
10501 (Item_Id => State_Id,
10503 Indic => First (Choices (Opt)),
10506 -- The Part_Of indicator turns an abstract state into a
10507 -- constituent of the encapsulating state.
10510 Encaps_Id := Entity (Encaps);
10512 Append_Elmt (State_Id, Part_Of_Constituents (Encaps_Id));
10513 Set_Encapsulating_State (State_Id, Encaps_Id);
10515 end Analyze_Part_Of_Option;
10517 ----------------------------
10518 -- Check_Duplicate_Option --
10519 ----------------------------
10521 procedure Check_Duplicate_Option
10523 Status : in out Boolean)
10527 SPARK_Msg_N ("duplicate state option", Opt);
10531 end Check_Duplicate_Option;
10533 ------------------------------
10534 -- Check_Duplicate_Property --
10535 ------------------------------
10537 procedure Check_Duplicate_Property
10539 Status : in out Boolean)
10543 SPARK_Msg_N ("duplicate external property", Prop);
10547 end Check_Duplicate_Property;
10549 ---------------------------
10550 -- Create_Abstract_State --
10551 ---------------------------
10553 procedure Create_Abstract_State
10560 -- The abstract state may be semi-declared when the related
10561 -- package was withed through a limited with clause. In that
10562 -- case reuse the entity to fully declare the state.
10564 if Present (Decl) and then Present (Entity (Decl)) then
10565 State_Id := Entity (Decl);
10567 -- Otherwise the elaboration of pragma Abstract_State
10568 -- declares the state.
10571 State_Id := Make_Defining_Identifier (Loc, Nam);
10573 if Present (Decl) then
10574 Set_Entity (Decl, State_Id);
10578 -- Null states never come from source
10580 Set_Comes_From_Source (State_Id, not Is_Null);
10581 Set_Parent (State_Id, State);
10582 Set_Ekind (State_Id, E_Abstract_State);
10583 Set_Etype (State_Id, Standard_Void_Type);
10584 Set_Encapsulating_State (State_Id, Empty);
10585 Set_Refinement_Constituents (State_Id, New_Elmt_List);
10586 Set_Part_Of_Constituents (State_Id, New_Elmt_List);
10588 -- Establish a link between the state declaration and the
10589 -- abstract state entity. Note that a null state remains as
10590 -- N_Null and does not carry any linkages.
10592 if not Is_Null then
10593 if Present (Decl) then
10594 Set_Entity (Decl, State_Id);
10595 Set_Etype (Decl, Standard_Void_Type);
10598 -- Every non-null state must be defined, nameable and
10601 Push_Scope (Pack_Id);
10602 Generate_Definition (State_Id);
10603 Enter_Name (State_Id);
10606 end Create_Abstract_State;
10613 -- Start of processing for Analyze_Abstract_State
10616 -- A package with a null abstract state is not allowed to
10617 -- declare additional states.
10621 ("package & has null abstract state", State, Pack_Id);
10623 -- Null states appear as internally generated entities
10625 elsif Nkind (State) = N_Null then
10626 Create_Abstract_State
10627 (Nam => New_Internal_Name ('S'),
10629 Loc => Sloc (State),
10633 -- Catch a case where a null state appears in a list of
10634 -- non-null states.
10636 if Non_Null_Seen then
10638 ("package & has non-null abstract state",
10642 -- Simple state declaration
10644 elsif Nkind (State) = N_Identifier then
10645 Create_Abstract_State
10646 (Nam => Chars (State),
10648 Loc => Sloc (State),
10650 Non_Null_Seen := True;
10652 -- State declaration with various options. This construct
10653 -- appears as an extension aggregate in the tree.
10655 elsif Nkind (State) = N_Extension_Aggregate then
10656 if Nkind (Ancestor_Part (State)) = N_Identifier then
10657 Create_Abstract_State
10658 (Nam => Chars (Ancestor_Part (State)),
10659 Decl => Ancestor_Part (State),
10660 Loc => Sloc (Ancestor_Part (State)),
10662 Non_Null_Seen := True;
10665 ("state name must be an identifier",
10666 Ancestor_Part (State));
10669 -- Catch an attempt to introduce a simple option which is
10670 -- currently not allowed. An exception to this is External
10671 -- defined without any properties.
10673 Opt := First (Expressions (State));
10674 while Present (Opt) loop
10675 if Nkind (Opt) = N_Identifier then
10676 if Chars (Opt) = Name_External then
10677 Analyze_External_Option (Opt);
10679 -- Option Part_Of without an encapsulating state is
10680 -- illegal. (SPARK RM 7.1.4(9)).
10682 elsif Chars (Opt) = Name_Part_Of then
10684 ("indicator Part_Of must denote an abstract "
10687 -- Do not emit an error message when a previous state
10688 -- declaration with options was not parenthesized as
10689 -- the option is actually another state declaration.
10691 -- with Abstract_State
10692 -- (State_1 with ..., -- missing parentheses
10693 -- (State_2 with ...),
10694 -- State_3) -- ok state declaration
10696 elsif Missing_Parentheses then
10699 -- Otherwise the option is not allowed. Note that it
10700 -- is not possible to distinguish between an option
10701 -- and a state declaration when a previous state with
10702 -- options not properly parentheses.
10704 -- with Abstract_State
10705 -- (State_1 with ..., -- missing parentheses
10706 -- State_2); -- could be an option
10710 ("simple option not allowed in state declaration",
10714 -- Catch a case where missing parentheses around a state
10715 -- declaration with options cause a subsequent state
10716 -- declaration with options to be treated as an option.
10718 -- with Abstract_State
10719 -- (State_1 with ..., -- missing parentheses
10720 -- (State_2 with ...))
10722 elsif Nkind (Opt) = N_Extension_Aggregate then
10723 Missing_Parentheses := True;
10725 ("state declaration must be parenthesized",
10726 Ancestor_Part (State));
10728 -- Otherwise the option is malformed
10731 SPARK_Msg_N ("malformed option", Opt);
10737 -- Options External and Part_Of appear as component
10740 Opt := First (Component_Associations (State));
10741 while Present (Opt) loop
10742 Opt_Nam := First (Choices (Opt));
10744 if Nkind (Opt_Nam) = N_Identifier then
10745 if Chars (Opt_Nam) = Name_External then
10746 Analyze_External_Option (Opt);
10748 elsif Chars (Opt_Nam) = Name_Part_Of then
10749 Analyze_Part_Of_Option (Opt);
10752 SPARK_Msg_N ("invalid state option", Opt);
10755 SPARK_Msg_N ("invalid state option", Opt);
10761 -- Any other attempt to declare a state is illegal. This is a
10762 -- syntax error, always report.
10765 Error_Msg_N ("malformed abstract state declaration", State);
10769 -- Guard against a junk state. In such cases no entity is
10770 -- generated and the subsequent checks cannot be applied.
10772 if Present (State_Id) then
10774 -- Verify whether the state does not introduce an illegal
10775 -- hidden state within a package subject to a null abstract
10778 Check_No_Hidden_State (State_Id);
10780 -- Check whether the lack of option Part_Of agrees with the
10781 -- placement of the abstract state with respect to the state
10784 if not Part_Of_Seen then
10785 Check_Missing_Part_Of (State_Id);
10788 -- Associate the state with its related package
10790 if No (Abstract_States (Pack_Id)) then
10791 Set_Abstract_States (Pack_Id, New_Elmt_List);
10794 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10796 end Analyze_Abstract_State;
10800 Context : constant Node_Id := Parent (Parent (N));
10803 -- Start of processing for Abstract_State
10807 Check_Arg_Count (1);
10808 Ensure_Aggregate_Form (Arg1);
10810 -- Ensure the proper placement of the pragma. Abstract states must
10811 -- be associated with a package declaration.
10813 if not Nkind_In (Context, N_Generic_Package_Declaration,
10814 N_Package_Declaration)
10820 State := Expression (Arg1);
10821 Pack_Id := Defining_Entity (Context);
10823 -- Multiple non-null abstract states appear as an aggregate
10825 if Nkind (State) = N_Aggregate then
10826 State := First (Expressions (State));
10827 while Present (State) loop
10828 Analyze_Abstract_State (State);
10832 -- Various forms of a single abstract state. Note that these may
10833 -- include malformed state declarations.
10836 Analyze_Abstract_State (State);
10839 -- Save the pragma for retrieval by other tools
10841 Add_Contract_Item (N, Pack_Id);
10843 -- Verify the declaration order of pragmas Abstract_State and
10846 Check_Declaration_Order
10848 Second => Get_Pragma (Pack_Id, Pragma_Initializes));
10849 end Abstract_State;
10857 -- Note: this pragma also has some specific processing in Par.Prag
10858 -- because we want to set the Ada version mode during parsing.
10860 when Pragma_Ada_83 =>
10862 Check_Arg_Count (0);
10864 -- We really should check unconditionally for proper configuration
10865 -- pragma placement, since we really don't want mixed Ada modes
10866 -- within a single unit, and the GNAT reference manual has always
10867 -- said this was a configuration pragma, but we did not check and
10868 -- are hesitant to add the check now.
10870 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10871 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10872 -- or Ada 2012 mode.
10874 if Ada_Version >= Ada_2005 then
10875 Check_Valid_Configuration_Pragma;
10878 -- Now set Ada 83 mode
10880 Ada_Version := Ada_83;
10881 Ada_Version_Explicit := Ada_83;
10882 Ada_Version_Pragma := N;
10890 -- Note: this pragma also has some specific processing in Par.Prag
10891 -- because we want to set the Ada 83 version mode during parsing.
10893 when Pragma_Ada_95 =>
10895 Check_Arg_Count (0);
10897 -- We really should check unconditionally for proper configuration
10898 -- pragma placement, since we really don't want mixed Ada modes
10899 -- within a single unit, and the GNAT reference manual has always
10900 -- said this was a configuration pragma, but we did not check and
10901 -- are hesitant to add the check now.
10903 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10904 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10906 if Ada_Version >= Ada_2005 then
10907 Check_Valid_Configuration_Pragma;
10910 -- Now set Ada 95 mode
10912 Ada_Version := Ada_95;
10913 Ada_Version_Explicit := Ada_95;
10914 Ada_Version_Pragma := N;
10916 ---------------------
10917 -- Ada_05/Ada_2005 --
10918 ---------------------
10921 -- pragma Ada_05 (LOCAL_NAME);
10923 -- pragma Ada_2005;
10924 -- pragma Ada_2005 (LOCAL_NAME):
10926 -- Note: these pragmas also have some specific processing in Par.Prag
10927 -- because we want to set the Ada 2005 version mode during parsing.
10929 -- The one argument form is used for managing the transition from
10930 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10931 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10932 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10933 -- mode, a preference rule is established which does not choose
10934 -- such an entity unless it is unambiguously specified. This avoids
10935 -- extra subprograms marked this way from generating ambiguities in
10936 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10937 -- intended for exclusive use in the GNAT run-time library.
10939 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
10945 if Arg_Count = 1 then
10946 Check_Arg_Is_Local_Name (Arg1);
10947 E_Id := Get_Pragma_Arg (Arg1);
10949 if Etype (E_Id) = Any_Type then
10953 Set_Is_Ada_2005_Only (Entity (E_Id));
10954 Record_Rep_Item (Entity (E_Id), N);
10957 Check_Arg_Count (0);
10959 -- For Ada_2005 we unconditionally enforce the documented
10960 -- configuration pragma placement, since we do not want to
10961 -- tolerate mixed modes in a unit involving Ada 2005. That
10962 -- would cause real difficulties for those cases where there
10963 -- are incompatibilities between Ada 95 and Ada 2005.
10965 Check_Valid_Configuration_Pragma;
10967 -- Now set appropriate Ada mode
10969 Ada_Version := Ada_2005;
10970 Ada_Version_Explicit := Ada_2005;
10971 Ada_Version_Pragma := N;
10975 ---------------------
10976 -- Ada_12/Ada_2012 --
10977 ---------------------
10980 -- pragma Ada_12 (LOCAL_NAME);
10982 -- pragma Ada_2012;
10983 -- pragma Ada_2012 (LOCAL_NAME):
10985 -- Note: these pragmas also have some specific processing in Par.Prag
10986 -- because we want to set the Ada 2012 version mode during parsing.
10988 -- The one argument form is used for managing the transition from Ada
10989 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10990 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10991 -- mode will generate a warning. In addition, in any pre-Ada_2012
10992 -- mode, a preference rule is established which does not choose
10993 -- such an entity unless it is unambiguously specified. This avoids
10994 -- extra subprograms marked this way from generating ambiguities in
10995 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10996 -- intended for exclusive use in the GNAT run-time library.
10998 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11004 if Arg_Count = 1 then
11005 Check_Arg_Is_Local_Name (Arg1);
11006 E_Id := Get_Pragma_Arg (Arg1);
11008 if Etype (E_Id) = Any_Type then
11012 Set_Is_Ada_2012_Only (Entity (E_Id));
11013 Record_Rep_Item (Entity (E_Id), N);
11016 Check_Arg_Count (0);
11018 -- For Ada_2012 we unconditionally enforce the documented
11019 -- configuration pragma placement, since we do not want to
11020 -- tolerate mixed modes in a unit involving Ada 2012. That
11021 -- would cause real difficulties for those cases where there
11022 -- are incompatibilities between Ada 95 and Ada 2012. We could
11023 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11025 Check_Valid_Configuration_Pragma;
11027 -- Now set appropriate Ada mode
11029 Ada_Version := Ada_2012;
11030 Ada_Version_Explicit := Ada_2012;
11031 Ada_Version_Pragma := N;
11035 ----------------------
11036 -- All_Calls_Remote --
11037 ----------------------
11039 -- pragma All_Calls_Remote [(library_package_NAME)];
11041 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11042 Lib_Entity : Entity_Id;
11045 Check_Ada_83_Warning;
11046 Check_Valid_Library_Unit_Pragma;
11048 if Nkind (N) = N_Null_Statement then
11052 Lib_Entity := Find_Lib_Unit_Name;
11054 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11056 if Present (Lib_Entity)
11057 and then not Debug_Flag_U
11059 if not Is_Remote_Call_Interface (Lib_Entity) then
11060 Error_Pragma ("pragma% only apply to rci unit");
11062 -- Set flag for entity of the library unit
11065 Set_Has_All_Calls_Remote (Lib_Entity);
11069 end All_Calls_Remote;
11071 ---------------------------
11072 -- Allow_Integer_Address --
11073 ---------------------------
11075 -- pragma Allow_Integer_Address;
11077 when Pragma_Allow_Integer_Address =>
11079 Check_Valid_Configuration_Pragma;
11080 Check_Arg_Count (0);
11082 -- If Address is a private type, then set the flag to allow
11083 -- integer address values. If Address is not private (e.g. on
11084 -- VMS, where it is an integer type), then this pragma has no
11085 -- purpose, so it is simply ignored.
11087 if Opt.Address_Is_Private then
11088 Opt.Allow_Integer_Address := True;
11096 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11097 -- ARG ::= NAME | EXPRESSION
11099 -- The first two arguments are by convention intended to refer to an
11100 -- external tool and a tool-specific function. These arguments are
11103 when Pragma_Annotate => Annotate : declare
11109 Check_At_Least_N_Arguments (1);
11111 -- See if last argument is Entity => local_Name, and if so process
11112 -- and then remove it for remaining processing.
11115 Last_Arg : constant Node_Id :=
11116 Last (Pragma_Argument_Associations (N));
11119 if Nkind (Last_Arg) = N_Pragma_Argument_Association
11120 and then Chars (Last_Arg) = Name_Entity
11122 Check_Arg_Is_Local_Name (Last_Arg);
11123 Arg_Count := Arg_Count - 1;
11125 -- Not allowed in compiler units (bootstrap issues)
11127 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11131 -- Continue processing with last argument removed for now
11133 Check_Arg_Is_Identifier (Arg1);
11134 Check_No_Identifiers;
11137 -- Second parameter is optional, it is never analyzed
11142 -- Here if we have a second parameter
11145 -- Second parameter must be identifier
11147 Check_Arg_Is_Identifier (Arg2);
11149 -- Process remaining parameters if any
11151 Arg := Next (Arg2);
11152 while Present (Arg) loop
11153 Exp := Get_Pragma_Arg (Arg);
11156 if Is_Entity_Name (Exp) then
11159 -- For string literals, we assume Standard_String as the
11160 -- type, unless the string contains wide or wide_wide
11163 elsif Nkind (Exp) = N_String_Literal then
11164 if Has_Wide_Wide_Character (Exp) then
11165 Resolve (Exp, Standard_Wide_Wide_String);
11166 elsif Has_Wide_Character (Exp) then
11167 Resolve (Exp, Standard_Wide_String);
11169 Resolve (Exp, Standard_String);
11172 elsif Is_Overloaded (Exp) then
11174 ("ambiguous argument for pragma%", Exp);
11185 -------------------------------------------------
11186 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11187 -------------------------------------------------
11190 -- ( [Check => ] Boolean_EXPRESSION
11191 -- [, [Message =>] Static_String_EXPRESSION]);
11193 -- pragma Assert_And_Cut
11194 -- ( [Check => ] Boolean_EXPRESSION
11195 -- [, [Message =>] Static_String_EXPRESSION]);
11198 -- ( [Check => ] Boolean_EXPRESSION
11199 -- [, [Message =>] Static_String_EXPRESSION]);
11201 -- pragma Loop_Invariant
11202 -- ( [Check => ] Boolean_EXPRESSION
11203 -- [, [Message =>] Static_String_EXPRESSION]);
11205 when Pragma_Assert |
11206 Pragma_Assert_And_Cut |
11208 Pragma_Loop_Invariant =>
11213 Has_Loop_Entry : Boolean;
11216 function Contains_Loop_Entry return Boolean;
11217 -- Tests if Expr contains a Loop_Entry attribute reference
11219 -------------------------
11220 -- Contains_Loop_Entry --
11221 -------------------------
11223 function Contains_Loop_Entry return Boolean is
11224 function Process (N : Node_Id) return Traverse_Result;
11225 -- Process function for traversal to look for Loop_Entry
11231 function Process (N : Node_Id) return Traverse_Result is
11233 if Nkind (N) = N_Attribute_Reference
11234 and then Attribute_Name (N) = Name_Loop_Entry
11236 Has_Loop_Entry := True;
11243 procedure Traverse is new Traverse_Proc (Process);
11245 -- Start of processing for Contains_Loop_Entry
11248 Has_Loop_Entry := False;
11250 return Has_Loop_Entry;
11251 end Contains_Loop_Entry;
11253 -- Start of processing for Assert
11256 -- Assert is an Ada 2005 RM-defined pragma
11258 if Prag_Id = Pragma_Assert then
11261 -- The remaining ones are GNAT pragmas
11267 Check_At_Least_N_Arguments (1);
11268 Check_At_Most_N_Arguments (2);
11269 Check_Arg_Order ((Name_Check, Name_Message));
11270 Check_Optional_Identifier (Arg1, Name_Check);
11271 Expr := Get_Pragma_Arg (Arg1);
11273 -- Special processing for Loop_Invariant or for other cases if
11274 -- a Loop_Entry attribute is present.
11276 if Prag_Id = Pragma_Loop_Invariant
11277 or else Contains_Loop_Entry
11279 -- Check restricted placement, must be within a loop
11281 Check_Loop_Pragma_Placement;
11283 -- Do preanalyze to deal with embedded Loop_Entry attribute
11285 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
11288 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11289 -- a corresponding Check pragma:
11291 -- pragma Check (name, condition [, msg]);
11293 -- Where name is the identifier matching the pragma name. So
11294 -- rewrite pragma in this manner, transfer the message argument
11295 -- if present, and analyze the result
11297 -- Note: When dealing with a semantically analyzed tree, the
11298 -- information that a Check node N corresponds to a source Assert,
11299 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11300 -- pragma kind of Original_Node(N).
11303 Make_Pragma_Argument_Association (Loc,
11304 Expression => Make_Identifier (Loc, Pname)),
11305 Make_Pragma_Argument_Association (Sloc (Expr),
11306 Expression => Expr));
11308 if Arg_Count > 1 then
11309 Check_Optional_Identifier (Arg2, Name_Message);
11310 Append_To (Newa, New_Copy_Tree (Arg2));
11313 -- Rewrite as Check pragma
11317 Chars => Name_Check,
11318 Pragma_Argument_Associations => Newa));
11322 ----------------------
11323 -- Assertion_Policy --
11324 ----------------------
11326 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11328 -- The following form is Ada 2012 only, but we allow it in all modes
11330 -- Pragma Assertion_Policy (
11331 -- ASSERTION_KIND => POLICY_IDENTIFIER
11332 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11334 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11336 -- RM_ASSERTION_KIND ::= Assert |
11337 -- Static_Predicate |
11338 -- Dynamic_Predicate |
11343 -- Type_Invariant |
11344 -- Type_Invariant'Class
11346 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11348 -- Contract_Cases |
11350 -- Initial_Condition |
11351 -- Loop_Invariant |
11357 -- Statement_Assertions
11359 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11360 -- ID_ASSERTION_KIND list contains implementation-defined additions
11361 -- recognized by GNAT. The effect is to control the behavior of
11362 -- identically named aspects and pragmas, depending on the specified
11363 -- policy identifier:
11365 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11367 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11368 -- implementation defined addition that results in totally ignoring
11369 -- the corresponding assertion. If Disable is specified, then the
11370 -- argument of the assertion is not even analyzed. This is useful
11371 -- when the aspect/pragma argument references entities in a with'ed
11372 -- package that is replaced by a dummy package in the final build.
11374 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11375 -- and Type_Invariant'Class were recognized by the parser and
11376 -- transformed into references to the special internal identifiers
11377 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11378 -- processing is required here.
11380 when Pragma_Assertion_Policy => Assertion_Policy : declare
11389 -- This can always appear as a configuration pragma
11391 if Is_Configuration_Pragma then
11394 -- It can also appear in a declarative part or package spec in Ada
11395 -- 2012 mode. We allow this in other modes, but in that case we
11396 -- consider that we have an Ada 2012 pragma on our hands.
11399 Check_Is_In_Decl_Part_Or_Package_Spec;
11403 -- One argument case with no identifier (first form above)
11406 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11407 or else Chars (Arg1) = No_Name)
11409 Check_Arg_Is_One_Of
11410 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11412 -- Treat one argument Assertion_Policy as equivalent to:
11414 -- pragma Check_Policy (Assertion, policy)
11416 -- So rewrite pragma in that manner and link on to the chain
11417 -- of Check_Policy pragmas, marking the pragma as analyzed.
11419 Policy := Get_Pragma_Arg (Arg1);
11423 Chars => Name_Check_Policy,
11424 Pragma_Argument_Associations => New_List (
11425 Make_Pragma_Argument_Association (Loc,
11426 Expression => Make_Identifier (Loc, Name_Assertion)),
11428 Make_Pragma_Argument_Association (Loc,
11430 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11433 -- Here if we have two or more arguments
11436 Check_At_Least_N_Arguments (1);
11439 -- Loop through arguments
11442 while Present (Arg) loop
11443 LocP := Sloc (Arg);
11445 -- Kind must be specified
11447 if Nkind (Arg) /= N_Pragma_Argument_Association
11448 or else Chars (Arg) = No_Name
11451 ("missing assertion kind for pragma%", Arg);
11454 -- Check Kind and Policy have allowed forms
11456 Kind := Chars (Arg);
11458 if not Is_Valid_Assertion_Kind (Kind) then
11460 ("invalid assertion kind for pragma%", Arg);
11463 Check_Arg_Is_One_Of
11464 (Arg, Name_Check, Name_Disable, Name_Ignore);
11466 -- We rewrite the Assertion_Policy pragma as a series of
11467 -- Check_Policy pragmas:
11469 -- Check_Policy (Kind, Policy);
11473 Chars => Name_Check_Policy,
11474 Pragma_Argument_Associations => New_List (
11475 Make_Pragma_Argument_Association (LocP,
11476 Expression => Make_Identifier (LocP, Kind)),
11477 Make_Pragma_Argument_Association (LocP,
11478 Expression => Get_Pragma_Arg (Arg)))));
11483 -- Rewrite the Assertion_Policy pragma as null since we have
11484 -- now inserted all the equivalent Check pragmas.
11486 Rewrite (N, Make_Null_Statement (Loc));
11489 end Assertion_Policy;
11491 ------------------------------
11492 -- Assume_No_Invalid_Values --
11493 ------------------------------
11495 -- pragma Assume_No_Invalid_Values (On | Off);
11497 when Pragma_Assume_No_Invalid_Values =>
11499 Check_Valid_Configuration_Pragma;
11500 Check_Arg_Count (1);
11501 Check_No_Identifiers;
11502 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11504 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11505 Assume_No_Invalid_Values := True;
11507 Assume_No_Invalid_Values := False;
11510 --------------------------
11511 -- Attribute_Definition --
11512 --------------------------
11514 -- pragma Attribute_Definition
11515 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11516 -- [Entity =>] LOCAL_NAME,
11517 -- [Expression =>] EXPRESSION | NAME);
11519 when Pragma_Attribute_Definition => Attribute_Definition : declare
11520 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11525 Check_Arg_Count (3);
11526 Check_Optional_Identifier (Arg1, "attribute");
11527 Check_Optional_Identifier (Arg2, "entity");
11528 Check_Optional_Identifier (Arg3, "expression");
11530 if Nkind (Attribute_Designator) /= N_Identifier then
11531 Error_Msg_N ("attribute name expected", Attribute_Designator);
11535 Check_Arg_Is_Local_Name (Arg2);
11537 -- If the attribute is not recognized, then issue a warning (not
11538 -- an error), and ignore the pragma.
11540 Aname := Chars (Attribute_Designator);
11542 if not Is_Attribute_Name (Aname) then
11543 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11547 -- Otherwise, rewrite the pragma as an attribute definition clause
11550 Make_Attribute_Definition_Clause (Loc,
11551 Name => Get_Pragma_Arg (Arg2),
11553 Expression => Get_Pragma_Arg (Arg3)));
11555 end Attribute_Definition;
11561 -- pragma AST_Entry (entry_IDENTIFIER);
11563 when Pragma_AST_Entry => AST_Entry : declare
11569 Check_Arg_Count (1);
11570 Check_No_Identifiers;
11571 Check_Arg_Is_Local_Name (Arg1);
11572 Ent := Entity (Get_Pragma_Arg (Arg1));
11574 -- Note: the implementation of the AST_Entry pragma could handle
11575 -- the entry family case fine, but for now we are consistent with
11576 -- the DEC rules, and do not allow the pragma, which of course
11577 -- has the effect of also forbidding the attribute.
11579 if Ekind (Ent) /= E_Entry then
11581 ("pragma% argument must be simple entry name", Arg1);
11583 elsif Is_AST_Entry (Ent) then
11585 ("duplicate % pragma for entry", Arg1);
11587 elsif Has_Homonym (Ent) then
11589 ("pragma% argument cannot specify overloaded entry", Arg1);
11593 FF : constant Entity_Id := First_Formal (Ent);
11596 if Present (FF) then
11597 if Present (Next_Formal (FF)) then
11599 ("entry for pragma% can have only one argument",
11602 elsif Parameter_Mode (FF) /= E_In_Parameter then
11604 ("entry parameter for pragma% must have mode IN",
11610 Set_Is_AST_Entry (Ent);
11614 ------------------------------------------------------------------
11615 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11616 ------------------------------------------------------------------
11618 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11619 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11620 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11621 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11623 -- FLAG ::= boolean_EXPRESSION
11625 when Pragma_Async_Readers |
11626 Pragma_Async_Writers |
11627 Pragma_Effective_Reads |
11628 Pragma_Effective_Writes =>
11629 Async_Effective : declare
11633 Obj_Id : Entity_Id;
11637 Check_No_Identifiers;
11638 Check_At_Least_N_Arguments (1);
11639 Check_At_Most_N_Arguments (2);
11640 Check_Arg_Is_Local_Name (Arg1);
11641 Error_Msg_Name_1 := Pname;
11643 Obj := Get_Pragma_Arg (Arg1);
11644 Expr := Get_Pragma_Arg (Arg2);
11646 -- Perform minimal verification to ensure that the argument is at
11647 -- least a variable. Subsequent finer grained checks will be done
11648 -- at the end of the declarative region the contains the pragma.
11650 if Is_Entity_Name (Obj)
11651 and then Present (Entity (Obj))
11652 and then Ekind (Entity (Obj)) = E_Variable
11654 Obj_Id := Entity (Obj);
11656 -- Detect a duplicate pragma. Note that it is not efficient to
11657 -- examine preceding statements as Boolean aspects may appear
11658 -- anywhere between the related object declaration and its
11659 -- freeze point. As an alternative, inspect the contents of the
11660 -- variable contract.
11662 Duplic := Get_Pragma (Obj_Id, Prag_Id);
11664 if Present (Duplic) then
11665 Error_Msg_Sloc := Sloc (Duplic);
11666 Error_Msg_N ("pragma % duplicates pragma declared #", N);
11668 -- No duplicate detected
11671 if Present (Expr) then
11672 Preanalyze_And_Resolve (Expr, Standard_Boolean);
11675 -- Chain the pragma on the contract for further processing
11677 Add_Contract_Item (N, Obj_Id);
11680 Error_Pragma ("pragma % must apply to a volatile object");
11682 end Async_Effective;
11688 -- pragma Asynchronous (LOCAL_NAME);
11690 when Pragma_Asynchronous => Asynchronous : declare
11696 Formal : Entity_Id;
11698 procedure Process_Async_Pragma;
11699 -- Common processing for procedure and access-to-procedure case
11701 --------------------------
11702 -- Process_Async_Pragma --
11703 --------------------------
11705 procedure Process_Async_Pragma is
11708 Set_Is_Asynchronous (Nm);
11712 -- The formals should be of mode IN (RM E.4.1(6))
11715 while Present (S) loop
11716 Formal := Defining_Identifier (S);
11718 if Nkind (Formal) = N_Defining_Identifier
11719 and then Ekind (Formal) /= E_In_Parameter
11722 ("pragma% procedure can only have IN parameter",
11729 Set_Is_Asynchronous (Nm);
11730 end Process_Async_Pragma;
11732 -- Start of processing for pragma Asynchronous
11735 Check_Ada_83_Warning;
11736 Check_No_Identifiers;
11737 Check_Arg_Count (1);
11738 Check_Arg_Is_Local_Name (Arg1);
11740 if Debug_Flag_U then
11744 C_Ent := Cunit_Entity (Current_Sem_Unit);
11745 Analyze (Get_Pragma_Arg (Arg1));
11746 Nm := Entity (Get_Pragma_Arg (Arg1));
11748 if not Is_Remote_Call_Interface (C_Ent)
11749 and then not Is_Remote_Types (C_Ent)
11751 -- This pragma should only appear in an RCI or Remote Types
11752 -- unit (RM E.4.1(4)).
11755 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11758 if Ekind (Nm) = E_Procedure
11759 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11761 if not Is_Remote_Call_Interface (Nm) then
11763 ("pragma% cannot be applied on non-remote procedure",
11767 L := Parameter_Specifications (Parent (Nm));
11768 Process_Async_Pragma;
11771 elsif Ekind (Nm) = E_Function then
11773 ("pragma% cannot be applied to function", Arg1);
11775 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11776 if Is_Record_Type (Nm) then
11778 -- A record type that is the Equivalent_Type for a remote
11779 -- access-to-subprogram type.
11781 N := Declaration_Node (Corresponding_Remote_Type (Nm));
11784 -- A non-expanded RAS type (distribution is not enabled)
11786 N := Declaration_Node (Nm);
11789 if Nkind (N) = N_Full_Type_Declaration
11790 and then Nkind (Type_Definition (N)) =
11791 N_Access_Procedure_Definition
11793 L := Parameter_Specifications (Type_Definition (N));
11794 Process_Async_Pragma;
11796 if Is_Asynchronous (Nm)
11797 and then Expander_Active
11798 and then Get_PCS_Name /= Name_No_DSA
11800 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11805 ("pragma% cannot reference access-to-function type",
11809 -- Only other possibility is Access-to-class-wide type
11811 elsif Is_Access_Type (Nm)
11812 and then Is_Class_Wide_Type (Designated_Type (Nm))
11814 Check_First_Subtype (Arg1);
11815 Set_Is_Asynchronous (Nm);
11816 if Expander_Active then
11817 RACW_Type_Is_Asynchronous (Nm);
11821 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
11829 -- pragma Atomic (LOCAL_NAME);
11831 when Pragma_Atomic =>
11832 Process_Atomic_Shared_Volatile;
11834 -----------------------
11835 -- Atomic_Components --
11836 -----------------------
11838 -- pragma Atomic_Components (array_LOCAL_NAME);
11840 -- This processing is shared by Volatile_Components
11842 when Pragma_Atomic_Components |
11843 Pragma_Volatile_Components =>
11845 Atomic_Components : declare
11852 Check_Ada_83_Warning;
11853 Check_No_Identifiers;
11854 Check_Arg_Count (1);
11855 Check_Arg_Is_Local_Name (Arg1);
11856 E_Id := Get_Pragma_Arg (Arg1);
11858 if Etype (E_Id) = Any_Type then
11862 E := Entity (E_Id);
11864 Check_Duplicate_Pragma (E);
11866 if Rep_Item_Too_Early (E, N)
11868 Rep_Item_Too_Late (E, N)
11873 D := Declaration_Node (E);
11876 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
11878 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
11879 and then Nkind (D) = N_Object_Declaration
11880 and then Nkind (Object_Definition (D)) =
11881 N_Constrained_Array_Definition)
11883 -- The flag is set on the object, or on the base type
11885 if Nkind (D) /= N_Object_Declaration then
11886 E := Base_Type (E);
11889 Set_Has_Volatile_Components (E);
11891 if Prag_Id = Pragma_Atomic_Components then
11892 Set_Has_Atomic_Components (E);
11896 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
11898 end Atomic_Components;
11900 --------------------
11901 -- Attach_Handler --
11902 --------------------
11904 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11906 when Pragma_Attach_Handler =>
11907 Check_Ada_83_Warning;
11908 Check_No_Identifiers;
11909 Check_Arg_Count (2);
11911 if No_Run_Time_Mode then
11912 Error_Msg_CRT ("Attach_Handler pragma", N);
11914 Check_Interrupt_Or_Attach_Handler;
11916 -- The expression that designates the attribute may depend on a
11917 -- discriminant, and is therefore a per-object expression, to
11918 -- be expanded in the init proc. If expansion is enabled, then
11919 -- perform semantic checks on a copy only.
11924 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
11927 -- In Relaxed_RM_Semantics mode, we allow any static
11928 -- integer value, for compatibility with other compilers.
11930 if Relaxed_RM_Semantics
11931 and then Nkind (Parg2) = N_Integer_Literal
11933 Typ := Standard_Integer;
11935 Typ := RTE (RE_Interrupt_ID);
11938 if Expander_Active then
11939 Temp := New_Copy_Tree (Parg2);
11940 Set_Parent (Temp, N);
11941 Preanalyze_And_Resolve (Temp, Typ);
11944 Resolve (Parg2, Typ);
11948 Process_Interrupt_Or_Attach_Handler;
11951 --------------------
11952 -- C_Pass_By_Copy --
11953 --------------------
11955 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11957 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
11963 Check_Valid_Configuration_Pragma;
11964 Check_Arg_Count (1);
11965 Check_Optional_Identifier (Arg1, "max_size");
11967 Arg := Get_Pragma_Arg (Arg1);
11968 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
11970 Val := Expr_Value (Arg);
11974 ("maximum size for pragma% must be positive", Arg1);
11976 elsif UI_Is_In_Int_Range (Val) then
11977 Default_C_Record_Mechanism := UI_To_Int (Val);
11979 -- If a giant value is given, Int'Last will do well enough.
11980 -- If sometime someone complains that a record larger than
11981 -- two gigabytes is not copied, we will worry about it then.
11984 Default_C_Record_Mechanism := Mechanism_Type'Last;
11986 end C_Pass_By_Copy;
11992 -- pragma Check ([Name =>] CHECK_KIND,
11993 -- [Check =>] Boolean_EXPRESSION
11994 -- [,[Message =>] String_EXPRESSION]);
11996 -- CHECK_KIND ::= IDENTIFIER |
11999 -- Invariant'Class |
12000 -- Type_Invariant'Class
12002 -- The identifiers Assertions and Statement_Assertions are not
12003 -- allowed, since they have special meaning for Check_Policy.
12005 when Pragma_Check => Check : declare
12013 Check_At_Least_N_Arguments (2);
12014 Check_At_Most_N_Arguments (3);
12015 Check_Optional_Identifier (Arg1, Name_Name);
12016 Check_Optional_Identifier (Arg2, Name_Check);
12018 if Arg_Count = 3 then
12019 Check_Optional_Identifier (Arg3, Name_Message);
12020 Str := Get_Pragma_Arg (Arg3);
12023 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12024 Check_Arg_Is_Identifier (Arg1);
12025 Cname := Chars (Get_Pragma_Arg (Arg1));
12027 -- Check forbidden name Assertions or Statement_Assertions
12030 when Name_Assertions =>
12032 ("""Assertions"" is not allowed as a check kind "
12033 & "for pragma%", Arg1);
12035 when Name_Statement_Assertions =>
12037 ("""Statement_Assertions"" is not allowed as a check kind "
12038 & "for pragma%", Arg1);
12044 -- Check applicable policy. We skip this if Checked/Ignored status
12045 -- is already set (e.g. in the casse of a pragma from an aspect).
12047 if Is_Checked (N) or else Is_Ignored (N) then
12050 -- For a non-source pragma that is a rewriting of another pragma,
12051 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12053 elsif Is_Rewrite_Substitution (N)
12054 and then Nkind (Original_Node (N)) = N_Pragma
12055 and then Original_Node (N) /= N
12057 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12058 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12060 -- Otherwise query the applicable policy at this point
12063 case Check_Kind (Cname) is
12064 when Name_Ignore =>
12065 Set_Is_Ignored (N, True);
12066 Set_Is_Checked (N, False);
12069 Set_Is_Ignored (N, False);
12070 Set_Is_Checked (N, True);
12072 -- For disable, rewrite pragma as null statement and skip
12073 -- rest of the analysis of the pragma.
12075 when Name_Disable =>
12076 Rewrite (N, Make_Null_Statement (Loc));
12080 -- No other possibilities
12083 raise Program_Error;
12087 -- If check kind was not Disable, then continue pragma analysis
12089 Expr := Get_Pragma_Arg (Arg2);
12091 -- Deal with SCO generation
12094 when Name_Predicate |
12097 -- Nothing to do: since checks occur in client units,
12098 -- the SCO for the aspect in the declaration unit is
12099 -- conservatively always enabled.
12105 if Is_Checked (N) and then not Split_PPC (N) then
12107 -- Mark aspect/pragma SCO as enabled
12109 Set_SCO_Pragma_Enabled (Loc);
12113 -- Deal with analyzing the string argument.
12115 if Arg_Count = 3 then
12117 -- If checks are not on we don't want any expansion (since
12118 -- such expansion would not get properly deleted) but
12119 -- we do want to analyze (to get proper references).
12120 -- The Preanalyze_And_Resolve routine does just what we want
12122 if Is_Ignored (N) then
12123 Preanalyze_And_Resolve (Str, Standard_String);
12125 -- Otherwise we need a proper analysis and expansion
12128 Analyze_And_Resolve (Str, Standard_String);
12132 -- Now you might think we could just do the same with the Boolean
12133 -- expression if checks are off (and expansion is on) and then
12134 -- rewrite the check as a null statement. This would work but we
12135 -- would lose the useful warnings about an assertion being bound
12136 -- to fail even if assertions are turned off.
12138 -- So instead we wrap the boolean expression in an if statement
12139 -- that looks like:
12141 -- if False and then condition then
12145 -- The reason we do this rewriting during semantic analysis rather
12146 -- than as part of normal expansion is that we cannot analyze and
12147 -- expand the code for the boolean expression directly, or it may
12148 -- cause insertion of actions that would escape the attempt to
12149 -- suppress the check code.
12151 -- Note that the Sloc for the if statement corresponds to the
12152 -- argument condition, not the pragma itself. The reason for
12153 -- this is that we may generate a warning if the condition is
12154 -- False at compile time, and we do not want to delete this
12155 -- warning when we delete the if statement.
12157 if Expander_Active and Is_Ignored (N) then
12158 Eloc := Sloc (Expr);
12161 Make_If_Statement (Eloc,
12163 Make_And_Then (Eloc,
12164 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
12165 Right_Opnd => Expr),
12166 Then_Statements => New_List (
12167 Make_Null_Statement (Eloc))));
12169 In_Assertion_Expr := In_Assertion_Expr + 1;
12171 In_Assertion_Expr := In_Assertion_Expr - 1;
12173 -- Check is active or expansion not active. In these cases we can
12174 -- just go ahead and analyze the boolean with no worries.
12177 In_Assertion_Expr := In_Assertion_Expr + 1;
12178 Analyze_And_Resolve (Expr, Any_Boolean);
12179 In_Assertion_Expr := In_Assertion_Expr - 1;
12183 --------------------------
12184 -- Check_Float_Overflow --
12185 --------------------------
12187 -- pragma Check_Float_Overflow;
12189 when Pragma_Check_Float_Overflow =>
12191 Check_Valid_Configuration_Pragma;
12192 Check_Arg_Count (0);
12193 Check_Float_Overflow := True;
12199 -- pragma Check_Name (check_IDENTIFIER);
12201 when Pragma_Check_Name =>
12203 Check_No_Identifiers;
12204 Check_Valid_Configuration_Pragma;
12205 Check_Arg_Count (1);
12206 Check_Arg_Is_Identifier (Arg1);
12209 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12212 for J in Check_Names.First .. Check_Names.Last loop
12213 if Check_Names.Table (J) = Nam then
12218 Check_Names.Append (Nam);
12225 -- This is the old style syntax, which is still allowed in all modes:
12227 -- pragma Check_Policy ([Name =>] CHECK_KIND
12228 -- [Policy =>] POLICY_IDENTIFIER);
12230 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12232 -- CHECK_KIND ::= IDENTIFIER |
12235 -- Type_Invariant'Class |
12238 -- This is the new style syntax, compatible with Assertion_Policy
12239 -- and also allowed in all modes.
12241 -- Pragma Check_Policy (
12242 -- CHECK_KIND => POLICY_IDENTIFIER
12243 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12245 -- Note: the identifiers Name and Policy are not allowed as
12246 -- Check_Kind values. This avoids ambiguities between the old and
12247 -- new form syntax.
12249 when Pragma_Check_Policy => Check_Policy : declare
12254 Check_At_Least_N_Arguments (1);
12256 -- A Check_Policy pragma can appear either as a configuration
12257 -- pragma, or in a declarative part or a package spec (see RM
12258 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12259 -- followed for Check_Policy).
12261 if not Is_Configuration_Pragma then
12262 Check_Is_In_Decl_Part_Or_Package_Spec;
12265 -- Figure out if we have the old or new syntax. We have the
12266 -- old syntax if the first argument has no identifier, or the
12267 -- identifier is Name.
12269 if Nkind (Arg1) /= N_Pragma_Argument_Association
12270 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12274 Check_Arg_Count (2);
12275 Check_Optional_Identifier (Arg1, Name_Name);
12276 Kind := Get_Pragma_Arg (Arg1);
12277 Rewrite_Assertion_Kind (Kind);
12278 Check_Arg_Is_Identifier (Arg1);
12280 -- Check forbidden check kind
12282 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12283 Error_Msg_Name_2 := Chars (Kind);
12285 ("pragma% does not allow% as check name", Arg1);
12290 Check_Optional_Identifier (Arg2, Name_Policy);
12291 Check_Arg_Is_One_Of
12293 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12295 -- And chain pragma on the Check_Policy_List for search
12297 Set_Next_Pragma (N, Opt.Check_Policy_List);
12298 Opt.Check_Policy_List := N;
12300 -- For the new syntax, what we do is to convert each argument to
12301 -- an old syntax equivalent. We do that because we want to chain
12302 -- old style Check_Policy pragmas for the search (we don't want
12303 -- to have to deal with multiple arguments in the search).
12313 while Present (Arg) loop
12314 LocP := Sloc (Arg);
12315 Argx := Get_Pragma_Arg (Arg);
12317 -- Kind must be specified
12319 if Nkind (Arg) /= N_Pragma_Argument_Association
12320 or else Chars (Arg) = No_Name
12323 ("missing assertion kind for pragma%", Arg);
12326 -- Construct equivalent old form syntax Check_Policy
12327 -- pragma and insert it to get remaining checks.
12331 Chars => Name_Check_Policy,
12332 Pragma_Argument_Associations => New_List (
12333 Make_Pragma_Argument_Association (LocP,
12335 Make_Identifier (LocP, Chars (Arg))),
12336 Make_Pragma_Argument_Association (Sloc (Argx),
12337 Expression => Argx))));
12342 -- Rewrite original Check_Policy pragma to null, since we
12343 -- have converted it into a series of old syntax pragmas.
12345 Rewrite (N, Make_Null_Statement (Loc));
12351 ---------------------
12352 -- CIL_Constructor --
12353 ---------------------
12355 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
12357 -- Processing for this pragma is shared with Java_Constructor
12363 -- pragma Comment (static_string_EXPRESSION)
12365 -- Processing for pragma Comment shares the circuitry for pragma
12366 -- Ident. The only differences are that Ident enforces a limit of 31
12367 -- characters on its argument, and also enforces limitations on
12368 -- placement for DEC compatibility. Pragma Comment shares neither of
12369 -- these restrictions.
12371 -------------------
12372 -- Common_Object --
12373 -------------------
12375 -- pragma Common_Object (
12376 -- [Internal =>] LOCAL_NAME
12377 -- [, [External =>] EXTERNAL_SYMBOL]
12378 -- [, [Size =>] EXTERNAL_SYMBOL]);
12380 -- Processing for this pragma is shared with Psect_Object
12382 ------------------------
12383 -- Compile_Time_Error --
12384 ------------------------
12386 -- pragma Compile_Time_Error
12387 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12389 when Pragma_Compile_Time_Error =>
12391 Process_Compile_Time_Warning_Or_Error;
12393 --------------------------
12394 -- Compile_Time_Warning --
12395 --------------------------
12397 -- pragma Compile_Time_Warning
12398 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12400 when Pragma_Compile_Time_Warning =>
12402 Process_Compile_Time_Warning_Or_Error;
12404 ---------------------------
12405 -- Compiler_Unit_Warning --
12406 ---------------------------
12408 -- pragma Compiler_Unit_Warning;
12412 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12413 -- errors not warnings. This means that we had introduced a big extra
12414 -- inertia to compiler changes, since even if we implemented a new
12415 -- feature, and even if all versions to be used for bootstrapping
12416 -- implemented this new feature, we could not use it, since old
12417 -- compilers would give errors for using this feature in units
12418 -- having Compiler_Unit pragmas.
12420 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12421 -- problem. We no longer have any units mentioning Compiler_Unit,
12422 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12423 -- and thus generates a warning which can be ignored. So that deals
12424 -- with the problem of old compilers not implementing the newer form
12427 -- Newer compilers recognize the new pragma, but generate warning
12428 -- messages instead of errors, which again can be ignored in the
12429 -- case of an old compiler which implements a wanted new feature
12430 -- but at the time felt like warning about it for older compilers.
12432 -- We retain Compiler_Unit so that new compilers can be used to build
12433 -- older run-times that use this pragma. That's an unusual case, but
12434 -- it's easy enough to handle, so why not?
12436 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12438 Check_Arg_Count (0);
12440 -- Only recognized in main unit
12442 if Current_Sem_Unit = Main_Unit then
12443 Compiler_Unit := True;
12446 -----------------------------
12447 -- Complete_Representation --
12448 -----------------------------
12450 -- pragma Complete_Representation;
12452 when Pragma_Complete_Representation =>
12454 Check_Arg_Count (0);
12456 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12458 ("pragma & must appear within record representation clause");
12461 ----------------------------
12462 -- Complex_Representation --
12463 ----------------------------
12465 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12467 when Pragma_Complex_Representation => Complex_Representation : declare
12474 Check_Arg_Count (1);
12475 Check_Optional_Identifier (Arg1, Name_Entity);
12476 Check_Arg_Is_Local_Name (Arg1);
12477 E_Id := Get_Pragma_Arg (Arg1);
12479 if Etype (E_Id) = Any_Type then
12483 E := Entity (E_Id);
12485 if not Is_Record_Type (E) then
12487 ("argument for pragma% must be record type", Arg1);
12490 Ent := First_Entity (E);
12493 or else No (Next_Entity (Ent))
12494 or else Present (Next_Entity (Next_Entity (Ent)))
12495 or else not Is_Floating_Point_Type (Etype (Ent))
12496 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12499 ("record for pragma% must have two fields of the same "
12500 & "floating-point type", Arg1);
12503 Set_Has_Complex_Representation (Base_Type (E));
12505 -- We need to treat the type has having a non-standard
12506 -- representation, for back-end purposes, even though in
12507 -- general a complex will have the default representation
12508 -- of a record with two real components.
12510 Set_Has_Non_Standard_Rep (Base_Type (E));
12512 end Complex_Representation;
12514 -------------------------
12515 -- Component_Alignment --
12516 -------------------------
12518 -- pragma Component_Alignment (
12519 -- [Form =>] ALIGNMENT_CHOICE
12520 -- [, [Name =>] type_LOCAL_NAME]);
12522 -- ALIGNMENT_CHOICE ::=
12524 -- | Component_Size_4
12528 when Pragma_Component_Alignment => Component_AlignmentP : declare
12529 Args : Args_List (1 .. 2);
12530 Names : constant Name_List (1 .. 2) := (
12534 Form : Node_Id renames Args (1);
12535 Name : Node_Id renames Args (2);
12537 Atype : Component_Alignment_Kind;
12542 Gather_Associations (Names, Args);
12545 Error_Pragma ("missing Form argument for pragma%");
12548 Check_Arg_Is_Identifier (Form);
12550 -- Get proper alignment, note that Default = Component_Size on all
12551 -- machines we have so far, and we want to set this value rather
12552 -- than the default value to indicate that it has been explicitly
12553 -- set (and thus will not get overridden by the default component
12554 -- alignment for the current scope)
12556 if Chars (Form) = Name_Component_Size then
12557 Atype := Calign_Component_Size;
12559 elsif Chars (Form) = Name_Component_Size_4 then
12560 Atype := Calign_Component_Size_4;
12562 elsif Chars (Form) = Name_Default then
12563 Atype := Calign_Component_Size;
12565 elsif Chars (Form) = Name_Storage_Unit then
12566 Atype := Calign_Storage_Unit;
12570 ("invalid Form parameter for pragma%", Form);
12573 -- Case with no name, supplied, affects scope table entry
12577 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12579 -- Case of name supplied
12582 Check_Arg_Is_Local_Name (Name);
12584 Typ := Entity (Name);
12587 or else Rep_Item_Too_Early (Typ, N)
12591 Typ := Underlying_Type (Typ);
12594 if not Is_Record_Type (Typ)
12595 and then not Is_Array_Type (Typ)
12598 ("Name parameter of pragma% must identify record or "
12599 & "array type", Name);
12602 -- An explicit Component_Alignment pragma overrides an
12603 -- implicit pragma Pack, but not an explicit one.
12605 if not Has_Pragma_Pack (Base_Type (Typ)) then
12606 Set_Is_Packed (Base_Type (Typ), False);
12607 Set_Component_Alignment (Base_Type (Typ), Atype);
12610 end Component_AlignmentP;
12612 --------------------
12613 -- Contract_Cases --
12614 --------------------
12616 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12618 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12620 -- CASE_GUARD ::= boolean_EXPRESSION | others
12622 -- CONSEQUENCE ::= boolean_EXPRESSION
12624 when Pragma_Contract_Cases => Contract_Cases : declare
12625 Subp_Decl : Node_Id;
12629 Check_Arg_Count (1);
12630 Ensure_Aggregate_Form (Arg1);
12632 -- The pragma is analyzed at the end of the declarative part which
12633 -- contains the related subprogram. Reset the analyzed flag.
12635 Set_Analyzed (N, False);
12637 -- Ensure the proper placement of the pragma. Contract_Cases must
12638 -- be associated with a subprogram declaration or a body that acts
12642 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
12644 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
12647 -- Body acts as spec
12649 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12650 and then No (Corresponding_Spec (Subp_Decl))
12654 -- Body stub acts as spec
12656 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12657 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12666 -- When the pragma appears on a subprogram body, perform the full
12669 if Nkind (Subp_Decl) = N_Subprogram_Body then
12670 Analyze_Contract_Cases_In_Decl_Part (N);
12672 -- When Contract_Cases applies to a subprogram compilation unit,
12673 -- the corresponding pragma is placed after the unit's declaration
12674 -- node and needs to be analyzed immediately.
12676 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
12677 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
12679 Analyze_Contract_Cases_In_Decl_Part (N);
12682 -- Chain the pragma on the contract for further processing
12684 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12685 end Contract_Cases;
12691 -- pragma Controlled (first_subtype_LOCAL_NAME);
12693 when Pragma_Controlled => Controlled : declare
12697 Check_No_Identifiers;
12698 Check_Arg_Count (1);
12699 Check_Arg_Is_Local_Name (Arg1);
12700 Arg := Get_Pragma_Arg (Arg1);
12702 if not Is_Entity_Name (Arg)
12703 or else not Is_Access_Type (Entity (Arg))
12705 Error_Pragma_Arg ("pragma% requires access type", Arg1);
12707 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
12715 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12716 -- [Entity =>] LOCAL_NAME);
12718 when Pragma_Convention => Convention : declare
12721 pragma Warnings (Off, C);
12722 pragma Warnings (Off, E);
12724 Check_Arg_Order ((Name_Convention, Name_Entity));
12725 Check_Ada_83_Warning;
12726 Check_Arg_Count (2);
12727 Process_Convention (C, E);
12730 ---------------------------
12731 -- Convention_Identifier --
12732 ---------------------------
12734 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12735 -- [Convention =>] convention_IDENTIFIER);
12737 when Pragma_Convention_Identifier => Convention_Identifier : declare
12743 Check_Arg_Order ((Name_Name, Name_Convention));
12744 Check_Arg_Count (2);
12745 Check_Optional_Identifier (Arg1, Name_Name);
12746 Check_Optional_Identifier (Arg2, Name_Convention);
12747 Check_Arg_Is_Identifier (Arg1);
12748 Check_Arg_Is_Identifier (Arg2);
12749 Idnam := Chars (Get_Pragma_Arg (Arg1));
12750 Cname := Chars (Get_Pragma_Arg (Arg2));
12752 if Is_Convention_Name (Cname) then
12753 Record_Convention_Identifier
12754 (Idnam, Get_Convention_Id (Cname));
12757 ("second arg for % pragma must be convention", Arg2);
12759 end Convention_Identifier;
12765 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12767 when Pragma_CPP_Class => CPP_Class : declare
12771 if Warn_On_Obsolescent_Feature then
12773 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12774 & "effect; replace it by pragma import?j?", N);
12777 Check_Arg_Count (1);
12781 Chars => Name_Import,
12782 Pragma_Argument_Associations => New_List (
12783 Make_Pragma_Argument_Association (Loc,
12784 Expression => Make_Identifier (Loc, Name_CPP)),
12785 New_Copy (First (Pragma_Argument_Associations (N))))));
12789 ---------------------
12790 -- CPP_Constructor --
12791 ---------------------
12793 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12794 -- [, [External_Name =>] static_string_EXPRESSION ]
12795 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12797 when Pragma_CPP_Constructor => CPP_Constructor : declare
12800 Def_Id : Entity_Id;
12801 Tag_Typ : Entity_Id;
12805 Check_At_Least_N_Arguments (1);
12806 Check_At_Most_N_Arguments (3);
12807 Check_Optional_Identifier (Arg1, Name_Entity);
12808 Check_Arg_Is_Local_Name (Arg1);
12810 Id := Get_Pragma_Arg (Arg1);
12811 Find_Program_Unit_Name (Id);
12813 -- If we did not find the name, we are done
12815 if Etype (Id) = Any_Type then
12819 Def_Id := Entity (Id);
12821 -- Check if already defined as constructor
12823 if Is_Constructor (Def_Id) then
12825 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
12829 if Ekind (Def_Id) = E_Function
12830 and then (Is_CPP_Class (Etype (Def_Id))
12831 or else (Is_Class_Wide_Type (Etype (Def_Id))
12833 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
12835 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
12837 ("'C'P'P constructor must be defined in the scope of "
12838 & "its returned type", Arg1);
12841 if Arg_Count >= 2 then
12842 Set_Imported (Def_Id);
12843 Set_Is_Public (Def_Id);
12844 Process_Interface_Name (Def_Id, Arg2, Arg3);
12847 Set_Has_Completion (Def_Id);
12848 Set_Is_Constructor (Def_Id);
12849 Set_Convention (Def_Id, Convention_CPP);
12851 -- Imported C++ constructors are not dispatching primitives
12852 -- because in C++ they don't have a dispatch table slot.
12853 -- However, in Ada the constructor has the profile of a
12854 -- function that returns a tagged type and therefore it has
12855 -- been treated as a primitive operation during semantic
12856 -- analysis. We now remove it from the list of primitive
12857 -- operations of the type.
12859 if Is_Tagged_Type (Etype (Def_Id))
12860 and then not Is_Class_Wide_Type (Etype (Def_Id))
12861 and then Is_Dispatching_Operation (Def_Id)
12863 Tag_Typ := Etype (Def_Id);
12865 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
12866 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
12870 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
12871 Set_Is_Dispatching_Operation (Def_Id, False);
12874 -- For backward compatibility, if the constructor returns a
12875 -- class wide type, and we internally change the return type to
12876 -- the corresponding root type.
12878 if Is_Class_Wide_Type (Etype (Def_Id)) then
12879 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
12883 ("pragma% requires function returning a 'C'P'P_Class type",
12886 end CPP_Constructor;
12892 when Pragma_CPP_Virtual => CPP_Virtual : declare
12896 if Warn_On_Obsolescent_Feature then
12898 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12907 when Pragma_CPP_Vtable => CPP_Vtable : declare
12911 if Warn_On_Obsolescent_Feature then
12913 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12922 -- pragma CPU (EXPRESSION);
12924 when Pragma_CPU => CPU : declare
12925 P : constant Node_Id := Parent (N);
12931 Check_No_Identifiers;
12932 Check_Arg_Count (1);
12936 if Nkind (P) = N_Subprogram_Body then
12937 Check_In_Main_Program;
12939 Arg := Get_Pragma_Arg (Arg1);
12940 Analyze_And_Resolve (Arg, Any_Integer);
12942 Ent := Defining_Unit_Name (Specification (P));
12944 if Nkind (Ent) = N_Defining_Program_Unit_Name then
12945 Ent := Defining_Identifier (Ent);
12950 if not Is_OK_Static_Expression (Arg) then
12951 Flag_Non_Static_Expr
12952 ("main subprogram affinity is not static!", Arg);
12955 -- If constraint error, then we already signalled an error
12957 elsif Raises_Constraint_Error (Arg) then
12960 -- Otherwise check in range
12964 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
12965 -- This is the entity System.Multiprocessors.CPU_Range;
12967 Val : constant Uint := Expr_Value (Arg);
12970 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
12972 Val > Expr_Value (Type_High_Bound (CPU_Id))
12975 ("main subprogram CPU is out of range", Arg1);
12981 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
12985 elsif Nkind (P) = N_Task_Definition then
12986 Arg := Get_Pragma_Arg (Arg1);
12987 Ent := Defining_Identifier (Parent (P));
12989 -- The expression must be analyzed in the special manner
12990 -- described in "Handling of Default and Per-Object
12991 -- Expressions" in sem.ads.
12993 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
12995 -- Anything else is incorrect
13001 -- Check duplicate pragma before we chain the pragma in the Rep
13002 -- Item chain of Ent.
13004 Check_Duplicate_Pragma (Ent);
13005 Record_Rep_Item (Ent, N);
13012 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13014 when Pragma_Debug => Debug : declare
13021 -- The condition for executing the call is that the expander
13022 -- is active and that we are not ignoring this debug pragma.
13027 (Expander_Active and then not Is_Ignored (N)),
13030 if not Is_Ignored (N) then
13031 Set_SCO_Pragma_Enabled (Loc);
13034 if Arg_Count = 2 then
13036 Make_And_Then (Loc,
13037 Left_Opnd => Relocate_Node (Cond),
13038 Right_Opnd => Get_Pragma_Arg (Arg1));
13039 Call := Get_Pragma_Arg (Arg2);
13041 Call := Get_Pragma_Arg (Arg1);
13045 N_Indexed_Component,
13049 N_Selected_Component)
13051 -- If this pragma Debug comes from source, its argument was
13052 -- parsed as a name form (which is syntactically identical).
13053 -- In a generic context a parameterless call will be left as
13054 -- an expanded name (if global) or selected_component if local.
13055 -- Change it to a procedure call statement now.
13057 Change_Name_To_Procedure_Call_Statement (Call);
13059 elsif Nkind (Call) = N_Procedure_Call_Statement then
13061 -- Already in the form of a procedure call statement: nothing
13062 -- to do (could happen in case of an internally generated
13068 -- All other cases: diagnose error
13071 ("argument of pragma ""Debug"" is not procedure call",
13076 -- Rewrite into a conditional with an appropriate condition. We
13077 -- wrap the procedure call in a block so that overhead from e.g.
13078 -- use of the secondary stack does not generate execution overhead
13079 -- for suppressed conditions.
13081 -- Normally the analysis that follows will freeze the subprogram
13082 -- being called. However, if the call is to a null procedure,
13083 -- we want to freeze it before creating the block, because the
13084 -- analysis that follows may be done with expansion disabled, in
13085 -- which case the body will not be generated, leading to spurious
13088 if Nkind (Call) = N_Procedure_Call_Statement
13089 and then Is_Entity_Name (Name (Call))
13091 Analyze (Name (Call));
13092 Freeze_Before (N, Entity (Name (Call)));
13096 Make_Implicit_If_Statement (N,
13098 Then_Statements => New_List (
13099 Make_Block_Statement (Loc,
13100 Handled_Statement_Sequence =>
13101 Make_Handled_Sequence_Of_Statements (Loc,
13102 Statements => New_List (Relocate_Node (Call)))))));
13105 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13106 -- after analysis of the normally rewritten node, to capture all
13107 -- references to entities, which avoids issuing wrong warnings
13108 -- about unused entities.
13110 if GNATprove_Mode then
13111 Rewrite (N, Make_Null_Statement (Loc));
13119 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13121 when Pragma_Debug_Policy =>
13123 Check_Arg_Count (1);
13124 Check_No_Identifiers;
13125 Check_Arg_Is_Identifier (Arg1);
13127 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13128 -- rewrite it that way, and let the rest of the checking come
13129 -- from analyzing the rewritten pragma.
13133 Chars => Name_Check_Policy,
13134 Pragma_Argument_Associations => New_List (
13135 Make_Pragma_Argument_Association (Loc,
13136 Expression => Make_Identifier (Loc, Name_Debug)),
13138 Make_Pragma_Argument_Association (Loc,
13139 Expression => Get_Pragma_Arg (Arg1)))));
13146 -- pragma Depends (DEPENDENCY_RELATION);
13148 -- DEPENDENCY_RELATION ::=
13150 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13152 -- DEPENDENCY_CLAUSE ::=
13153 -- OUTPUT_LIST =>[+] INPUT_LIST
13154 -- | NULL_DEPENDENCY_CLAUSE
13156 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13158 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13160 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13162 -- OUTPUT ::= NAME | FUNCTION_RESULT
13165 -- where FUNCTION_RESULT is a function Result attribute_reference
13167 when Pragma_Depends => Depends : declare
13168 Subp_Decl : Node_Id;
13172 Check_Arg_Count (1);
13173 Ensure_Aggregate_Form (Arg1);
13175 -- Ensure the proper placement of the pragma. Depends must be
13176 -- associated with a subprogram declaration or a body that acts
13180 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
13182 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
13185 -- Body acts as spec
13187 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13188 and then No (Corresponding_Spec (Subp_Decl))
13192 -- Body stub acts as spec
13194 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13195 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13204 -- When the pragma appears on a subprogram body, perform the full
13207 if Nkind (Subp_Decl) = N_Subprogram_Body then
13208 Analyze_Depends_In_Decl_Part (N);
13210 -- When Depends applies to a subprogram compilation unit, the
13211 -- corresponding pragma is placed after the unit's declaration
13212 -- node and needs to be analyzed immediately.
13214 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
13215 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
13217 Analyze_Depends_In_Decl_Part (N);
13220 -- Chain the pragma on the contract for further processing
13222 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13225 ---------------------
13226 -- Detect_Blocking --
13227 ---------------------
13229 -- pragma Detect_Blocking;
13231 when Pragma_Detect_Blocking =>
13233 Check_Arg_Count (0);
13234 Check_Valid_Configuration_Pragma;
13235 Detect_Blocking := True;
13237 ----------------------------------
13238 -- Default_Scalar_Storage_Order --
13239 ----------------------------------
13241 -- pragma Default_Scalar_Storage_Order
13242 -- (High_Order_First | Low_Order_First);
13244 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13245 Default : Character;
13249 Check_Arg_Count (1);
13251 -- Default_Scalar_Storage_Order can appear as a configuration
13252 -- pragma, or in a declarative part of a package spec.
13254 if not Is_Configuration_Pragma then
13255 Check_Is_In_Decl_Part_Or_Package_Spec;
13258 Check_No_Identifiers;
13259 Check_Arg_Is_One_Of
13260 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13261 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13262 Default := Fold_Upper (Name_Buffer (1));
13264 if not Support_Nondefault_SSO_On_Target
13265 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13267 if Warn_On_Unrecognized_Pragma then
13269 ("non-default Scalar_Storage_Order not supported "
13270 & "on target?g?", N);
13272 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13275 -- Here set the specified default
13278 Opt.Default_SSO := Default;
13282 --------------------------
13283 -- Default_Storage_Pool --
13284 --------------------------
13286 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13288 when Pragma_Default_Storage_Pool =>
13290 Check_Arg_Count (1);
13292 -- Default_Storage_Pool can appear as a configuration pragma, or
13293 -- in a declarative part of a package spec.
13295 if not Is_Configuration_Pragma then
13296 Check_Is_In_Decl_Part_Or_Package_Spec;
13299 -- Case of Default_Storage_Pool (null);
13301 if Nkind (Expression (Arg1)) = N_Null then
13302 Analyze (Expression (Arg1));
13304 -- This is an odd case, this is not really an expression, so
13305 -- we don't have a type for it. So just set the type to Empty.
13307 Set_Etype (Expression (Arg1), Empty);
13309 -- Case of Default_Storage_Pool (storage_pool_NAME);
13312 -- If it's a configuration pragma, then the only allowed
13313 -- argument is "null".
13315 if Is_Configuration_Pragma then
13316 Error_Pragma_Arg ("NULL expected", Arg1);
13319 -- The expected type for a non-"null" argument is
13320 -- Root_Storage_Pool'Class.
13322 Analyze_And_Resolve
13323 (Get_Pragma_Arg (Arg1),
13324 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13327 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
13328 -- for an access type will use this information to set the
13329 -- appropriate attributes of the access type.
13331 Default_Pool := Expression (Arg1);
13333 ------------------------------------
13334 -- Disable_Atomic_Synchronization --
13335 ------------------------------------
13337 -- pragma Disable_Atomic_Synchronization [(Entity)];
13339 when Pragma_Disable_Atomic_Synchronization =>
13341 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13343 -------------------
13344 -- Discard_Names --
13345 -------------------
13347 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13349 when Pragma_Discard_Names => Discard_Names : declare
13354 Check_Ada_83_Warning;
13356 -- Deal with configuration pragma case
13358 if Arg_Count = 0 and then Is_Configuration_Pragma then
13359 Global_Discard_Names := True;
13362 -- Otherwise, check correct appropriate context
13365 Check_Is_In_Decl_Part_Or_Package_Spec;
13367 if Arg_Count = 0 then
13369 -- If there is no parameter, then from now on this pragma
13370 -- applies to any enumeration, exception or tagged type
13371 -- defined in the current declarative part, and recursively
13372 -- to any nested scope.
13374 Set_Discard_Names (Current_Scope);
13378 Check_Arg_Count (1);
13379 Check_Optional_Identifier (Arg1, Name_On);
13380 Check_Arg_Is_Local_Name (Arg1);
13382 E_Id := Get_Pragma_Arg (Arg1);
13384 if Etype (E_Id) = Any_Type then
13387 E := Entity (E_Id);
13390 if (Is_First_Subtype (E)
13392 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13393 or else Ekind (E) = E_Exception
13395 Set_Discard_Names (E);
13396 Record_Rep_Item (E, N);
13400 ("inappropriate entity for pragma%", Arg1);
13407 ------------------------
13408 -- Dispatching_Domain --
13409 ------------------------
13411 -- pragma Dispatching_Domain (EXPRESSION);
13413 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13414 P : constant Node_Id := Parent (N);
13420 Check_No_Identifiers;
13421 Check_Arg_Count (1);
13423 -- This pragma is born obsolete, but not the aspect
13425 if not From_Aspect_Specification (N) then
13427 (No_Obsolescent_Features, Pragma_Identifier (N));
13430 if Nkind (P) = N_Task_Definition then
13431 Arg := Get_Pragma_Arg (Arg1);
13432 Ent := Defining_Identifier (Parent (P));
13434 -- The expression must be analyzed in the special manner
13435 -- described in "Handling of Default and Per-Object
13436 -- Expressions" in sem.ads.
13438 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13440 -- Check duplicate pragma before we chain the pragma in the Rep
13441 -- Item chain of Ent.
13443 Check_Duplicate_Pragma (Ent);
13444 Record_Rep_Item (Ent, N);
13446 -- Anything else is incorrect
13451 end Dispatching_Domain;
13457 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13459 when Pragma_Elaborate => Elaborate : declare
13464 -- Pragma must be in context items list of a compilation unit
13466 if not Is_In_Context_Clause then
13470 -- Must be at least one argument
13472 if Arg_Count = 0 then
13473 Error_Pragma ("pragma% requires at least one argument");
13476 -- In Ada 83 mode, there can be no items following it in the
13477 -- context list except other pragmas and implicit with clauses
13478 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13479 -- placement rule does not apply.
13481 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13483 while Present (Citem) loop
13484 if Nkind (Citem) = N_Pragma
13485 or else (Nkind (Citem) = N_With_Clause
13486 and then Implicit_With (Citem))
13491 ("(Ada 83) pragma% must be at end of context clause");
13498 -- Finally, the arguments must all be units mentioned in a with
13499 -- clause in the same context clause. Note we already checked (in
13500 -- Par.Prag) that the arguments are all identifiers or selected
13504 Outer : while Present (Arg) loop
13505 Citem := First (List_Containing (N));
13506 Inner : while Citem /= N loop
13507 if Nkind (Citem) = N_With_Clause
13508 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13510 Set_Elaborate_Present (Citem, True);
13511 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13512 Generate_Reference (Entity (Name (Citem)), Citem);
13514 -- With the pragma present, elaboration calls on
13515 -- subprograms from the named unit need no further
13516 -- checks, as long as the pragma appears in the current
13517 -- compilation unit. If the pragma appears in some unit
13518 -- in the context, there might still be a need for an
13519 -- Elaborate_All_Desirable from the current compilation
13520 -- to the named unit, so we keep the check enabled.
13522 if In_Extended_Main_Source_Unit (N) then
13523 Set_Suppress_Elaboration_Warnings
13524 (Entity (Name (Citem)));
13535 ("argument of pragma% is not withed unit", Arg);
13541 -- Give a warning if operating in static mode with one of the
13542 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13544 if Elab_Warnings and not Dynamic_Elaboration_Checks then
13546 ("?l?use of pragma Elaborate may not be safe", N);
13548 ("?l?use pragma Elaborate_All instead if possible", N);
13552 -------------------
13553 -- Elaborate_All --
13554 -------------------
13556 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13558 when Pragma_Elaborate_All => Elaborate_All : declare
13563 Check_Ada_83_Warning;
13565 -- Pragma must be in context items list of a compilation unit
13567 if not Is_In_Context_Clause then
13571 -- Must be at least one argument
13573 if Arg_Count = 0 then
13574 Error_Pragma ("pragma% requires at least one argument");
13577 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13578 -- have to appear at the end of the context clause, but may
13579 -- appear mixed in with other items, even in Ada 83 mode.
13581 -- Final check: the arguments must all be units mentioned in
13582 -- a with clause in the same context clause. Note that we
13583 -- already checked (in Par.Prag) that all the arguments are
13584 -- either identifiers or selected components.
13587 Outr : while Present (Arg) loop
13588 Citem := First (List_Containing (N));
13589 Innr : while Citem /= N loop
13590 if Nkind (Citem) = N_With_Clause
13591 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13593 Set_Elaborate_All_Present (Citem, True);
13594 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13596 -- Suppress warnings and elaboration checks on the named
13597 -- unit if the pragma is in the current compilation, as
13598 -- for pragma Elaborate.
13600 if In_Extended_Main_Source_Unit (N) then
13601 Set_Suppress_Elaboration_Warnings
13602 (Entity (Name (Citem)));
13611 Set_Error_Posted (N);
13613 ("argument of pragma% is not withed unit", Arg);
13620 --------------------
13621 -- Elaborate_Body --
13622 --------------------
13624 -- pragma Elaborate_Body [( library_unit_NAME )];
13626 when Pragma_Elaborate_Body => Elaborate_Body : declare
13627 Cunit_Node : Node_Id;
13628 Cunit_Ent : Entity_Id;
13631 Check_Ada_83_Warning;
13632 Check_Valid_Library_Unit_Pragma;
13634 if Nkind (N) = N_Null_Statement then
13638 Cunit_Node := Cunit (Current_Sem_Unit);
13639 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
13641 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
13644 Error_Pragma ("pragma% must refer to a spec, not a body");
13646 Set_Body_Required (Cunit_Node, True);
13647 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
13649 -- If we are in dynamic elaboration mode, then we suppress
13650 -- elaboration warnings for the unit, since it is definitely
13651 -- fine NOT to do dynamic checks at the first level (and such
13652 -- checks will be suppressed because no elaboration boolean
13653 -- is created for Elaborate_Body packages).
13655 -- But in the static model of elaboration, Elaborate_Body is
13656 -- definitely NOT good enough to ensure elaboration safety on
13657 -- its own, since the body may WITH other units that are not
13658 -- safe from an elaboration point of view, so a client must
13659 -- still do an Elaborate_All on such units.
13661 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13662 -- Elaborate_Body always suppressed elab warnings.
13664 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
13665 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
13668 end Elaborate_Body;
13670 ------------------------
13671 -- Elaboration_Checks --
13672 ------------------------
13674 -- pragma Elaboration_Checks (Static | Dynamic);
13676 when Pragma_Elaboration_Checks =>
13678 Check_Arg_Count (1);
13679 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
13680 Dynamic_Elaboration_Checks :=
13681 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
13687 -- pragma Eliminate (
13688 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13689 -- [,[Entity =>] IDENTIFIER |
13690 -- SELECTED_COMPONENT |
13692 -- [, OVERLOADING_RESOLUTION]);
13694 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13697 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13698 -- FUNCTION_PROFILE
13700 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13702 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13703 -- Result_Type => result_SUBTYPE_NAME]
13705 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13706 -- SUBTYPE_NAME ::= STRING_LITERAL
13708 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13709 -- SOURCE_TRACE ::= STRING_LITERAL
13711 when Pragma_Eliminate => Eliminate : declare
13712 Args : Args_List (1 .. 5);
13713 Names : constant Name_List (1 .. 5) := (
13716 Name_Parameter_Types,
13718 Name_Source_Location);
13720 Unit_Name : Node_Id renames Args (1);
13721 Entity : Node_Id renames Args (2);
13722 Parameter_Types : Node_Id renames Args (3);
13723 Result_Type : Node_Id renames Args (4);
13724 Source_Location : Node_Id renames Args (5);
13728 Check_Valid_Configuration_Pragma;
13729 Gather_Associations (Names, Args);
13731 if No (Unit_Name) then
13732 Error_Pragma ("missing Unit_Name argument for pragma%");
13736 and then (Present (Parameter_Types)
13738 Present (Result_Type)
13740 Present (Source_Location))
13742 Error_Pragma ("missing Entity argument for pragma%");
13745 if (Present (Parameter_Types)
13747 Present (Result_Type))
13749 Present (Source_Location)
13752 ("parameter profile and source location cannot be used "
13753 & "together in pragma%");
13756 Process_Eliminate_Pragma
13765 -----------------------------------
13766 -- Enable_Atomic_Synchronization --
13767 -----------------------------------
13769 -- pragma Enable_Atomic_Synchronization [(Entity)];
13771 when Pragma_Enable_Atomic_Synchronization =>
13773 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
13780 -- [ Convention =>] convention_IDENTIFIER,
13781 -- [ Entity =>] LOCAL_NAME
13782 -- [, [External_Name =>] static_string_EXPRESSION ]
13783 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13785 when Pragma_Export => Export : declare
13787 Def_Id : Entity_Id;
13789 pragma Warnings (Off, C);
13792 Check_Ada_83_Warning;
13796 Name_External_Name,
13799 Check_At_Least_N_Arguments (2);
13800 Check_At_Most_N_Arguments (4);
13802 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13803 -- pragma Export (Entity, "external name");
13805 if Relaxed_RM_Semantics
13806 and then Arg_Count = 2
13807 and then Nkind (Expression (Arg2)) = N_String_Literal
13810 Def_Id := Get_Pragma_Arg (Arg1);
13813 if not Is_Entity_Name (Def_Id) then
13814 Error_Pragma_Arg ("entity name required", Arg1);
13817 Def_Id := Entity (Def_Id);
13818 Set_Exported (Def_Id, Arg1);
13821 Process_Convention (C, Def_Id);
13823 if Ekind (Def_Id) /= E_Constant then
13824 Note_Possible_Modification
13825 (Get_Pragma_Arg (Arg2), Sure => False);
13828 Process_Interface_Name (Def_Id, Arg3, Arg4);
13829 Set_Exported (Def_Id, Arg2);
13832 -- If the entity is a deferred constant, propagate the information
13833 -- to the full view, because gigi elaborates the full view only.
13835 if Ekind (Def_Id) = E_Constant
13836 and then Present (Full_View (Def_Id))
13839 Id2 : constant Entity_Id := Full_View (Def_Id);
13841 Set_Is_Exported (Id2, Is_Exported (Def_Id));
13842 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
13843 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
13848 ----------------------
13849 -- Export_Exception --
13850 ----------------------
13852 -- pragma Export_Exception (
13853 -- [Internal =>] LOCAL_NAME
13854 -- [, [External =>] EXTERNAL_SYMBOL]
13855 -- [, [Form =>] Ada | VMS]
13856 -- [, [Code =>] static_integer_EXPRESSION]);
13858 when Pragma_Export_Exception => Export_Exception : declare
13859 Args : Args_List (1 .. 4);
13860 Names : constant Name_List (1 .. 4) := (
13866 Internal : Node_Id renames Args (1);
13867 External : Node_Id renames Args (2);
13868 Form : Node_Id renames Args (3);
13869 Code : Node_Id renames Args (4);
13874 if Inside_A_Generic then
13875 Error_Pragma ("pragma% cannot be used for generic entities");
13878 Gather_Associations (Names, Args);
13879 Process_Extended_Import_Export_Exception_Pragma (
13880 Arg_Internal => Internal,
13881 Arg_External => External,
13885 if not Is_VMS_Exception (Entity (Internal)) then
13886 Set_Exported (Entity (Internal), Internal);
13888 end Export_Exception;
13890 ---------------------
13891 -- Export_Function --
13892 ---------------------
13894 -- pragma Export_Function (
13895 -- [Internal =>] LOCAL_NAME
13896 -- [, [External =>] EXTERNAL_SYMBOL]
13897 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13898 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13899 -- [, [Mechanism =>] MECHANISM]
13900 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13902 -- EXTERNAL_SYMBOL ::=
13904 -- | static_string_EXPRESSION
13906 -- PARAMETER_TYPES ::=
13908 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13910 -- TYPE_DESIGNATOR ::=
13912 -- | subtype_Name ' Access
13916 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13918 -- MECHANISM_ASSOCIATION ::=
13919 -- [formal_parameter_NAME =>] MECHANISM_NAME
13921 -- MECHANISM_NAME ::=
13924 -- | Descriptor [([Class =>] CLASS_NAME)]
13926 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13928 when Pragma_Export_Function => Export_Function : declare
13929 Args : Args_List (1 .. 6);
13930 Names : constant Name_List (1 .. 6) := (
13933 Name_Parameter_Types,
13936 Name_Result_Mechanism);
13938 Internal : Node_Id renames Args (1);
13939 External : Node_Id renames Args (2);
13940 Parameter_Types : Node_Id renames Args (3);
13941 Result_Type : Node_Id renames Args (4);
13942 Mechanism : Node_Id renames Args (5);
13943 Result_Mechanism : Node_Id renames Args (6);
13947 Gather_Associations (Names, Args);
13948 Process_Extended_Import_Export_Subprogram_Pragma (
13949 Arg_Internal => Internal,
13950 Arg_External => External,
13951 Arg_Parameter_Types => Parameter_Types,
13952 Arg_Result_Type => Result_Type,
13953 Arg_Mechanism => Mechanism,
13954 Arg_Result_Mechanism => Result_Mechanism);
13955 end Export_Function;
13957 -------------------
13958 -- Export_Object --
13959 -------------------
13961 -- pragma Export_Object (
13962 -- [Internal =>] LOCAL_NAME
13963 -- [, [External =>] EXTERNAL_SYMBOL]
13964 -- [, [Size =>] EXTERNAL_SYMBOL]);
13966 -- EXTERNAL_SYMBOL ::=
13968 -- | static_string_EXPRESSION
13970 -- PARAMETER_TYPES ::=
13972 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13974 -- TYPE_DESIGNATOR ::=
13976 -- | subtype_Name ' Access
13980 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13982 -- MECHANISM_ASSOCIATION ::=
13983 -- [formal_parameter_NAME =>] MECHANISM_NAME
13985 -- MECHANISM_NAME ::=
13988 -- | Descriptor [([Class =>] CLASS_NAME)]
13990 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
13992 when Pragma_Export_Object => Export_Object : declare
13993 Args : Args_List (1 .. 3);
13994 Names : constant Name_List (1 .. 3) := (
13999 Internal : Node_Id renames Args (1);
14000 External : Node_Id renames Args (2);
14001 Size : Node_Id renames Args (3);
14005 Gather_Associations (Names, Args);
14006 Process_Extended_Import_Export_Object_Pragma (
14007 Arg_Internal => Internal,
14008 Arg_External => External,
14012 ----------------------
14013 -- Export_Procedure --
14014 ----------------------
14016 -- pragma Export_Procedure (
14017 -- [Internal =>] LOCAL_NAME
14018 -- [, [External =>] EXTERNAL_SYMBOL]
14019 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14020 -- [, [Mechanism =>] MECHANISM]);
14022 -- EXTERNAL_SYMBOL ::=
14024 -- | static_string_EXPRESSION
14026 -- PARAMETER_TYPES ::=
14028 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14030 -- TYPE_DESIGNATOR ::=
14032 -- | subtype_Name ' Access
14036 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14038 -- MECHANISM_ASSOCIATION ::=
14039 -- [formal_parameter_NAME =>] MECHANISM_NAME
14041 -- MECHANISM_NAME ::=
14044 -- | Descriptor [([Class =>] CLASS_NAME)]
14046 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14048 when Pragma_Export_Procedure => Export_Procedure : declare
14049 Args : Args_List (1 .. 4);
14050 Names : constant Name_List (1 .. 4) := (
14053 Name_Parameter_Types,
14056 Internal : Node_Id renames Args (1);
14057 External : Node_Id renames Args (2);
14058 Parameter_Types : Node_Id renames Args (3);
14059 Mechanism : Node_Id renames Args (4);
14063 Gather_Associations (Names, Args);
14064 Process_Extended_Import_Export_Subprogram_Pragma (
14065 Arg_Internal => Internal,
14066 Arg_External => External,
14067 Arg_Parameter_Types => Parameter_Types,
14068 Arg_Mechanism => Mechanism);
14069 end Export_Procedure;
14075 -- pragma Export_Value (
14076 -- [Value =>] static_integer_EXPRESSION,
14077 -- [Link_Name =>] static_string_EXPRESSION);
14079 when Pragma_Export_Value =>
14081 Check_Arg_Order ((Name_Value, Name_Link_Name));
14082 Check_Arg_Count (2);
14084 Check_Optional_Identifier (Arg1, Name_Value);
14085 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14087 Check_Optional_Identifier (Arg2, Name_Link_Name);
14088 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14090 -----------------------------
14091 -- Export_Valued_Procedure --
14092 -----------------------------
14094 -- pragma Export_Valued_Procedure (
14095 -- [Internal =>] LOCAL_NAME
14096 -- [, [External =>] EXTERNAL_SYMBOL,]
14097 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14098 -- [, [Mechanism =>] MECHANISM]);
14100 -- EXTERNAL_SYMBOL ::=
14102 -- | static_string_EXPRESSION
14104 -- PARAMETER_TYPES ::=
14106 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14108 -- TYPE_DESIGNATOR ::=
14110 -- | subtype_Name ' Access
14114 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14116 -- MECHANISM_ASSOCIATION ::=
14117 -- [formal_parameter_NAME =>] MECHANISM_NAME
14119 -- MECHANISM_NAME ::=
14122 -- | Descriptor [([Class =>] CLASS_NAME)]
14124 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14126 when Pragma_Export_Valued_Procedure =>
14127 Export_Valued_Procedure : declare
14128 Args : Args_List (1 .. 4);
14129 Names : constant Name_List (1 .. 4) := (
14132 Name_Parameter_Types,
14135 Internal : Node_Id renames Args (1);
14136 External : Node_Id renames Args (2);
14137 Parameter_Types : Node_Id renames Args (3);
14138 Mechanism : Node_Id renames Args (4);
14142 Gather_Associations (Names, Args);
14143 Process_Extended_Import_Export_Subprogram_Pragma (
14144 Arg_Internal => Internal,
14145 Arg_External => External,
14146 Arg_Parameter_Types => Parameter_Types,
14147 Arg_Mechanism => Mechanism);
14148 end Export_Valued_Procedure;
14150 -------------------
14151 -- Extend_System --
14152 -------------------
14154 -- pragma Extend_System ([Name =>] Identifier);
14156 when Pragma_Extend_System => Extend_System : declare
14159 Check_Valid_Configuration_Pragma;
14160 Check_Arg_Count (1);
14161 Check_Optional_Identifier (Arg1, Name_Name);
14162 Check_Arg_Is_Identifier (Arg1);
14164 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14167 and then Name_Buffer (1 .. 4) = "aux_"
14169 if Present (System_Extend_Pragma_Arg) then
14170 if Chars (Get_Pragma_Arg (Arg1)) =
14171 Chars (Expression (System_Extend_Pragma_Arg))
14175 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14176 Error_Pragma ("pragma% conflicts with that #");
14180 System_Extend_Pragma_Arg := Arg1;
14182 if not GNAT_Mode then
14183 System_Extend_Unit := Arg1;
14187 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14191 ------------------------
14192 -- Extensions_Allowed --
14193 ------------------------
14195 -- pragma Extensions_Allowed (ON | OFF);
14197 when Pragma_Extensions_Allowed =>
14199 Check_Arg_Count (1);
14200 Check_No_Identifiers;
14201 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14203 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14204 Extensions_Allowed := True;
14205 Ada_Version := Ada_Version_Type'Last;
14208 Extensions_Allowed := False;
14209 Ada_Version := Ada_Version_Explicit;
14210 Ada_Version_Pragma := Empty;
14217 -- pragma External (
14218 -- [ Convention =>] convention_IDENTIFIER,
14219 -- [ Entity =>] LOCAL_NAME
14220 -- [, [External_Name =>] static_string_EXPRESSION ]
14221 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14223 when Pragma_External => External : declare
14224 Def_Id : Entity_Id;
14227 pragma Warnings (Off, C);
14234 Name_External_Name,
14236 Check_At_Least_N_Arguments (2);
14237 Check_At_Most_N_Arguments (4);
14238 Process_Convention (C, Def_Id);
14239 Note_Possible_Modification
14240 (Get_Pragma_Arg (Arg2), Sure => False);
14241 Process_Interface_Name (Def_Id, Arg3, Arg4);
14242 Set_Exported (Def_Id, Arg2);
14245 --------------------------
14246 -- External_Name_Casing --
14247 --------------------------
14249 -- pragma External_Name_Casing (
14250 -- UPPERCASE | LOWERCASE
14251 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14253 when Pragma_External_Name_Casing => External_Name_Casing : declare
14256 Check_No_Identifiers;
14258 if Arg_Count = 2 then
14259 Check_Arg_Is_One_Of
14260 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14262 case Chars (Get_Pragma_Arg (Arg2)) is
14264 Opt.External_Name_Exp_Casing := As_Is;
14266 when Name_Uppercase =>
14267 Opt.External_Name_Exp_Casing := Uppercase;
14269 when Name_Lowercase =>
14270 Opt.External_Name_Exp_Casing := Lowercase;
14277 Check_Arg_Count (1);
14280 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14282 case Chars (Get_Pragma_Arg (Arg1)) is
14283 when Name_Uppercase =>
14284 Opt.External_Name_Imp_Casing := Uppercase;
14286 when Name_Lowercase =>
14287 Opt.External_Name_Imp_Casing := Lowercase;
14292 end External_Name_Casing;
14298 -- pragma Fast_Math;
14300 when Pragma_Fast_Math =>
14302 Check_No_Identifiers;
14303 Check_Valid_Configuration_Pragma;
14306 --------------------------
14307 -- Favor_Top_Level --
14308 --------------------------
14310 -- pragma Favor_Top_Level (type_NAME);
14312 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14313 Named_Entity : Entity_Id;
14317 Check_No_Identifiers;
14318 Check_Arg_Count (1);
14319 Check_Arg_Is_Local_Name (Arg1);
14320 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
14322 -- If it's an access-to-subprogram type (in particular, not a
14323 -- subtype), set the flag on that type.
14325 if Is_Access_Subprogram_Type (Named_Entity) then
14326 Set_Can_Use_Internal_Rep (Named_Entity, False);
14328 -- Otherwise it's an error (name denotes the wrong sort of entity)
14332 ("access-to-subprogram type expected",
14333 Get_Pragma_Arg (Arg1));
14335 end Favor_Top_Level;
14337 ---------------------------
14338 -- Finalize_Storage_Only --
14339 ---------------------------
14341 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14343 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14344 Assoc : constant Node_Id := Arg1;
14345 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14350 Check_No_Identifiers;
14351 Check_Arg_Count (1);
14352 Check_Arg_Is_Local_Name (Arg1);
14354 Find_Type (Type_Id);
14355 Typ := Entity (Type_Id);
14358 or else Rep_Item_Too_Early (Typ, N)
14362 Typ := Underlying_Type (Typ);
14365 if not Is_Controlled (Typ) then
14366 Error_Pragma ("pragma% must specify controlled type");
14369 Check_First_Subtype (Arg1);
14371 if Finalize_Storage_Only (Typ) then
14372 Error_Pragma ("duplicate pragma%, only one allowed");
14374 elsif not Rep_Item_Too_Late (Typ, N) then
14375 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14377 end Finalize_Storage;
14379 --------------------------
14380 -- Float_Representation --
14381 --------------------------
14383 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
14385 -- FLOAT_REP ::= VAX_Float | IEEE_Float
14387 when Pragma_Float_Representation => Float_Representation : declare
14395 if Arg_Count = 1 then
14396 Check_Valid_Configuration_Pragma;
14398 Check_Arg_Count (2);
14399 Check_Optional_Identifier (Arg2, Name_Entity);
14400 Check_Arg_Is_Local_Name (Arg2);
14403 Check_No_Identifier (Arg1);
14404 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
14406 if not OpenVMS_On_Target then
14407 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14409 ("??pragma% ignored (applies only to Open'V'M'S)");
14415 -- One argument case
14417 if Arg_Count = 1 then
14418 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14419 if Opt.Float_Format = 'I' then
14420 Error_Pragma ("'I'E'E'E format previously specified");
14423 Opt.Float_Format := 'V';
14426 if Opt.Float_Format = 'V' then
14427 Error_Pragma ("'V'A'X format previously specified");
14430 Opt.Float_Format := 'I';
14433 Set_Standard_Fpt_Formats;
14435 -- Two argument case
14438 Argx := Get_Pragma_Arg (Arg2);
14440 if not Is_Entity_Name (Argx)
14441 or else not Is_Floating_Point_Type (Entity (Argx))
14444 ("second argument of% pragma must be floating-point type",
14448 Ent := Entity (Argx);
14449 Digs := UI_To_Int (Digits_Value (Ent));
14451 -- Two arguments, VAX_Float case
14453 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
14455 when 6 => Set_F_Float (Ent);
14456 when 9 => Set_D_Float (Ent);
14457 when 15 => Set_G_Float (Ent);
14461 ("wrong digits value, must be 6,9 or 15", Arg2);
14464 -- Two arguments, IEEE_Float case
14468 when 6 => Set_IEEE_Short (Ent);
14469 when 15 => Set_IEEE_Long (Ent);
14473 ("wrong digits value, must be 6 or 15", Arg2);
14477 end Float_Representation;
14483 -- pragma Global (GLOBAL_SPECIFICATION);
14485 -- GLOBAL_SPECIFICATION ::=
14488 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14490 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14492 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14493 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14494 -- GLOBAL_ITEM ::= NAME
14496 when Pragma_Global => Global : declare
14497 Subp_Decl : Node_Id;
14501 Check_Arg_Count (1);
14502 Ensure_Aggregate_Form (Arg1);
14504 -- Ensure the proper placement of the pragma. Global must be
14505 -- associated with a subprogram declaration or a body that acts
14509 Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
14511 if Nkind (Subp_Decl) = N_Subprogram_Declaration then
14514 -- Body acts as spec
14516 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14517 and then No (Corresponding_Spec (Subp_Decl))
14521 -- Body stub acts as spec
14523 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14524 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14533 -- When the pragma appears on a subprogram body, perform the full
14536 if Nkind (Subp_Decl) = N_Subprogram_Body then
14537 Analyze_Global_In_Decl_Part (N);
14539 -- When Global applies to a subprogram compilation unit, the
14540 -- corresponding pragma is placed after the unit's declaration
14541 -- node and needs to be analyzed immediately.
14543 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
14544 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
14546 Analyze_Global_In_Decl_Part (N);
14549 -- Chain the pragma on the contract for further processing
14551 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14558 -- pragma Ident (static_string_EXPRESSION)
14560 -- Note: pragma Comment shares this processing. Pragma Comment is
14561 -- identical to Ident, except that the restriction of the argument to
14562 -- 31 characters and the placement restrictions are not enforced for
14565 when Pragma_Ident | Pragma_Comment => Ident : declare
14570 Check_Arg_Count (1);
14571 Check_No_Identifiers;
14572 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
14575 -- For pragma Ident, preserve DEC compatibility by requiring the
14576 -- pragma to appear in a declarative part or package spec.
14578 if Prag_Id = Pragma_Ident then
14579 Check_Is_In_Decl_Part_Or_Package_Spec;
14582 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
14589 GP := Parent (Parent (N));
14591 if Nkind_In (GP, N_Package_Declaration,
14592 N_Generic_Package_Declaration)
14597 -- If we have a compilation unit, then record the ident value,
14598 -- checking for improper duplication.
14600 if Nkind (GP) = N_Compilation_Unit then
14601 CS := Ident_String (Current_Sem_Unit);
14603 if Present (CS) then
14605 -- For Ident, we do not permit multiple instances
14607 if Prag_Id = Pragma_Ident then
14608 Error_Pragma ("duplicate% pragma not permitted");
14610 -- For Comment, we concatenate the string, unless we want
14611 -- to preserve the tree structure for ASIS.
14613 elsif not ASIS_Mode then
14614 Start_String (Strval (CS));
14615 Store_String_Char (' ');
14616 Store_String_Chars (Strval (Str));
14617 Set_Strval (CS, End_String);
14621 -- In VMS, the effect of IDENT is achieved by passing
14622 -- --identification=name as a --for-linker switch.
14624 if OpenVMS_On_Target then
14627 ("--for-linker=--identification=");
14628 String_To_Name_Buffer (Strval (Str));
14629 Store_String_Chars (Name_Buffer (1 .. Name_Len));
14631 -- Only the last processed IDENT is saved. The main
14632 -- purpose is so an IDENT associated with a main
14633 -- procedure will be used in preference to an IDENT
14634 -- associated with a with'd package.
14636 Replace_Linker_Option_String
14637 (End_String, "--for-linker=--identification=");
14640 Set_Ident_String (Current_Sem_Unit, Str);
14643 -- For subunits, we just ignore the Ident, since in GNAT these
14644 -- are not separate object files, and hence not separate units
14645 -- in the unit table.
14647 elsif Nkind (GP) = N_Subunit then
14650 -- Otherwise we have a misplaced pragma Ident, but we ignore
14651 -- this if we are in an instantiation, since it comes from
14652 -- a generic, and has no relevance to the instantiation.
14654 elsif Prag_Id = Pragma_Ident then
14655 if Instantiation_Location (Loc) = No_Location then
14656 Error_Pragma ("pragma% only allowed at outer level");
14662 ----------------------------
14663 -- Implementation_Defined --
14664 ----------------------------
14666 -- pragma Implementation_Defined (LOCAL_NAME);
14668 -- Marks previously declared entity as implementation defined. For
14669 -- an overloaded entity, applies to the most recent homonym.
14671 -- pragma Implementation_Defined;
14673 -- The form with no arguments appears anywhere within a scope, most
14674 -- typically a package spec, and indicates that all entities that are
14675 -- defined within the package spec are Implementation_Defined.
14677 when Pragma_Implementation_Defined => Implementation_Defined : declare
14682 Check_No_Identifiers;
14684 -- Form with no arguments
14686 if Arg_Count = 0 then
14687 Set_Is_Implementation_Defined (Current_Scope);
14689 -- Form with one argument
14692 Check_Arg_Count (1);
14693 Check_Arg_Is_Local_Name (Arg1);
14694 Ent := Entity (Get_Pragma_Arg (Arg1));
14695 Set_Is_Implementation_Defined (Ent);
14697 end Implementation_Defined;
14703 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14705 -- IMPLEMENTATION_KIND ::=
14706 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14708 -- "By_Any" and "Optional" are treated as synonyms in order to
14709 -- support Ada 2012 aspect Synchronization.
14711 when Pragma_Implemented => Implemented : declare
14712 Proc_Id : Entity_Id;
14717 Check_Arg_Count (2);
14718 Check_No_Identifiers;
14719 Check_Arg_Is_Identifier (Arg1);
14720 Check_Arg_Is_Local_Name (Arg1);
14721 Check_Arg_Is_One_Of (Arg2,
14724 Name_By_Protected_Procedure,
14727 -- Extract the name of the local procedure
14729 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
14731 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14732 -- primitive procedure of a synchronized tagged type.
14734 if Ekind (Proc_Id) = E_Procedure
14735 and then Is_Primitive (Proc_Id)
14736 and then Present (First_Formal (Proc_Id))
14738 Typ := Etype (First_Formal (Proc_Id));
14740 if Is_Tagged_Type (Typ)
14743 -- Check for a protected, a synchronized or a task interface
14745 ((Is_Interface (Typ)
14746 and then Is_Synchronized_Interface (Typ))
14748 -- Check for a protected type or a task type that implements
14752 (Is_Concurrent_Record_Type (Typ)
14753 and then Present (Interfaces (Typ)))
14755 -- Check for a private record extension with keyword
14759 (Ekind_In (Typ, E_Record_Type_With_Private,
14760 E_Record_Subtype_With_Private)
14761 and then Synchronized_Present (Parent (Typ))))
14766 ("controlling formal must be of synchronized tagged type",
14771 -- Procedures declared inside a protected type must be accepted
14773 elsif Ekind (Proc_Id) = E_Procedure
14774 and then Is_Protected_Type (Scope (Proc_Id))
14778 -- The first argument is not a primitive procedure
14782 ("pragma % must be applied to a primitive procedure", Arg1);
14786 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14787 -- By_Protected_Procedure to the primitive procedure of a task
14790 if Chars (Arg2) = Name_By_Protected_Procedure
14791 and then Is_Interface (Typ)
14792 and then Is_Task_Interface (Typ)
14795 ("implementation kind By_Protected_Procedure cannot be "
14796 & "applied to a task interface primitive", Arg2);
14800 Record_Rep_Item (Proc_Id, N);
14803 ----------------------
14804 -- Implicit_Packing --
14805 ----------------------
14807 -- pragma Implicit_Packing;
14809 when Pragma_Implicit_Packing =>
14811 Check_Arg_Count (0);
14812 Implicit_Packing := True;
14819 -- [Convention =>] convention_IDENTIFIER,
14820 -- [Entity =>] LOCAL_NAME
14821 -- [, [External_Name =>] static_string_EXPRESSION ]
14822 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14824 when Pragma_Import =>
14825 Check_Ada_83_Warning;
14829 Name_External_Name,
14832 Check_At_Least_N_Arguments (2);
14833 Check_At_Most_N_Arguments (4);
14834 Process_Import_Or_Interface;
14836 ----------------------
14837 -- Import_Exception --
14838 ----------------------
14840 -- pragma Import_Exception (
14841 -- [Internal =>] LOCAL_NAME
14842 -- [, [External =>] EXTERNAL_SYMBOL]
14843 -- [, [Form =>] Ada | VMS]
14844 -- [, [Code =>] static_integer_EXPRESSION]);
14846 when Pragma_Import_Exception => Import_Exception : declare
14847 Args : Args_List (1 .. 4);
14848 Names : constant Name_List (1 .. 4) := (
14854 Internal : Node_Id renames Args (1);
14855 External : Node_Id renames Args (2);
14856 Form : Node_Id renames Args (3);
14857 Code : Node_Id renames Args (4);
14861 Gather_Associations (Names, Args);
14863 if Present (External) and then Present (Code) then
14865 ("cannot give both External and Code options for pragma%");
14868 Process_Extended_Import_Export_Exception_Pragma (
14869 Arg_Internal => Internal,
14870 Arg_External => External,
14874 if not Is_VMS_Exception (Entity (Internal)) then
14875 Set_Imported (Entity (Internal));
14877 end Import_Exception;
14879 ---------------------
14880 -- Import_Function --
14881 ---------------------
14883 -- pragma Import_Function (
14884 -- [Internal =>] LOCAL_NAME,
14885 -- [, [External =>] EXTERNAL_SYMBOL]
14886 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14887 -- [, [Result_Type =>] SUBTYPE_MARK]
14888 -- [, [Mechanism =>] MECHANISM]
14889 -- [, [Result_Mechanism =>] MECHANISM_NAME]
14890 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14892 -- EXTERNAL_SYMBOL ::=
14894 -- | static_string_EXPRESSION
14896 -- PARAMETER_TYPES ::=
14898 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14900 -- TYPE_DESIGNATOR ::=
14902 -- | subtype_Name ' Access
14906 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14908 -- MECHANISM_ASSOCIATION ::=
14909 -- [formal_parameter_NAME =>] MECHANISM_NAME
14911 -- MECHANISM_NAME ::=
14914 -- | Descriptor [([Class =>] CLASS_NAME)]
14916 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
14918 when Pragma_Import_Function => Import_Function : declare
14919 Args : Args_List (1 .. 7);
14920 Names : constant Name_List (1 .. 7) := (
14923 Name_Parameter_Types,
14926 Name_Result_Mechanism,
14927 Name_First_Optional_Parameter);
14929 Internal : Node_Id renames Args (1);
14930 External : Node_Id renames Args (2);
14931 Parameter_Types : Node_Id renames Args (3);
14932 Result_Type : Node_Id renames Args (4);
14933 Mechanism : Node_Id renames Args (5);
14934 Result_Mechanism : Node_Id renames Args (6);
14935 First_Optional_Parameter : Node_Id renames Args (7);
14939 Gather_Associations (Names, Args);
14940 Process_Extended_Import_Export_Subprogram_Pragma (
14941 Arg_Internal => Internal,
14942 Arg_External => External,
14943 Arg_Parameter_Types => Parameter_Types,
14944 Arg_Result_Type => Result_Type,
14945 Arg_Mechanism => Mechanism,
14946 Arg_Result_Mechanism => Result_Mechanism,
14947 Arg_First_Optional_Parameter => First_Optional_Parameter);
14948 end Import_Function;
14950 -------------------
14951 -- Import_Object --
14952 -------------------
14954 -- pragma Import_Object (
14955 -- [Internal =>] LOCAL_NAME
14956 -- [, [External =>] EXTERNAL_SYMBOL]
14957 -- [, [Size =>] EXTERNAL_SYMBOL]);
14959 -- EXTERNAL_SYMBOL ::=
14961 -- | static_string_EXPRESSION
14963 when Pragma_Import_Object => Import_Object : declare
14964 Args : Args_List (1 .. 3);
14965 Names : constant Name_List (1 .. 3) := (
14970 Internal : Node_Id renames Args (1);
14971 External : Node_Id renames Args (2);
14972 Size : Node_Id renames Args (3);
14976 Gather_Associations (Names, Args);
14977 Process_Extended_Import_Export_Object_Pragma (
14978 Arg_Internal => Internal,
14979 Arg_External => External,
14983 ----------------------
14984 -- Import_Procedure --
14985 ----------------------
14987 -- pragma Import_Procedure (
14988 -- [Internal =>] LOCAL_NAME
14989 -- [, [External =>] EXTERNAL_SYMBOL]
14990 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14991 -- [, [Mechanism =>] MECHANISM]
14992 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
14994 -- EXTERNAL_SYMBOL ::=
14996 -- | static_string_EXPRESSION
14998 -- PARAMETER_TYPES ::=
15000 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15002 -- TYPE_DESIGNATOR ::=
15004 -- | subtype_Name ' Access
15008 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15010 -- MECHANISM_ASSOCIATION ::=
15011 -- [formal_parameter_NAME =>] MECHANISM_NAME
15013 -- MECHANISM_NAME ::=
15016 -- | Descriptor [([Class =>] CLASS_NAME)]
15018 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
15020 when Pragma_Import_Procedure => Import_Procedure : declare
15021 Args : Args_List (1 .. 5);
15022 Names : constant Name_List (1 .. 5) := (
15025 Name_Parameter_Types,
15027 Name_First_Optional_Parameter);
15029 Internal : Node_Id renames Args (1);
15030 External : Node_Id renames Args (2);
15031 Parameter_Types : Node_Id renames Args (3);
15032 Mechanism : Node_Id renames Args (4);
15033 First_Optional_Parameter : Node_Id renames Args (5);
15037 Gather_Associations (Names, Args);
15038 Process_Extended_Import_Export_Subprogram_Pragma (
15039 Arg_Internal => Internal,
15040 Arg_External => External,
15041 Arg_Parameter_Types => Parameter_Types,
15042 Arg_Mechanism => Mechanism,
15043 Arg_First_Optional_Parameter => First_Optional_Parameter);
15044 end Import_Procedure;
15046 -----------------------------
15047 -- Import_Valued_Procedure --
15048 -----------------------------
15050 -- pragma Import_Valued_Procedure (
15051 -- [Internal =>] LOCAL_NAME
15052 -- [, [External =>] EXTERNAL_SYMBOL]
15053 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15054 -- [, [Mechanism =>] MECHANISM]
15055 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
15057 -- EXTERNAL_SYMBOL ::=
15059 -- | static_string_EXPRESSION
15061 -- PARAMETER_TYPES ::=
15063 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15065 -- TYPE_DESIGNATOR ::=
15067 -- | subtype_Name ' Access
15071 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15073 -- MECHANISM_ASSOCIATION ::=
15074 -- [formal_parameter_NAME =>] MECHANISM_NAME
15076 -- MECHANISM_NAME ::=
15079 -- | Descriptor [([Class =>] CLASS_NAME)]
15081 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
15083 when Pragma_Import_Valued_Procedure =>
15084 Import_Valued_Procedure : declare
15085 Args : Args_List (1 .. 5);
15086 Names : constant Name_List (1 .. 5) := (
15089 Name_Parameter_Types,
15091 Name_First_Optional_Parameter);
15093 Internal : Node_Id renames Args (1);
15094 External : Node_Id renames Args (2);
15095 Parameter_Types : Node_Id renames Args (3);
15096 Mechanism : Node_Id renames Args (4);
15097 First_Optional_Parameter : Node_Id renames Args (5);
15101 Gather_Associations (Names, Args);
15102 Process_Extended_Import_Export_Subprogram_Pragma (
15103 Arg_Internal => Internal,
15104 Arg_External => External,
15105 Arg_Parameter_Types => Parameter_Types,
15106 Arg_Mechanism => Mechanism,
15107 Arg_First_Optional_Parameter => First_Optional_Parameter);
15108 end Import_Valued_Procedure;
15114 -- pragma Independent (record_component_LOCAL_NAME);
15116 when Pragma_Independent => Independent : declare
15121 Check_Ada_83_Warning;
15123 Check_No_Identifiers;
15124 Check_Arg_Count (1);
15125 Check_Arg_Is_Local_Name (Arg1);
15126 E_Id := Get_Pragma_Arg (Arg1);
15128 if Etype (E_Id) = Any_Type then
15132 E := Entity (E_Id);
15134 -- Check we have a record component. We have not yet setup
15135 -- components fully, so identify by syntactic structure.
15137 if Nkind (Declaration_Node (E)) /= N_Component_Declaration then
15139 ("argument for pragma% must be record component", Arg1);
15142 -- Check duplicate before we chain ourselves
15144 Check_Duplicate_Pragma (E);
15148 if Rep_Item_Too_Early (E, N)
15150 Rep_Item_Too_Late (E, N)
15155 -- Set flag in component
15157 Set_Is_Independent (E);
15159 Independence_Checks.Append ((N, E));
15162 ----------------------------
15163 -- Independent_Components --
15164 ----------------------------
15166 -- pragma Atomic_Components (array_LOCAL_NAME);
15168 -- This processing is shared by Volatile_Components
15170 when Pragma_Independent_Components => Independent_Components : declare
15178 Check_Ada_83_Warning;
15180 Check_No_Identifiers;
15181 Check_Arg_Count (1);
15182 Check_Arg_Is_Local_Name (Arg1);
15183 E_Id := Get_Pragma_Arg (Arg1);
15185 if Etype (E_Id) = Any_Type then
15189 E := Entity (E_Id);
15191 -- Check duplicate before we chain ourselves
15193 Check_Duplicate_Pragma (E);
15195 -- Check appropriate entity
15197 if Rep_Item_Too_Early (E, N)
15199 Rep_Item_Too_Late (E, N)
15204 D := Declaration_Node (E);
15207 if K = N_Full_Type_Declaration
15208 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15210 Independence_Checks.Append ((N, Base_Type (E)));
15211 Set_Has_Independent_Components (Base_Type (E));
15213 -- For record type, set all components independent
15215 if Is_Record_Type (E) then
15216 C := First_Component (E);
15217 while Present (C) loop
15218 Set_Is_Independent (C);
15219 Next_Component (C);
15223 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15224 and then Nkind (D) = N_Object_Declaration
15225 and then Nkind (Object_Definition (D)) =
15226 N_Constrained_Array_Definition
15228 Independence_Checks.Append ((N, Base_Type (Etype (E))));
15229 Set_Has_Independent_Components (Base_Type (Etype (E)));
15232 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15234 end Independent_Components;
15236 -----------------------
15237 -- Initial_Condition --
15238 -----------------------
15240 -- pragma Initial_Condition (boolean_EXPRESSION);
15242 when Pragma_Initial_Condition => Initial_Condition : declare
15243 Context : constant Node_Id := Parent (Parent (N));
15244 Pack_Id : Entity_Id;
15249 Check_Arg_Count (1);
15251 -- Ensure the proper placement of the pragma. Initial_Condition
15252 -- must be associated with a package declaration.
15254 if not Nkind_In (Context, N_Generic_Package_Declaration,
15255 N_Package_Declaration)
15262 while Present (Stmt) loop
15264 -- Skip prior pragmas, but check for duplicates
15266 if Nkind (Stmt) = N_Pragma then
15267 if Pragma_Name (Stmt) = Pname then
15268 Error_Msg_Name_1 := Pname;
15269 Error_Msg_Sloc := Sloc (Stmt);
15270 Error_Msg_N ("pragma % duplicates pragma declared #", N);
15273 -- Skip internally generated code
15275 elsif not Comes_From_Source (Stmt) then
15278 -- The pragma does not apply to a legal construct, issue an
15279 -- error and stop the analysis.
15286 Stmt := Prev (Stmt);
15289 -- The pragma must be analyzed at the end of the visible
15290 -- declarations of the related package. Save the pragma for later
15291 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
15292 -- the contract of the package.
15294 Pack_Id := Defining_Entity (Context);
15295 Add_Contract_Item (N, Pack_Id);
15297 -- Verify the declaration order of pragma Initial_Condition with
15298 -- respect to pragmas Abstract_State and Initializes when SPARK
15299 -- checks are enabled.
15301 if SPARK_Mode /= Off then
15302 Check_Declaration_Order
15303 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15306 Check_Declaration_Order
15307 (First => Get_Pragma (Pack_Id, Pragma_Initializes),
15310 end Initial_Condition;
15312 ------------------------
15313 -- Initialize_Scalars --
15314 ------------------------
15316 -- pragma Initialize_Scalars;
15318 when Pragma_Initialize_Scalars =>
15320 Check_Arg_Count (0);
15321 Check_Valid_Configuration_Pragma;
15322 Check_Restriction (No_Initialize_Scalars, N);
15324 -- Initialize_Scalars creates false positives in CodePeer, and
15325 -- incorrect negative results in GNATprove mode, so ignore this
15326 -- pragma in these modes.
15328 if not Restriction_Active (No_Initialize_Scalars)
15329 and then not (CodePeer_Mode or GNATprove_Mode)
15331 Init_Or_Norm_Scalars := True;
15332 Initialize_Scalars := True;
15339 -- pragma Initializes (INITIALIZATION_SPEC);
15341 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15343 -- INITIALIZATION_LIST ::=
15344 -- INITIALIZATION_ITEM
15345 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15347 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15352 -- | (INPUT {, INPUT})
15356 when Pragma_Initializes => Initializes : declare
15357 Context : constant Node_Id := Parent (Parent (N));
15358 Pack_Id : Entity_Id;
15363 Check_Arg_Count (1);
15364 Ensure_Aggregate_Form (Arg1);
15366 -- Ensure the proper placement of the pragma. Initializes must be
15367 -- associated with a package declaration.
15369 if not Nkind_In (Context, N_Generic_Package_Declaration,
15370 N_Package_Declaration)
15377 while Present (Stmt) loop
15379 -- Skip prior pragmas, but check for duplicates
15381 if Nkind (Stmt) = N_Pragma then
15382 if Pragma_Name (Stmt) = Pname then
15383 Error_Msg_Name_1 := Pname;
15384 Error_Msg_Sloc := Sloc (Stmt);
15385 Error_Msg_N ("pragma % duplicates pragma declared #", N);
15388 -- Skip internally generated code
15390 elsif not Comes_From_Source (Stmt) then
15393 -- The pragma does not apply to a legal construct, issue an
15394 -- error and stop the analysis.
15401 Stmt := Prev (Stmt);
15404 -- The pragma must be analyzed at the end of the visible
15405 -- declarations of the related package. Save the pragma for later
15406 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
15407 -- contract of the package.
15409 Pack_Id := Defining_Entity (Context);
15410 Add_Contract_Item (N, Pack_Id);
15412 -- Verify the declaration order of pragmas Abstract_State and
15413 -- Initializes when SPARK checks are enabled.
15415 if SPARK_Mode /= Off then
15416 Check_Declaration_Order
15417 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State),
15426 -- pragma Inline ( NAME {, NAME} );
15428 when Pragma_Inline =>
15430 -- Inline status is Enabled if inlining option is active
15432 if Inline_Active then
15433 Process_Inline (Enabled);
15435 Process_Inline (Disabled);
15438 -------------------
15439 -- Inline_Always --
15440 -------------------
15442 -- pragma Inline_Always ( NAME {, NAME} );
15444 when Pragma_Inline_Always =>
15447 -- Pragma always active unless in CodePeer mode. It is disabled
15448 -- in CodePeer mode because inlining is not helpful, and enabling
15449 -- if caused walk order issues.
15451 -- Historical note: this pragma used to be disabled in GNATprove
15452 -- mode as well, but that was odd since walk order should not be
15453 -- an issue in that case.
15455 if not CodePeer_Mode then
15456 Process_Inline (Enabled);
15459 --------------------
15460 -- Inline_Generic --
15461 --------------------
15463 -- pragma Inline_Generic (NAME {, NAME});
15465 when Pragma_Inline_Generic =>
15467 Process_Generic_List;
15469 ----------------------
15470 -- Inspection_Point --
15471 ----------------------
15473 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15475 when Pragma_Inspection_Point => Inspection_Point : declare
15482 if Arg_Count > 0 then
15485 Exp := Get_Pragma_Arg (Arg);
15488 if not Is_Entity_Name (Exp)
15489 or else not Is_Object (Entity (Exp))
15491 Error_Pragma_Arg ("object name required", Arg);
15495 exit when No (Arg);
15498 end Inspection_Point;
15504 -- pragma Interface (
15505 -- [ Convention =>] convention_IDENTIFIER,
15506 -- [ Entity =>] LOCAL_NAME
15507 -- [, [External_Name =>] static_string_EXPRESSION ]
15508 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15510 when Pragma_Interface =>
15515 Name_External_Name,
15517 Check_At_Least_N_Arguments (2);
15518 Check_At_Most_N_Arguments (4);
15519 Process_Import_Or_Interface;
15521 -- In Ada 2005, the permission to use Interface (a reserved word)
15522 -- as a pragma name is considered an obsolescent feature, and this
15523 -- pragma was already obsolescent in Ada 95.
15525 if Ada_Version >= Ada_95 then
15527 (No_Obsolescent_Features, Pragma_Identifier (N));
15529 if Warn_On_Obsolescent_Feature then
15531 ("pragma Interface is an obsolescent feature?j?", N);
15533 ("|use pragma Import instead?j?", N);
15537 --------------------
15538 -- Interface_Name --
15539 --------------------
15541 -- pragma Interface_Name (
15542 -- [ Entity =>] LOCAL_NAME
15543 -- [,[External_Name =>] static_string_EXPRESSION ]
15544 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15546 when Pragma_Interface_Name => Interface_Name : declare
15548 Def_Id : Entity_Id;
15549 Hom_Id : Entity_Id;
15555 ((Name_Entity, Name_External_Name, Name_Link_Name));
15556 Check_At_Least_N_Arguments (2);
15557 Check_At_Most_N_Arguments (3);
15558 Id := Get_Pragma_Arg (Arg1);
15561 -- This is obsolete from Ada 95 on, but it is an implementation
15562 -- defined pragma, so we do not consider that it violates the
15563 -- restriction (No_Obsolescent_Features).
15565 if Ada_Version >= Ada_95 then
15566 if Warn_On_Obsolescent_Feature then
15568 ("pragma Interface_Name is an obsolescent feature?j?", N);
15570 ("|use pragma Import instead?j?", N);
15574 if not Is_Entity_Name (Id) then
15576 ("first argument for pragma% must be entity name", Arg1);
15577 elsif Etype (Id) = Any_Type then
15580 Def_Id := Entity (Id);
15583 -- Special DEC-compatible processing for the object case, forces
15584 -- object to be imported.
15586 if Ekind (Def_Id) = E_Variable then
15587 Kill_Size_Check_Code (Def_Id);
15588 Note_Possible_Modification (Id, Sure => False);
15590 -- Initialization is not allowed for imported variable
15592 if Present (Expression (Parent (Def_Id)))
15593 and then Comes_From_Source (Expression (Parent (Def_Id)))
15595 Error_Msg_Sloc := Sloc (Def_Id);
15597 ("no initialization allowed for declaration of& #",
15601 -- For compatibility, support VADS usage of providing both
15602 -- pragmas Interface and Interface_Name to obtain the effect
15603 -- of a single Import pragma.
15605 if Is_Imported (Def_Id)
15606 and then Present (First_Rep_Item (Def_Id))
15607 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
15609 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
15613 Set_Imported (Def_Id);
15616 Set_Is_Public (Def_Id);
15617 Process_Interface_Name (Def_Id, Arg2, Arg3);
15620 -- Otherwise must be subprogram
15622 elsif not Is_Subprogram (Def_Id) then
15624 ("argument of pragma% is not subprogram", Arg1);
15627 Check_At_Most_N_Arguments (3);
15631 -- Loop through homonyms
15634 Def_Id := Get_Base_Subprogram (Hom_Id);
15636 if Is_Imported (Def_Id) then
15637 Process_Interface_Name (Def_Id, Arg2, Arg3);
15641 exit when From_Aspect_Specification (N);
15642 Hom_Id := Homonym (Hom_Id);
15644 exit when No (Hom_Id)
15645 or else Scope (Hom_Id) /= Current_Scope;
15650 ("argument of pragma% is not imported subprogram",
15654 end Interface_Name;
15656 -----------------------
15657 -- Interrupt_Handler --
15658 -----------------------
15660 -- pragma Interrupt_Handler (handler_NAME);
15662 when Pragma_Interrupt_Handler =>
15663 Check_Ada_83_Warning;
15664 Check_Arg_Count (1);
15665 Check_No_Identifiers;
15667 if No_Run_Time_Mode then
15668 Error_Msg_CRT ("Interrupt_Handler pragma", N);
15670 Check_Interrupt_Or_Attach_Handler;
15671 Process_Interrupt_Or_Attach_Handler;
15674 ------------------------
15675 -- Interrupt_Priority --
15676 ------------------------
15678 -- pragma Interrupt_Priority [(EXPRESSION)];
15680 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
15681 P : constant Node_Id := Parent (N);
15686 Check_Ada_83_Warning;
15688 if Arg_Count /= 0 then
15689 Arg := Get_Pragma_Arg (Arg1);
15690 Check_Arg_Count (1);
15691 Check_No_Identifiers;
15693 -- The expression must be analyzed in the special manner
15694 -- described in "Handling of Default and Per-Object
15695 -- Expressions" in sem.ads.
15697 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
15700 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
15705 Ent := Defining_Identifier (Parent (P));
15707 -- Check duplicate pragma before we chain the pragma in the Rep
15708 -- Item chain of Ent.
15710 Check_Duplicate_Pragma (Ent);
15711 Record_Rep_Item (Ent, N);
15713 end Interrupt_Priority;
15715 ---------------------
15716 -- Interrupt_State --
15717 ---------------------
15719 -- pragma Interrupt_State (
15720 -- [Name =>] INTERRUPT_ID,
15721 -- [State =>] INTERRUPT_STATE);
15723 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15724 -- INTERRUPT_STATE => System | Runtime | User
15726 -- Note: if the interrupt id is given as an identifier, then it must
15727 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15728 -- given as a static integer expression which must be in the range of
15729 -- Ada.Interrupts.Interrupt_ID.
15731 when Pragma_Interrupt_State => Interrupt_State : declare
15732 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
15733 -- This is the entity Ada.Interrupts.Interrupt_ID;
15735 State_Type : Character;
15736 -- Set to 's'/'r'/'u' for System/Runtime/User
15739 -- Index to entry in Interrupt_States table
15742 -- Value of interrupt
15744 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
15745 -- The first argument to the pragma
15747 Int_Ent : Entity_Id;
15748 -- Interrupt entity in Ada.Interrupts.Names
15752 Check_Arg_Order ((Name_Name, Name_State));
15753 Check_Arg_Count (2);
15755 Check_Optional_Identifier (Arg1, Name_Name);
15756 Check_Optional_Identifier (Arg2, Name_State);
15757 Check_Arg_Is_Identifier (Arg2);
15759 -- First argument is identifier
15761 if Nkind (Arg1X) = N_Identifier then
15763 -- Search list of names in Ada.Interrupts.Names
15765 Int_Ent := First_Entity (RTE (RE_Names));
15767 if No (Int_Ent) then
15768 Error_Pragma_Arg ("invalid interrupt name", Arg1);
15770 elsif Chars (Int_Ent) = Chars (Arg1X) then
15771 Int_Val := Expr_Value (Constant_Value (Int_Ent));
15775 Next_Entity (Int_Ent);
15778 -- First argument is not an identifier, so it must be a static
15779 -- expression of type Ada.Interrupts.Interrupt_ID.
15782 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
15783 Int_Val := Expr_Value (Arg1X);
15785 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
15787 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
15790 ("value not in range of type "
15791 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
15797 case Chars (Get_Pragma_Arg (Arg2)) is
15798 when Name_Runtime => State_Type := 'r';
15799 when Name_System => State_Type := 's';
15800 when Name_User => State_Type := 'u';
15803 Error_Pragma_Arg ("invalid interrupt state", Arg2);
15806 -- Check if entry is already stored
15808 IST_Num := Interrupt_States.First;
15810 -- If entry not found, add it
15812 if IST_Num > Interrupt_States.Last then
15813 Interrupt_States.Append
15814 ((Interrupt_Number => UI_To_Int (Int_Val),
15815 Interrupt_State => State_Type,
15816 Pragma_Loc => Loc));
15819 -- Case of entry for the same entry
15821 elsif Int_Val = Interrupt_States.Table (IST_Num).
15824 -- If state matches, done, no need to make redundant entry
15827 State_Type = Interrupt_States.Table (IST_Num).
15830 -- Otherwise if state does not match, error
15833 Interrupt_States.Table (IST_Num).Pragma_Loc;
15835 ("state conflicts with that given #", Arg2);
15839 IST_Num := IST_Num + 1;
15841 end Interrupt_State;
15847 -- pragma Invariant
15848 -- ([Entity =>] type_LOCAL_NAME,
15849 -- [Check =>] EXPRESSION
15850 -- [,[Message =>] String_Expression]);
15852 when Pragma_Invariant => Invariant : declare
15860 Check_At_Least_N_Arguments (2);
15861 Check_At_Most_N_Arguments (3);
15862 Check_Optional_Identifier (Arg1, Name_Entity);
15863 Check_Optional_Identifier (Arg2, Name_Check);
15865 if Arg_Count = 3 then
15866 Check_Optional_Identifier (Arg3, Name_Message);
15867 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
15870 Check_Arg_Is_Local_Name (Arg1);
15872 Type_Id := Get_Pragma_Arg (Arg1);
15873 Find_Type (Type_Id);
15874 Typ := Entity (Type_Id);
15876 if Typ = Any_Type then
15879 -- An invariant must apply to a private type, or appear in the
15880 -- private part of a package spec and apply to a completion.
15881 -- a class-wide invariant can only appear on a private declaration
15882 -- or private extension, not a completion.
15884 elsif Ekind_In (Typ, E_Private_Type,
15885 E_Record_Type_With_Private,
15886 E_Limited_Private_Type)
15890 elsif In_Private_Part (Current_Scope)
15891 and then Has_Private_Declaration (Typ)
15892 and then not Class_Present (N)
15896 elsif In_Private_Part (Current_Scope) then
15898 ("pragma% only allowed for private type declared in "
15899 & "visible part", Arg1);
15903 ("pragma% only allowed for private type", Arg1);
15906 -- Note that the type has at least one invariant, and also that
15907 -- it has inheritable invariants if we have Invariant'Class
15908 -- or Type_Invariant'Class. Build the corresponding invariant
15909 -- procedure declaration, so that calls to it can be generated
15910 -- before the body is built (e.g. within an expression function).
15912 PDecl := Build_Invariant_Procedure_Declaration (Typ);
15914 Insert_After (N, PDecl);
15917 if Class_Present (N) then
15918 Set_Has_Inheritable_Invariants (Typ);
15921 -- The remaining processing is simply to link the pragma on to
15922 -- the rep item chain, for processing when the type is frozen.
15923 -- This is accomplished by a call to Rep_Item_Too_Late.
15925 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15928 ----------------------
15929 -- Java_Constructor --
15930 ----------------------
15932 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15934 -- Also handles pragma CIL_Constructor
15936 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
15937 Java_Constructor : declare
15938 Convention : Convention_Id;
15939 Def_Id : Entity_Id;
15940 Hom_Id : Entity_Id;
15942 This_Formal : Entity_Id;
15946 Check_Arg_Count (1);
15947 Check_Optional_Identifier (Arg1, Name_Entity);
15948 Check_Arg_Is_Local_Name (Arg1);
15950 Id := Get_Pragma_Arg (Arg1);
15951 Find_Program_Unit_Name (Id);
15953 -- If we did not find the name, we are done
15955 if Etype (Id) = Any_Type then
15959 -- Check wrong use of pragma in wrong VM target
15961 if VM_Target = No_VM then
15964 elsif VM_Target = CLI_Target
15965 and then Prag_Id = Pragma_Java_Constructor
15967 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
15969 elsif VM_Target = JVM_Target
15970 and then Prag_Id = Pragma_CIL_Constructor
15972 Error_Pragma ("must use pragma 'Java_'Constructor");
15976 when Pragma_CIL_Constructor => Convention := Convention_CIL;
15977 when Pragma_Java_Constructor => Convention := Convention_Java;
15978 when others => null;
15981 Hom_Id := Entity (Id);
15983 -- Loop through homonyms
15986 Def_Id := Get_Base_Subprogram (Hom_Id);
15988 -- The constructor is required to be a function
15990 if Ekind (Def_Id) /= E_Function then
15991 if VM_Target = JVM_Target then
15993 ("pragma% requires function returning a 'Java access "
15997 ("pragma% requires function returning a 'C'I'L access "
16002 -- Check arguments: For tagged type the first formal must be
16003 -- named "this" and its type must be a named access type
16004 -- designating a class-wide tagged type that has convention
16005 -- CIL/Java. The first formal must also have a null default
16006 -- value. For example:
16008 -- type Typ is tagged ...
16009 -- type Ref is access all Typ;
16010 -- pragma Convention (CIL, Typ);
16012 -- function New_Typ (This : Ref) return Ref;
16013 -- function New_Typ (This : Ref; I : Integer) return Ref;
16014 -- pragma Cil_Constructor (New_Typ);
16016 -- Reason: The first formal must NOT be a primitive of the
16019 -- This rule also applies to constructors of delegates used
16020 -- to interface with standard target libraries. For example:
16022 -- type Delegate is access procedure ...
16023 -- pragma Import (CIL, Delegate, ...);
16025 -- function new_Delegate
16026 -- (This : Delegate := null; ... ) return Delegate;
16028 -- For value-types this rule does not apply.
16030 if not Is_Value_Type (Etype (Def_Id)) then
16031 if No (First_Formal (Def_Id)) then
16032 Error_Msg_Name_1 := Pname;
16033 Error_Msg_N ("% function must have parameters", Def_Id);
16037 -- In the JRE library we have several occurrences in which
16038 -- the "this" parameter is not the first formal.
16040 This_Formal := First_Formal (Def_Id);
16042 -- In the JRE library we have several occurrences in which
16043 -- the "this" parameter is not the first formal. Search for
16046 if VM_Target = JVM_Target then
16047 while Present (This_Formal)
16048 and then Get_Name_String (Chars (This_Formal)) /= "this"
16050 Next_Formal (This_Formal);
16053 if No (This_Formal) then
16054 This_Formal := First_Formal (Def_Id);
16058 -- Warning: The first parameter should be named "this".
16059 -- We temporarily allow it because we have the following
16060 -- case in the Java runtime (file s-osinte.ads) ???
16062 -- function new_Thread
16063 -- (Self_Id : System.Address) return Thread_Id;
16064 -- pragma Java_Constructor (new_Thread);
16066 if VM_Target = JVM_Target
16067 and then Get_Name_String (Chars (First_Formal (Def_Id)))
16069 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
16073 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
16074 Error_Msg_Name_1 := Pname;
16076 ("first formal of % function must be named `this`",
16077 Parent (This_Formal));
16079 elsif not Is_Access_Type (Etype (This_Formal)) then
16080 Error_Msg_Name_1 := Pname;
16082 ("first formal of % function must be an access type",
16083 Parameter_Type (Parent (This_Formal)));
16085 -- For delegates the type of the first formal must be a
16086 -- named access-to-subprogram type (see previous example)
16088 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
16089 and then Ekind (Etype (This_Formal))
16090 /= E_Access_Subprogram_Type
16092 Error_Msg_Name_1 := Pname;
16094 ("first formal of % function must be a named access "
16095 & "to subprogram type",
16096 Parameter_Type (Parent (This_Formal)));
16098 -- Warning: We should reject anonymous access types because
16099 -- the constructor must not be handled as a primitive of the
16100 -- tagged type. We temporarily allow it because this profile
16101 -- is currently generated by cil2ada???
16103 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
16104 and then not Ekind_In (Etype (This_Formal),
16106 E_General_Access_Type,
16107 E_Anonymous_Access_Type)
16109 Error_Msg_Name_1 := Pname;
16111 ("first formal of % function must be a named access "
16112 & "type", Parameter_Type (Parent (This_Formal)));
16114 elsif Atree.Convention
16115 (Designated_Type (Etype (This_Formal))) /= Convention
16117 Error_Msg_Name_1 := Pname;
16119 if Convention = Convention_Java then
16121 ("pragma% requires convention 'Cil in designated "
16122 & "type", Parameter_Type (Parent (This_Formal)));
16125 ("pragma% requires convention 'Java in designated "
16126 & "type", Parameter_Type (Parent (This_Formal)));
16129 elsif No (Expression (Parent (This_Formal)))
16130 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
16132 Error_Msg_Name_1 := Pname;
16134 ("pragma% requires first formal with default `null`",
16135 Parameter_Type (Parent (This_Formal)));
16139 -- Check result type: the constructor must be a function
16141 -- * a value type (only allowed in the CIL compiler)
16142 -- * an access-to-subprogram type with convention Java/CIL
16143 -- * an access-type designating a type that has convention
16146 if Is_Value_Type (Etype (Def_Id)) then
16149 -- Access-to-subprogram type with convention Java/CIL
16151 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
16152 if Atree.Convention (Etype (Def_Id)) /= Convention then
16153 if Convention = Convention_Java then
16155 ("pragma% requires function returning a 'Java "
16156 & "access type", Arg1);
16158 pragma Assert (Convention = Convention_CIL);
16160 ("pragma% requires function returning a 'C'I'L "
16161 & "access type", Arg1);
16165 elsif Is_Access_Type (Etype (Def_Id)) then
16166 if not Ekind_In (Etype (Def_Id), E_Access_Type,
16167 E_General_Access_Type)
16170 (Designated_Type (Etype (Def_Id))) /= Convention
16172 Error_Msg_Name_1 := Pname;
16174 if Convention = Convention_Java then
16176 ("pragma% requires function returning a named "
16177 & "'Java access type", Arg1);
16180 ("pragma% requires function returning a named "
16181 & "'C'I'L access type", Arg1);
16186 Set_Is_Constructor (Def_Id);
16187 Set_Convention (Def_Id, Convention);
16188 Set_Is_Imported (Def_Id);
16190 exit when From_Aspect_Specification (N);
16191 Hom_Id := Homonym (Hom_Id);
16193 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
16195 end Java_Constructor;
16197 ----------------------
16198 -- Java_Interface --
16199 ----------------------
16201 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
16203 when Pragma_Java_Interface => Java_Interface : declare
16209 Check_Arg_Count (1);
16210 Check_Optional_Identifier (Arg1, Name_Entity);
16211 Check_Arg_Is_Local_Name (Arg1);
16213 Arg := Get_Pragma_Arg (Arg1);
16216 if Etype (Arg) = Any_Type then
16220 if not Is_Entity_Name (Arg)
16221 or else not Is_Type (Entity (Arg))
16223 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
16226 Typ := Underlying_Type (Entity (Arg));
16228 -- For now simply check some of the semantic constraints on the
16229 -- type. This currently leaves out some restrictions on interface
16230 -- types, namely that the parent type must be java.lang.Object.Typ
16231 -- and that all primitives of the type should be declared
16234 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
16236 ("pragma% requires an abstract tagged type", Arg1);
16238 elsif not Has_Discriminants (Typ)
16239 or else Ekind (Etype (First_Discriminant (Typ)))
16240 /= E_Anonymous_Access_Type
16242 not Is_Class_Wide_Type
16243 (Designated_Type (Etype (First_Discriminant (Typ))))
16246 ("type must have a class-wide access discriminant", Arg1);
16248 end Java_Interface;
16254 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16256 when Pragma_Keep_Names => Keep_Names : declare
16261 Check_Arg_Count (1);
16262 Check_Optional_Identifier (Arg1, Name_On);
16263 Check_Arg_Is_Local_Name (Arg1);
16265 Arg := Get_Pragma_Arg (Arg1);
16268 if Etype (Arg) = Any_Type then
16272 if not Is_Entity_Name (Arg)
16273 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16276 ("pragma% requires a local enumeration type", Arg1);
16279 Set_Discard_Names (Entity (Arg), False);
16286 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16288 when Pragma_License =>
16290 Check_Arg_Count (1);
16291 Check_No_Identifiers;
16292 Check_Valid_Configuration_Pragma;
16293 Check_Arg_Is_Identifier (Arg1);
16296 Sind : constant Source_File_Index :=
16297 Source_Index (Current_Sem_Unit);
16300 case Chars (Get_Pragma_Arg (Arg1)) is
16302 Set_License (Sind, GPL);
16304 when Name_Modified_GPL =>
16305 Set_License (Sind, Modified_GPL);
16307 when Name_Restricted =>
16308 Set_License (Sind, Restricted);
16310 when Name_Unrestricted =>
16311 Set_License (Sind, Unrestricted);
16314 Error_Pragma_Arg ("invalid license name", Arg1);
16322 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16324 when Pragma_Link_With => Link_With : declare
16330 if Operating_Mode = Generate_Code
16331 and then In_Extended_Main_Source_Unit (N)
16333 Check_At_Least_N_Arguments (1);
16334 Check_No_Identifiers;
16335 Check_Is_In_Decl_Part_Or_Package_Spec;
16336 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16340 while Present (Arg) loop
16341 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16343 -- Store argument, converting sequences of spaces to a
16344 -- single null character (this is one of the differences
16345 -- in processing between Link_With and Linker_Options).
16347 Arg_Store : declare
16348 C : constant Char_Code := Get_Char_Code (' ');
16349 S : constant String_Id :=
16350 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16351 L : constant Nat := String_Length (S);
16354 procedure Skip_Spaces;
16355 -- Advance F past any spaces
16361 procedure Skip_Spaces is
16363 while F <= L and then Get_String_Char (S, F) = C loop
16368 -- Start of processing for Arg_Store
16371 Skip_Spaces; -- skip leading spaces
16373 -- Loop through characters, changing any embedded
16374 -- sequence of spaces to a single null character (this
16375 -- is how Link_With/Linker_Options differ)
16378 if Get_String_Char (S, F) = C then
16381 Store_String_Char (ASCII.NUL);
16384 Store_String_Char (Get_String_Char (S, F));
16392 if Present (Arg) then
16393 Store_String_Char (ASCII.NUL);
16397 Store_Linker_Option_String (End_String);
16405 -- pragma Linker_Alias (
16406 -- [Entity =>] LOCAL_NAME
16407 -- [Target =>] static_string_EXPRESSION);
16409 when Pragma_Linker_Alias =>
16411 Check_Arg_Order ((Name_Entity, Name_Target));
16412 Check_Arg_Count (2);
16413 Check_Optional_Identifier (Arg1, Name_Entity);
16414 Check_Optional_Identifier (Arg2, Name_Target);
16415 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16416 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16418 -- The only processing required is to link this item on to the
16419 -- list of rep items for the given entity. This is accomplished
16420 -- by the call to Rep_Item_Too_Late (when no error is detected
16421 -- and False is returned).
16423 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16426 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16429 ------------------------
16430 -- Linker_Constructor --
16431 ------------------------
16433 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16435 -- Code is shared with Linker_Destructor
16437 -----------------------
16438 -- Linker_Destructor --
16439 -----------------------
16441 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16443 when Pragma_Linker_Constructor |
16444 Pragma_Linker_Destructor =>
16445 Linker_Constructor : declare
16451 Check_Arg_Count (1);
16452 Check_No_Identifiers;
16453 Check_Arg_Is_Local_Name (Arg1);
16454 Arg1_X := Get_Pragma_Arg (Arg1);
16456 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16458 if not Is_Library_Level_Entity (Proc) then
16460 ("argument for pragma% must be library level entity", Arg1);
16463 -- The only processing required is to link this item on to the
16464 -- list of rep items for the given entity. This is accomplished
16465 -- by the call to Rep_Item_Too_Late (when no error is detected
16466 -- and False is returned).
16468 if Rep_Item_Too_Late (Proc, N) then
16471 Set_Has_Gigi_Rep_Item (Proc);
16473 end Linker_Constructor;
16475 --------------------
16476 -- Linker_Options --
16477 --------------------
16479 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16481 when Pragma_Linker_Options => Linker_Options : declare
16485 Check_Ada_83_Warning;
16486 Check_No_Identifiers;
16487 Check_Arg_Count (1);
16488 Check_Is_In_Decl_Part_Or_Package_Spec;
16489 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16490 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16493 while Present (Arg) loop
16494 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16495 Store_String_Char (ASCII.NUL);
16497 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16501 if Operating_Mode = Generate_Code
16502 and then In_Extended_Main_Source_Unit (N)
16504 Store_Linker_Option_String (End_String);
16506 end Linker_Options;
16508 --------------------
16509 -- Linker_Section --
16510 --------------------
16512 -- pragma Linker_Section (
16513 -- [Entity =>] LOCAL_NAME
16514 -- [Section =>] static_string_EXPRESSION);
16516 when Pragma_Linker_Section => Linker_Section : declare
16522 Check_Arg_Order ((Name_Entity, Name_Section));
16523 Check_Arg_Count (2);
16524 Check_Optional_Identifier (Arg1, Name_Entity);
16525 Check_Optional_Identifier (Arg2, Name_Section);
16526 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16527 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16529 -- Check kind of entity
16531 Arg := Get_Pragma_Arg (Arg1);
16532 Ent := Entity (Arg);
16534 case Ekind (Ent) is
16536 -- Objects (constants and variables) and types. For these cases
16537 -- all we need to do is to set the Linker_Section_pragma field.
16539 when E_Constant | E_Variable | Type_Kind =>
16540 Set_Linker_Section_Pragma (Ent, N);
16544 when Subprogram_Kind =>
16546 -- Aspect case, entity already set
16548 if From_Aspect_Specification (N) then
16549 Set_Linker_Section_Pragma
16550 (Entity (Corresponding_Aspect (N)), N);
16552 -- Pragma case, we must climb the homonym chain, but skip
16553 -- any for which the linker section is already set.
16557 if No (Linker_Section_Pragma (Ent)) then
16558 Set_Linker_Section_Pragma (Ent, N);
16561 Ent := Homonym (Ent);
16563 or else Scope (Ent) /= Current_Scope;
16567 -- All other cases are illegal
16571 ("pragma% applies only to objects, subprograms, and types",
16574 end Linker_Section;
16580 -- pragma List (On | Off)
16582 -- There is nothing to do here, since we did all the processing for
16583 -- this pragma in Par.Prag (so that it works properly even in syntax
16586 when Pragma_List =>
16593 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16595 when Pragma_Lock_Free => Lock_Free : declare
16596 P : constant Node_Id := Parent (N);
16602 Check_No_Identifiers;
16603 Check_At_Most_N_Arguments (1);
16605 -- Protected definition case
16607 if Nkind (P) = N_Protected_Definition then
16608 Ent := Defining_Identifier (Parent (P));
16612 if Arg_Count = 1 then
16613 Arg := Get_Pragma_Arg (Arg1);
16614 Val := Is_True (Static_Boolean (Arg));
16616 -- No arguments (expression is considered to be True)
16622 -- Check duplicate pragma before we chain the pragma in the Rep
16623 -- Item chain of Ent.
16625 Check_Duplicate_Pragma (Ent);
16626 Record_Rep_Item (Ent, N);
16627 Set_Uses_Lock_Free (Ent, Val);
16629 -- Anything else is incorrect placement
16636 --------------------
16637 -- Locking_Policy --
16638 --------------------
16640 -- pragma Locking_Policy (policy_IDENTIFIER);
16642 when Pragma_Locking_Policy => declare
16643 subtype LP_Range is Name_Id
16644 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
16649 Check_Ada_83_Warning;
16650 Check_Arg_Count (1);
16651 Check_No_Identifiers;
16652 Check_Arg_Is_Locking_Policy (Arg1);
16653 Check_Valid_Configuration_Pragma;
16654 LP_Val := Chars (Get_Pragma_Arg (Arg1));
16657 when Name_Ceiling_Locking =>
16659 when Name_Inheritance_Locking =>
16661 when Name_Concurrent_Readers_Locking =>
16665 if Locking_Policy /= ' '
16666 and then Locking_Policy /= LP
16668 Error_Msg_Sloc := Locking_Policy_Sloc;
16669 Error_Pragma ("locking policy incompatible with policy#");
16671 -- Set new policy, but always preserve System_Location since we
16672 -- like the error message with the run time name.
16675 Locking_Policy := LP;
16677 if Locking_Policy_Sloc /= System_Location then
16678 Locking_Policy_Sloc := Loc;
16687 -- pragma Long_Float (D_Float | G_Float);
16689 when Pragma_Long_Float => Long_Float : declare
16692 Check_Valid_Configuration_Pragma;
16693 Check_Arg_Count (1);
16694 Check_No_Identifier (Arg1);
16695 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
16697 if not OpenVMS_On_Target then
16698 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
16703 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
16704 if Opt.Float_Format_Long = 'G' then
16706 ("G_Float previously specified", Arg1);
16708 elsif Current_Sem_Unit /= Main_Unit
16709 and then Opt.Float_Format_Long /= 'D'
16712 ("main unit not compiled with pragma Long_Float (D_Float)",
16713 "\pragma% must be used consistently for whole partition",
16717 Opt.Float_Format_Long := 'D';
16720 -- G_Float case (this is the default, does not need overriding)
16723 if Opt.Float_Format_Long = 'D' then
16724 Error_Pragma ("D_Float previously specified");
16726 elsif Current_Sem_Unit /= Main_Unit
16727 and then Opt.Float_Format_Long /= 'G'
16730 ("main unit not compiled with pragma Long_Float (G_Float)",
16731 "\pragma% must be used consistently for whole partition",
16735 Opt.Float_Format_Long := 'G';
16739 Set_Standard_Fpt_Formats;
16742 -------------------
16743 -- Loop_Optimize --
16744 -------------------
16746 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16748 -- OPTIMIZATION_HINT ::=
16749 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16751 when Pragma_Loop_Optimize => Loop_Optimize : declare
16756 Check_At_Least_N_Arguments (1);
16757 Check_No_Identifiers;
16759 Hint := First (Pragma_Argument_Associations (N));
16760 while Present (Hint) loop
16761 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
16769 Check_Loop_Pragma_Placement;
16776 -- pragma Loop_Variant
16777 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16779 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16781 -- CHANGE_DIRECTION ::= Increases | Decreases
16783 when Pragma_Loop_Variant => Loop_Variant : declare
16788 Check_At_Least_N_Arguments (1);
16789 Check_Loop_Pragma_Placement;
16791 -- Process all increasing / decreasing expressions
16793 Variant := First (Pragma_Argument_Associations (N));
16794 while Present (Variant) loop
16795 if not Nam_In (Chars (Variant), Name_Decreases,
16798 Error_Pragma_Arg ("wrong change modifier", Variant);
16801 Preanalyze_Assert_Expression
16802 (Expression (Variant), Any_Discrete);
16808 -----------------------
16809 -- Machine_Attribute --
16810 -----------------------
16812 -- pragma Machine_Attribute (
16813 -- [Entity =>] LOCAL_NAME,
16814 -- [Attribute_Name =>] static_string_EXPRESSION
16815 -- [, [Info =>] static_EXPRESSION] );
16817 when Pragma_Machine_Attribute => Machine_Attribute : declare
16818 Def_Id : Entity_Id;
16822 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
16824 if Arg_Count = 3 then
16825 Check_Optional_Identifier (Arg3, Name_Info);
16826 Check_Arg_Is_OK_Static_Expression (Arg3);
16828 Check_Arg_Count (2);
16831 Check_Optional_Identifier (Arg1, Name_Entity);
16832 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
16833 Check_Arg_Is_Local_Name (Arg1);
16834 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16835 Def_Id := Entity (Get_Pragma_Arg (Arg1));
16837 if Is_Access_Type (Def_Id) then
16838 Def_Id := Designated_Type (Def_Id);
16841 if Rep_Item_Too_Early (Def_Id, N) then
16845 Def_Id := Underlying_Type (Def_Id);
16847 -- The only processing required is to link this item on to the
16848 -- list of rep items for the given entity. This is accomplished
16849 -- by the call to Rep_Item_Too_Late (when no error is detected
16850 -- and False is returned).
16852 if Rep_Item_Too_Late (Def_Id, N) then
16855 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16857 end Machine_Attribute;
16864 -- (MAIN_OPTION [, MAIN_OPTION]);
16867 -- [STACK_SIZE =>] static_integer_EXPRESSION
16868 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16869 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16871 when Pragma_Main => Main : declare
16872 Args : Args_List (1 .. 3);
16873 Names : constant Name_List (1 .. 3) := (
16875 Name_Task_Stack_Size_Default,
16876 Name_Time_Slicing_Enabled);
16882 Gather_Associations (Names, Args);
16884 for J in 1 .. 2 loop
16885 if Present (Args (J)) then
16886 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16890 if Present (Args (3)) then
16891 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
16895 while Present (Nod) loop
16896 if Nkind (Nod) = N_Pragma
16897 and then Pragma_Name (Nod) = Name_Main
16899 Error_Msg_Name_1 := Pname;
16900 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16911 -- pragma Main_Storage
16912 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16914 -- MAIN_STORAGE_OPTION ::=
16915 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16916 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16918 when Pragma_Main_Storage => Main_Storage : declare
16919 Args : Args_List (1 .. 2);
16920 Names : constant Name_List (1 .. 2) := (
16921 Name_Working_Storage,
16928 Gather_Associations (Names, Args);
16930 for J in 1 .. 2 loop
16931 if Present (Args (J)) then
16932 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
16936 Check_In_Main_Program;
16939 while Present (Nod) loop
16940 if Nkind (Nod) = N_Pragma
16941 and then Pragma_Name (Nod) = Name_Main_Storage
16943 Error_Msg_Name_1 := Pname;
16944 Error_Msg_N ("duplicate pragma% not permitted", Nod);
16955 -- pragma Memory_Size (NUMERIC_LITERAL)
16957 when Pragma_Memory_Size =>
16960 -- Memory size is simply ignored
16962 Check_No_Identifiers;
16963 Check_Arg_Count (1);
16964 Check_Arg_Is_Integer_Literal (Arg1);
16972 -- The only correct use of this pragma is on its own in a file, in
16973 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16974 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16975 -- check for a file containing nothing but a No_Body pragma). If we
16976 -- attempt to process it during normal semantics processing, it means
16977 -- it was misplaced.
16979 when Pragma_No_Body =>
16987 -- pragma No_Inline ( NAME {, NAME} );
16989 when Pragma_No_Inline =>
16991 Process_Inline (Suppressed);
16997 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16999 when Pragma_No_Return => No_Return : declare
17007 Check_At_Least_N_Arguments (1);
17009 -- Loop through arguments of pragma
17012 while Present (Arg) loop
17013 Check_Arg_Is_Local_Name (Arg);
17014 Id := Get_Pragma_Arg (Arg);
17017 if not Is_Entity_Name (Id) then
17018 Error_Pragma_Arg ("entity name required", Arg);
17021 if Etype (Id) = Any_Type then
17025 -- Loop to find matching procedures
17030 and then Scope (E) = Current_Scope
17032 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17035 -- Set flag on any alias as well
17037 if Is_Overloadable (E) and then Present (Alias (E)) then
17038 Set_No_Return (Alias (E));
17044 exit when From_Aspect_Specification (N);
17048 -- If entity in not in current scope it may be the enclosing
17049 -- suprogram body to which the aspect applies.
17052 if Entity (Id) = Current_Scope
17053 and then From_Aspect_Specification (N)
17055 Set_No_Return (Entity (Id));
17057 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17069 -- pragma No_Run_Time;
17071 -- Note: this pragma is retained for backwards compatibility. See
17072 -- body of Rtsfind for full details on its handling.
17074 when Pragma_No_Run_Time =>
17076 Check_Valid_Configuration_Pragma;
17077 Check_Arg_Count (0);
17079 No_Run_Time_Mode := True;
17080 Configurable_Run_Time_Mode := True;
17082 -- Set Duration to 32 bits if word size is 32
17084 if Ttypes.System_Word_Size = 32 then
17085 Duration_32_Bits_On_Target := True;
17088 -- Set appropriate restrictions
17090 Set_Restriction (No_Finalization, N);
17091 Set_Restriction (No_Exception_Handlers, N);
17092 Set_Restriction (Max_Tasks, N, 0);
17093 Set_Restriction (No_Tasking, N);
17095 ------------------------
17096 -- No_Strict_Aliasing --
17097 ------------------------
17099 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17101 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17106 Check_At_Most_N_Arguments (1);
17108 if Arg_Count = 0 then
17109 Check_Valid_Configuration_Pragma;
17110 Opt.No_Strict_Aliasing := True;
17113 Check_Optional_Identifier (Arg2, Name_Entity);
17114 Check_Arg_Is_Local_Name (Arg1);
17115 E_Id := Entity (Get_Pragma_Arg (Arg1));
17117 if E_Id = Any_Type then
17119 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17120 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17123 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17125 end No_Strict_Aliasing;
17127 -----------------------
17128 -- Normalize_Scalars --
17129 -----------------------
17131 -- pragma Normalize_Scalars;
17133 when Pragma_Normalize_Scalars =>
17134 Check_Ada_83_Warning;
17135 Check_Arg_Count (0);
17136 Check_Valid_Configuration_Pragma;
17138 -- Normalize_Scalars creates false positives in CodePeer, and
17139 -- incorrect negative results in GNATprove mode, so ignore this
17140 -- pragma in these modes.
17142 if not (CodePeer_Mode or GNATprove_Mode) then
17143 Normalize_Scalars := True;
17144 Init_Or_Norm_Scalars := True;
17151 -- pragma Obsolescent;
17153 -- pragma Obsolescent (
17154 -- [Message =>] static_string_EXPRESSION
17155 -- [,[Version =>] Ada_05]]);
17157 -- pragma Obsolescent (
17158 -- [Entity =>] NAME
17159 -- [,[Message =>] static_string_EXPRESSION
17160 -- [,[Version =>] Ada_05]] );
17162 when Pragma_Obsolescent => Obsolescent : declare
17166 procedure Set_Obsolescent (E : Entity_Id);
17167 -- Given an entity Ent, mark it as obsolescent if appropriate
17169 ---------------------
17170 -- Set_Obsolescent --
17171 ---------------------
17173 procedure Set_Obsolescent (E : Entity_Id) is
17182 -- Entity name was given
17184 if Present (Ename) then
17186 -- If entity name matches, we are fine. Save entity in
17187 -- pragma argument, for ASIS use.
17189 if Chars (Ename) = Chars (Ent) then
17190 Set_Entity (Ename, Ent);
17191 Generate_Reference (Ent, Ename);
17193 -- If entity name does not match, only possibility is an
17194 -- enumeration literal from an enumeration type declaration.
17196 elsif Ekind (Ent) /= E_Enumeration_Type then
17198 ("pragma % entity name does not match declaration");
17201 Ent := First_Literal (E);
17205 ("pragma % entity name does not match any "
17206 & "enumeration literal");
17208 elsif Chars (Ent) = Chars (Ename) then
17209 Set_Entity (Ename, Ent);
17210 Generate_Reference (Ent, Ename);
17214 Ent := Next_Literal (Ent);
17220 -- Ent points to entity to be marked
17222 if Arg_Count >= 1 then
17224 -- Deal with static string argument
17226 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17227 S := Strval (Get_Pragma_Arg (Arg1));
17229 for J in 1 .. String_Length (S) loop
17230 if not In_Character_Range (Get_String_Char (S, J)) then
17232 ("pragma% argument does not allow wide characters",
17237 Obsolescent_Warnings.Append
17238 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17240 -- Check for Ada_05 parameter
17242 if Arg_Count /= 1 then
17243 Check_Arg_Count (2);
17246 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17249 Check_Arg_Is_Identifier (Argx);
17251 if Chars (Argx) /= Name_Ada_05 then
17252 Error_Msg_Name_2 := Name_Ada_05;
17254 ("only allowed argument for pragma% is %", Argx);
17257 if Ada_Version_Explicit < Ada_2005
17258 or else not Warn_On_Ada_2005_Compatibility
17266 -- Set flag if pragma active
17269 Set_Is_Obsolescent (Ent);
17273 end Set_Obsolescent;
17275 -- Start of processing for pragma Obsolescent
17280 Check_At_Most_N_Arguments (3);
17282 -- See if first argument specifies an entity name
17286 (Chars (Arg1) = Name_Entity
17288 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17290 N_Operator_Symbol))
17292 Ename := Get_Pragma_Arg (Arg1);
17294 -- Eliminate first argument, so we can share processing
17298 Arg_Count := Arg_Count - 1;
17300 -- No Entity name argument given
17306 if Arg_Count >= 1 then
17307 Check_Optional_Identifier (Arg1, Name_Message);
17309 if Arg_Count = 2 then
17310 Check_Optional_Identifier (Arg2, Name_Version);
17314 -- Get immediately preceding declaration
17317 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17321 -- Cases where we do not follow anything other than another pragma
17325 -- First case: library level compilation unit declaration with
17326 -- the pragma immediately following the declaration.
17328 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17330 (Defining_Entity (Unit (Parent (Parent (N)))));
17333 -- Case 2: library unit placement for package
17337 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17339 if Is_Package_Or_Generic_Package (Ent) then
17340 Set_Obsolescent (Ent);
17346 -- Cases where we must follow a declaration
17349 if Nkind (Decl) not in N_Declaration
17350 and then Nkind (Decl) not in N_Later_Decl_Item
17351 and then Nkind (Decl) not in N_Generic_Declaration
17352 and then Nkind (Decl) not in N_Renaming_Declaration
17355 ("pragma% misplaced, "
17356 & "must immediately follow a declaration");
17359 Set_Obsolescent (Defining_Entity (Decl));
17369 -- pragma Optimize (Time | Space | Off);
17371 -- The actual check for optimize is done in Gigi. Note that this
17372 -- pragma does not actually change the optimization setting, it
17373 -- simply checks that it is consistent with the pragma.
17375 when Pragma_Optimize =>
17376 Check_No_Identifiers;
17377 Check_Arg_Count (1);
17378 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17380 ------------------------
17381 -- Optimize_Alignment --
17382 ------------------------
17384 -- pragma Optimize_Alignment (Time | Space | Off);
17386 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17388 Check_No_Identifiers;
17389 Check_Arg_Count (1);
17390 Check_Valid_Configuration_Pragma;
17393 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17397 Opt.Optimize_Alignment := 'T';
17399 Opt.Optimize_Alignment := 'S';
17401 Opt.Optimize_Alignment := 'O';
17403 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17407 -- Set indication that mode is set locally. If we are in fact in a
17408 -- configuration pragma file, this setting is harmless since the
17409 -- switch will get reset anyway at the start of each unit.
17411 Optimize_Alignment_Local := True;
17412 end Optimize_Alignment;
17418 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17420 when Pragma_Ordered => Ordered : declare
17421 Assoc : constant Node_Id := Arg1;
17427 Check_No_Identifiers;
17428 Check_Arg_Count (1);
17429 Check_Arg_Is_Local_Name (Arg1);
17431 Type_Id := Get_Pragma_Arg (Assoc);
17432 Find_Type (Type_Id);
17433 Typ := Entity (Type_Id);
17435 if Typ = Any_Type then
17438 Typ := Underlying_Type (Typ);
17441 if not Is_Enumeration_Type (Typ) then
17442 Error_Pragma ("pragma% must specify enumeration type");
17445 Check_First_Subtype (Arg1);
17446 Set_Has_Pragma_Ordered (Base_Type (Typ));
17449 -------------------
17450 -- Overflow_Mode --
17451 -------------------
17453 -- pragma Overflow_Mode
17454 -- ([General => ] MODE [, [Assertions => ] MODE]);
17456 -- MODE := STRICT | MINIMIZED | ELIMINATED
17458 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17459 -- since System.Bignums makes this assumption. This is true of nearly
17460 -- all (all?) targets.
17462 when Pragma_Overflow_Mode => Overflow_Mode : declare
17463 function Get_Overflow_Mode
17465 Arg : Node_Id) return Overflow_Mode_Type;
17466 -- Function to process one pragma argument, Arg. If an identifier
17467 -- is present, it must be Name. Mode type is returned if a valid
17468 -- argument exists, otherwise an error is signalled.
17470 -----------------------
17471 -- Get_Overflow_Mode --
17472 -----------------------
17474 function Get_Overflow_Mode
17476 Arg : Node_Id) return Overflow_Mode_Type
17478 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
17481 Check_Optional_Identifier (Arg, Name);
17482 Check_Arg_Is_Identifier (Argx);
17484 if Chars (Argx) = Name_Strict then
17487 elsif Chars (Argx) = Name_Minimized then
17490 elsif Chars (Argx) = Name_Eliminated then
17491 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
17493 ("Eliminated not implemented on this target", Argx);
17499 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
17501 end Get_Overflow_Mode;
17503 -- Start of processing for Overflow_Mode
17507 Check_At_Least_N_Arguments (1);
17508 Check_At_Most_N_Arguments (2);
17510 -- Process first argument
17512 Scope_Suppress.Overflow_Mode_General :=
17513 Get_Overflow_Mode (Name_General, Arg1);
17515 -- Case of only one argument
17517 if Arg_Count = 1 then
17518 Scope_Suppress.Overflow_Mode_Assertions :=
17519 Scope_Suppress.Overflow_Mode_General;
17521 -- Case of two arguments present
17524 Scope_Suppress.Overflow_Mode_Assertions :=
17525 Get_Overflow_Mode (Name_Assertions, Arg2);
17529 --------------------------
17530 -- Overriding Renamings --
17531 --------------------------
17533 -- pragma Overriding_Renamings;
17535 when Pragma_Overriding_Renamings =>
17537 Check_Arg_Count (0);
17538 Check_Valid_Configuration_Pragma;
17539 Overriding_Renamings := True;
17545 -- pragma Pack (first_subtype_LOCAL_NAME);
17547 when Pragma_Pack => Pack : declare
17548 Assoc : constant Node_Id := Arg1;
17552 Ignore : Boolean := False;
17555 Check_No_Identifiers;
17556 Check_Arg_Count (1);
17557 Check_Arg_Is_Local_Name (Arg1);
17558 Type_Id := Get_Pragma_Arg (Assoc);
17560 if not Is_Entity_Name (Type_Id)
17561 or else not Is_Type (Entity (Type_Id))
17564 ("argument for pragma% must be type or subtype", Arg1);
17567 Find_Type (Type_Id);
17568 Typ := Entity (Type_Id);
17571 or else Rep_Item_Too_Early (Typ, N)
17575 Typ := Underlying_Type (Typ);
17578 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
17579 Error_Pragma ("pragma% must specify array or record type");
17582 Check_First_Subtype (Arg1);
17583 Check_Duplicate_Pragma (Typ);
17587 if Is_Array_Type (Typ) then
17588 Ctyp := Component_Type (Typ);
17590 -- Ignore pack that does nothing
17592 if Known_Static_Esize (Ctyp)
17593 and then Known_Static_RM_Size (Ctyp)
17594 and then Esize (Ctyp) = RM_Size (Ctyp)
17595 and then Addressable (Esize (Ctyp))
17600 -- Process OK pragma Pack. Note that if there is a separate
17601 -- component clause present, the Pack will be cancelled. This
17602 -- processing is in Freeze.
17604 if not Rep_Item_Too_Late (Typ, N) then
17606 -- In CodePeer mode, we do not need complex front-end
17607 -- expansions related to pragma Pack, so disable handling
17610 if CodePeer_Mode then
17613 -- Don't attempt any packing for VM targets. We possibly
17614 -- could deal with some cases of array bit-packing, but we
17615 -- don't bother, since this is not a typical kind of
17616 -- representation in the VM context anyway (and would not
17617 -- for example work nicely with the debugger).
17619 elsif VM_Target /= No_VM then
17620 if not GNAT_Mode then
17622 ("??pragma% ignored in this configuration");
17625 -- Normal case where we do the pack action
17629 Set_Is_Packed (Base_Type (Typ));
17630 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17633 Set_Has_Pragma_Pack (Base_Type (Typ));
17637 -- For record types, the pack is always effective
17639 else pragma Assert (Is_Record_Type (Typ));
17640 if not Rep_Item_Too_Late (Typ, N) then
17642 -- Ignore pack request with warning in VM mode (skip warning
17643 -- if we are compiling GNAT run time library).
17645 if VM_Target /= No_VM then
17646 if not GNAT_Mode then
17648 ("??pragma% ignored in this configuration");
17651 -- Normal case of pack request active
17654 Set_Is_Packed (Base_Type (Typ));
17655 Set_Has_Pragma_Pack (Base_Type (Typ));
17656 Set_Has_Non_Standard_Rep (Base_Type (Typ));
17668 -- There is nothing to do here, since we did all the processing for
17669 -- this pragma in Par.Prag (so that it works properly even in syntax
17672 when Pragma_Page =>
17679 -- pragma Part_Of (ABSTRACT_STATE);
17681 -- ABSTRACT_STATE ::= NAME
17683 when Pragma_Part_Of => Part_Of : declare
17684 procedure Propagate_Part_Of
17685 (Pack_Id : Entity_Id;
17686 State_Id : Entity_Id;
17687 Instance : Node_Id);
17688 -- Propagate the Part_Of indicator to all abstract states and
17689 -- variables declared in the visible state space of a package
17690 -- denoted by Pack_Id. State_Id is the encapsulating state.
17691 -- Instance is the package instantiation node.
17693 -----------------------
17694 -- Propagate_Part_Of --
17695 -----------------------
17697 procedure Propagate_Part_Of
17698 (Pack_Id : Entity_Id;
17699 State_Id : Entity_Id;
17700 Instance : Node_Id)
17702 Has_Item : Boolean := False;
17703 -- Flag set when the visible state space contains at least one
17704 -- abstract state or variable.
17706 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
17707 -- Propagate the Part_Of indicator to all abstract states and
17708 -- variables declared in the visible state space of a package
17709 -- denoted by Pack_Id.
17711 -----------------------
17712 -- Propagate_Part_Of --
17713 -----------------------
17715 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
17716 Item_Id : Entity_Id;
17719 -- Traverse the entity chain of the package and set relevant
17720 -- attributes of abstract states and variables declared in
17721 -- the visible state space of the package.
17723 Item_Id := First_Entity (Pack_Id);
17724 while Present (Item_Id)
17725 and then not In_Private_Part (Item_Id)
17727 -- Do not consider internally generated items
17729 if not Comes_From_Source (Item_Id) then
17732 -- The Part_Of indicator turns an abstract state or
17733 -- variable into a constituent of the encapsulating
17736 elsif Ekind_In (Item_Id, E_Abstract_State,
17741 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17742 Set_Encapsulating_State (Item_Id, State_Id);
17744 -- Recursively handle nested packages and instantiations
17746 elsif Ekind (Item_Id) = E_Package then
17747 Propagate_Part_Of (Item_Id);
17750 Next_Entity (Item_Id);
17752 end Propagate_Part_Of;
17754 -- Start of processing for Propagate_Part_Of
17757 Propagate_Part_Of (Pack_Id);
17759 -- Detect a package instantiation that is subject to a Part_Of
17760 -- indicator, but has no visible state.
17762 if not Has_Item then
17764 ("package instantiation & has Part_Of indicator but "
17765 & "lacks visible state", Instance, Pack_Id);
17767 end Propagate_Part_Of;
17771 Item_Id : Entity_Id;
17774 State_Id : Entity_Id;
17777 -- Start of processing for Part_Of
17781 Check_Arg_Count (1);
17783 -- Ensure the proper placement of the pragma. Part_Of must appear
17784 -- on a variable declaration or a package instantiation.
17787 while Present (Stmt) loop
17789 -- Skip prior pragmas, but check for duplicates
17791 if Nkind (Stmt) = N_Pragma then
17792 if Pragma_Name (Stmt) = Pname then
17793 Error_Msg_Name_1 := Pname;
17794 Error_Msg_Sloc := Sloc (Stmt);
17795 Error_Msg_N ("pragma% duplicates pragma declared#", N);
17798 -- Skip internally generated code
17800 elsif not Comes_From_Source (Stmt) then
17803 -- The pragma applies to an object declaration (possibly a
17804 -- variable) or a package instantiation. Stop the traversal
17805 -- and continue the analysis.
17807 elsif Nkind_In (Stmt, N_Object_Declaration,
17808 N_Package_Instantiation)
17812 -- The pragma does not apply to a legal construct, issue an
17813 -- error and stop the analysis.
17820 Stmt := Prev (Stmt);
17823 -- When the context is an object declaration, ensure that we are
17824 -- dealing with a variable.
17826 if Nkind (Stmt) = N_Object_Declaration
17827 and then Ekind (Defining_Entity (Stmt)) /= E_Variable
17829 SPARK_Msg_N ("indicator Part_Of must apply to a variable", N);
17833 -- Extract the entity of the related object declaration or package
17834 -- instantiation. In the case of the instantiation, use the entity
17835 -- of the instance spec.
17837 if Nkind (Stmt) = N_Package_Instantiation then
17838 Stmt := Instance_Spec (Stmt);
17841 Item_Id := Defining_Entity (Stmt);
17842 State := Get_Pragma_Arg (Arg1);
17844 -- Detect any discrepancies between the placement of the object
17845 -- or package instantiation with respect to state space and the
17846 -- encapsulating state.
17849 (Item_Id => Item_Id,
17855 State_Id := Entity (State);
17857 -- Add the pragma to the contract of the item. This aids with
17858 -- the detection of a missing but required Part_Of indicator.
17860 Add_Contract_Item (N, Item_Id);
17862 -- The Part_Of indicator turns a variable into a constituent
17863 -- of the encapsulating state.
17865 if Ekind (Item_Id) = E_Variable then
17866 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
17867 Set_Encapsulating_State (Item_Id, State_Id);
17869 -- Propagate the Part_Of indicator to the visible state space
17870 -- of the package instantiation.
17874 (Pack_Id => Item_Id,
17875 State_Id => State_Id,
17881 ----------------------------------
17882 -- Partition_Elaboration_Policy --
17883 ----------------------------------
17885 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17887 when Pragma_Partition_Elaboration_Policy => declare
17888 subtype PEP_Range is Name_Id
17889 range First_Partition_Elaboration_Policy_Name
17890 .. Last_Partition_Elaboration_Policy_Name;
17891 PEP_Val : PEP_Range;
17896 Check_Arg_Count (1);
17897 Check_No_Identifiers;
17898 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
17899 Check_Valid_Configuration_Pragma;
17900 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
17903 when Name_Concurrent =>
17905 when Name_Sequential =>
17909 if Partition_Elaboration_Policy /= ' '
17910 and then Partition_Elaboration_Policy /= PEP
17912 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
17914 ("partition elaboration policy incompatible with policy#");
17916 -- Set new policy, but always preserve System_Location since we
17917 -- like the error message with the run time name.
17920 Partition_Elaboration_Policy := PEP;
17922 if Partition_Elaboration_Policy_Sloc /= System_Location then
17923 Partition_Elaboration_Policy_Sloc := Loc;
17932 -- pragma Passive [(PASSIVE_FORM)];
17934 -- PASSIVE_FORM ::= Semaphore | No
17936 when Pragma_Passive =>
17939 if Nkind (Parent (N)) /= N_Task_Definition then
17940 Error_Pragma ("pragma% must be within task definition");
17943 if Arg_Count /= 0 then
17944 Check_Arg_Count (1);
17945 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
17948 ----------------------------------
17949 -- Preelaborable_Initialization --
17950 ----------------------------------
17952 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17954 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
17959 Check_Arg_Count (1);
17960 Check_No_Identifiers;
17961 Check_Arg_Is_Identifier (Arg1);
17962 Check_Arg_Is_Local_Name (Arg1);
17963 Check_First_Subtype (Arg1);
17964 Ent := Entity (Get_Pragma_Arg (Arg1));
17966 -- The pragma may come from an aspect on a private declaration,
17967 -- even if the freeze point at which this is analyzed in the
17968 -- private part after the full view.
17970 if Has_Private_Declaration (Ent)
17971 and then From_Aspect_Specification (N)
17975 elsif Is_Private_Type (Ent)
17976 or else Is_Protected_Type (Ent)
17977 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
17983 ("pragma % can only be applied to private, formal derived or "
17984 & "protected type",
17988 -- Give an error if the pragma is applied to a protected type that
17989 -- does not qualify (due to having entries, or due to components
17990 -- that do not qualify).
17992 if Is_Protected_Type (Ent)
17993 and then not Has_Preelaborable_Initialization (Ent)
17996 ("protected type & does not have preelaborable "
17997 & "initialization", Ent);
17999 -- Otherwise mark the type as definitely having preelaborable
18003 Set_Known_To_Have_Preelab_Init (Ent);
18006 if Has_Pragma_Preelab_Init (Ent)
18007 and then Warn_On_Redundant_Constructs
18009 Error_Pragma ("?r?duplicate pragma%!");
18011 Set_Has_Pragma_Preelab_Init (Ent);
18015 --------------------
18016 -- Persistent_BSS --
18017 --------------------
18019 -- pragma Persistent_BSS [(object_NAME)];
18021 when Pragma_Persistent_BSS => Persistent_BSS : declare
18028 Check_At_Most_N_Arguments (1);
18030 -- Case of application to specific object (one argument)
18032 if Arg_Count = 1 then
18033 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18035 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18037 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18040 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18043 Ent := Entity (Get_Pragma_Arg (Arg1));
18044 Decl := Parent (Ent);
18046 -- Check for duplication before inserting in list of
18047 -- representation items.
18049 Check_Duplicate_Pragma (Ent);
18051 if Rep_Item_Too_Late (Ent, N) then
18055 if Present (Expression (Decl)) then
18057 ("object for pragma% cannot have initialization", Arg1);
18060 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18062 ("object type for pragma% is not potentially persistent",
18067 Make_Linker_Section_Pragma
18068 (Ent, Sloc (N), ".persistent.bss");
18069 Insert_After (N, Prag);
18072 -- Case of use as configuration pragma with no arguments
18075 Check_Valid_Configuration_Pragma;
18076 Persistent_BSS_Mode := True;
18078 end Persistent_BSS;
18084 -- pragma Polling (ON | OFF);
18086 when Pragma_Polling =>
18088 Check_Arg_Count (1);
18089 Check_No_Identifiers;
18090 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18091 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18097 -- pragma Post (Boolean_EXPRESSION);
18098 -- pragma Post_Class (Boolean_EXPRESSION);
18100 when Pragma_Post | Pragma_Post_Class => Post : declare
18101 PC_Pragma : Node_Id;
18105 Check_Arg_Count (1);
18106 Check_No_Identifiers;
18109 -- Rewrite Post[_Class] pragma as Postcondition pragma setting the
18110 -- flag Class_Present to True for the Post_Class case.
18112 Set_Class_Present (N, Prag_Id = Pragma_Post_Class);
18113 PC_Pragma := New_Copy (N);
18114 Set_Pragma_Identifier
18115 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition));
18116 Rewrite (N, PC_Pragma);
18117 Set_Analyzed (N, False);
18121 -------------------
18122 -- Postcondition --
18123 -------------------
18125 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18126 -- [,[Message =>] String_EXPRESSION]);
18128 when Pragma_Postcondition => Postcondition : declare
18133 Check_At_Least_N_Arguments (1);
18134 Check_At_Most_N_Arguments (2);
18135 Check_Optional_Identifier (Arg1, Name_Check);
18137 -- Verify the proper placement of the pragma. The remainder of the
18138 -- processing is found in Sem_Ch6/Sem_Ch7.
18140 Check_Precondition_Postcondition (In_Body);
18142 -- When the pragma is a source construct appearing inside a body,
18143 -- preanalyze the boolean_expression to detect illegal forward
18147 -- pragma Postcondition (X'Old ...);
18150 if Comes_From_Source (N) and then In_Body then
18151 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean);
18159 -- pragma Pre (Boolean_EXPRESSION);
18160 -- pragma Pre_Class (Boolean_EXPRESSION);
18162 when Pragma_Pre | Pragma_Pre_Class => Pre : declare
18163 PC_Pragma : Node_Id;
18167 Check_Arg_Count (1);
18168 Check_No_Identifiers;
18171 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the
18172 -- flag Class_Present to True for the Pre_Class case.
18174 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class);
18175 PC_Pragma := New_Copy (N);
18176 Set_Pragma_Identifier
18177 (PC_Pragma, Make_Identifier (Loc, Name_Precondition));
18178 Rewrite (N, PC_Pragma);
18179 Set_Analyzed (N, False);
18187 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18188 -- [,[Message =>] String_EXPRESSION]);
18190 when Pragma_Precondition => Precondition : declare
18195 Check_At_Least_N_Arguments (1);
18196 Check_At_Most_N_Arguments (2);
18197 Check_Optional_Identifier (Arg1, Name_Check);
18198 Check_Precondition_Postcondition (In_Body);
18200 -- If in spec, nothing more to do. If in body, then we convert
18201 -- the pragma to an equivalent pragma Check. That works fine since
18202 -- pragma Check will analyze the condition in the proper context.
18204 -- The form of the pragma Check is either:
18206 -- pragma Check (Precondition, cond [, msg])
18208 -- pragma Check (Pre, cond [, msg])
18210 -- We use the Pre form if this pragma derived from a Pre aspect.
18211 -- This is needed to make sure that the right set of Policy
18212 -- pragmas are checked.
18216 -- Rewrite as Check pragma
18220 Chars => Name_Check,
18221 Pragma_Argument_Associations => New_List (
18222 Make_Pragma_Argument_Association (Loc,
18223 Expression => Make_Identifier (Loc, Pname)),
18225 Make_Pragma_Argument_Association (Sloc (Arg1),
18227 Relocate_Node (Get_Pragma_Arg (Arg1))))));
18229 if Arg_Count = 2 then
18230 Append_To (Pragma_Argument_Associations (N),
18231 Make_Pragma_Argument_Association (Sloc (Arg2),
18233 Relocate_Node (Get_Pragma_Arg (Arg2))));
18244 -- pragma Predicate
18245 -- ([Entity =>] type_LOCAL_NAME,
18246 -- [Check =>] boolean_EXPRESSION);
18248 when Pragma_Predicate => Predicate : declare
18255 Check_Arg_Count (2);
18256 Check_Optional_Identifier (Arg1, Name_Entity);
18257 Check_Optional_Identifier (Arg2, Name_Check);
18259 Check_Arg_Is_Local_Name (Arg1);
18261 Type_Id := Get_Pragma_Arg (Arg1);
18262 Find_Type (Type_Id);
18263 Typ := Entity (Type_Id);
18265 if Typ = Any_Type then
18269 -- The remaining processing is simply to link the pragma on to
18270 -- the rep item chain, for processing when the type is frozen.
18271 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18272 -- mark the type as having predicates.
18274 Set_Has_Predicates (Typ);
18275 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18282 -- pragma Preelaborate [(library_unit_NAME)];
18284 -- Set the flag Is_Preelaborated of program unit name entity
18286 when Pragma_Preelaborate => Preelaborate : declare
18287 Pa : constant Node_Id := Parent (N);
18288 Pk : constant Node_Kind := Nkind (Pa);
18292 Check_Ada_83_Warning;
18293 Check_Valid_Library_Unit_Pragma;
18295 if Nkind (N) = N_Null_Statement then
18299 Ent := Find_Lib_Unit_Name;
18300 Check_Duplicate_Pragma (Ent);
18302 -- This filters out pragmas inside generic parents that show up
18303 -- inside instantiations. Pragmas that come from aspects in the
18304 -- unit are not ignored.
18306 if Present (Ent) then
18307 if Pk = N_Package_Specification
18308 and then Present (Generic_Parent (Pa))
18309 and then not From_Aspect_Specification (N)
18314 if not Debug_Flag_U then
18315 Set_Is_Preelaborated (Ent);
18316 Set_Suppress_Elaboration_Warnings (Ent);
18326 -- pragma Priority (EXPRESSION);
18328 when Pragma_Priority => Priority : declare
18329 P : constant Node_Id := Parent (N);
18334 Check_No_Identifiers;
18335 Check_Arg_Count (1);
18339 if Nkind (P) = N_Subprogram_Body then
18340 Check_In_Main_Program;
18342 Ent := Defining_Unit_Name (Specification (P));
18344 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18345 Ent := Defining_Identifier (Ent);
18348 Arg := Get_Pragma_Arg (Arg1);
18349 Analyze_And_Resolve (Arg, Standard_Integer);
18353 if not Is_OK_Static_Expression (Arg) then
18354 Flag_Non_Static_Expr
18355 ("main subprogram priority is not static!", Arg);
18358 -- If constraint error, then we already signalled an error
18360 elsif Raises_Constraint_Error (Arg) then
18363 -- Otherwise check in range except if Relaxed_RM_Semantics
18364 -- where we ignore the value if out of range.
18368 Val : constant Uint := Expr_Value (Arg);
18370 if not Relaxed_RM_Semantics
18373 or else Val > Expr_Value (Expression
18374 (Parent (RTE (RE_Max_Priority)))))
18377 ("main subprogram priority is out of range", Arg1);
18380 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18385 -- Load an arbitrary entity from System.Tasking.Stages or
18386 -- System.Tasking.Restricted.Stages (depending on the
18387 -- supported profile) to make sure that one of these packages
18388 -- is implicitly with'ed, since we need to have the tasking
18389 -- run time active for the pragma Priority to have any effect.
18390 -- Previously we with'ed the package System.Tasking, but this
18391 -- package does not trigger the required initialization of the
18392 -- run-time library.
18395 Discard : Entity_Id;
18396 pragma Warnings (Off, Discard);
18398 if Restricted_Profile then
18399 Discard := RTE (RE_Activate_Restricted_Tasks);
18401 Discard := RTE (RE_Activate_Tasks);
18405 -- Task or Protected, must be of type Integer
18407 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18408 Arg := Get_Pragma_Arg (Arg1);
18409 Ent := Defining_Identifier (Parent (P));
18411 -- The expression must be analyzed in the special manner
18412 -- described in "Handling of Default and Per-Object
18413 -- Expressions" in sem.ads.
18415 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18417 if not Is_Static_Expression (Arg) then
18418 Check_Restriction (Static_Priorities, Arg);
18421 -- Anything else is incorrect
18427 -- Check duplicate pragma before we chain the pragma in the Rep
18428 -- Item chain of Ent.
18430 Check_Duplicate_Pragma (Ent);
18431 Record_Rep_Item (Ent, N);
18434 -----------------------------------
18435 -- Priority_Specific_Dispatching --
18436 -----------------------------------
18438 -- pragma Priority_Specific_Dispatching (
18439 -- policy_IDENTIFIER,
18440 -- first_priority_EXPRESSION,
18441 -- last_priority_EXPRESSION);
18443 when Pragma_Priority_Specific_Dispatching =>
18444 Priority_Specific_Dispatching : declare
18445 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
18446 -- This is the entity System.Any_Priority;
18449 Lower_Bound : Node_Id;
18450 Upper_Bound : Node_Id;
18456 Check_Arg_Count (3);
18457 Check_No_Identifiers;
18458 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
18459 Check_Valid_Configuration_Pragma;
18460 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
18461 DP := Fold_Upper (Name_Buffer (1));
18463 Lower_Bound := Get_Pragma_Arg (Arg2);
18464 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
18465 Lower_Val := Expr_Value (Lower_Bound);
18467 Upper_Bound := Get_Pragma_Arg (Arg3);
18468 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
18469 Upper_Val := Expr_Value (Upper_Bound);
18471 -- It is not allowed to use Task_Dispatching_Policy and
18472 -- Priority_Specific_Dispatching in the same partition.
18474 if Task_Dispatching_Policy /= ' ' then
18475 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18477 ("pragma% incompatible with Task_Dispatching_Policy#");
18479 -- Check lower bound in range
18481 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18483 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
18486 ("first_priority is out of range", Arg2);
18488 -- Check upper bound in range
18490 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
18492 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
18495 ("last_priority is out of range", Arg3);
18497 -- Check that the priority range is valid
18499 elsif Lower_Val > Upper_Val then
18501 ("last_priority_expression must be greater than or equal to "
18502 & "first_priority_expression");
18504 -- Store the new policy, but always preserve System_Location since
18505 -- we like the error message with the run-time name.
18508 -- Check overlapping in the priority ranges specified in other
18509 -- Priority_Specific_Dispatching pragmas within the same
18510 -- partition. We can only check those we know about.
18513 Specific_Dispatching.First .. Specific_Dispatching.Last
18515 if Specific_Dispatching.Table (J).First_Priority in
18516 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18517 or else Specific_Dispatching.Table (J).Last_Priority in
18518 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
18521 Specific_Dispatching.Table (J).Pragma_Loc;
18523 ("priority range overlaps with "
18524 & "Priority_Specific_Dispatching#");
18528 -- The use of Priority_Specific_Dispatching is incompatible
18529 -- with Task_Dispatching_Policy.
18531 if Task_Dispatching_Policy /= ' ' then
18532 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
18534 ("Priority_Specific_Dispatching incompatible "
18535 & "with Task_Dispatching_Policy#");
18538 -- The use of Priority_Specific_Dispatching forces ceiling
18541 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
18542 Error_Msg_Sloc := Locking_Policy_Sloc;
18544 ("Priority_Specific_Dispatching incompatible "
18545 & "with Locking_Policy#");
18547 -- Set the Ceiling_Locking policy, but preserve System_Location
18548 -- since we like the error message with the run time name.
18551 Locking_Policy := 'C';
18553 if Locking_Policy_Sloc /= System_Location then
18554 Locking_Policy_Sloc := Loc;
18558 -- Add entry in the table
18560 Specific_Dispatching.Append
18561 ((Dispatching_Policy => DP,
18562 First_Priority => UI_To_Int (Lower_Val),
18563 Last_Priority => UI_To_Int (Upper_Val),
18564 Pragma_Loc => Loc));
18566 end Priority_Specific_Dispatching;
18572 -- pragma Profile (profile_IDENTIFIER);
18574 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18576 when Pragma_Profile =>
18578 Check_Arg_Count (1);
18579 Check_Valid_Configuration_Pragma;
18580 Check_No_Identifiers;
18583 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18586 if Chars (Argx) = Name_Ravenscar then
18587 Set_Ravenscar_Profile (N);
18589 elsif Chars (Argx) = Name_Restricted then
18590 Set_Profile_Restrictions
18592 N, Warn => Treat_Restrictions_As_Warnings);
18594 elsif Chars (Argx) = Name_Rational then
18595 Set_Rational_Profile;
18597 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18598 Set_Profile_Restrictions
18599 (No_Implementation_Extensions,
18600 N, Warn => Treat_Restrictions_As_Warnings);
18603 Error_Pragma_Arg ("& is not a valid profile", Argx);
18607 ----------------------
18608 -- Profile_Warnings --
18609 ----------------------
18611 -- pragma Profile_Warnings (profile_IDENTIFIER);
18613 -- profile_IDENTIFIER => Restricted | Ravenscar
18615 when Pragma_Profile_Warnings =>
18617 Check_Arg_Count (1);
18618 Check_Valid_Configuration_Pragma;
18619 Check_No_Identifiers;
18622 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
18625 if Chars (Argx) = Name_Ravenscar then
18626 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
18628 elsif Chars (Argx) = Name_Restricted then
18629 Set_Profile_Restrictions (Restricted, N, Warn => True);
18631 elsif Chars (Argx) = Name_No_Implementation_Extensions then
18632 Set_Profile_Restrictions
18633 (No_Implementation_Extensions, N, Warn => True);
18636 Error_Pragma_Arg ("& is not a valid profile", Argx);
18640 --------------------------
18641 -- Propagate_Exceptions --
18642 --------------------------
18644 -- pragma Propagate_Exceptions;
18646 -- Note: this pragma is obsolete and has no effect
18648 when Pragma_Propagate_Exceptions =>
18650 Check_Arg_Count (0);
18652 if Warn_On_Obsolescent_Feature then
18654 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18655 "and has no effect?j?", N);
18658 -----------------------------
18659 -- Provide_Shift_Operators --
18660 -----------------------------
18662 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18664 when Pragma_Provide_Shift_Operators =>
18665 Provide_Shift_Operators : declare
18668 procedure Declare_Shift_Operator (Nam : Name_Id);
18669 -- Insert declaration and pragma Instrinsic for named shift op
18671 ----------------------------
18672 -- Declare_Shift_Operator --
18673 ----------------------------
18675 procedure Declare_Shift_Operator (Nam : Name_Id) is
18681 Make_Subprogram_Declaration (Loc,
18682 Make_Function_Specification (Loc,
18683 Defining_Unit_Name =>
18684 Make_Defining_Identifier (Loc, Chars => Nam),
18686 Result_Definition =>
18687 Make_Identifier (Loc, Chars => Chars (Ent)),
18689 Parameter_Specifications => New_List (
18690 Make_Parameter_Specification (Loc,
18691 Defining_Identifier =>
18692 Make_Defining_Identifier (Loc, Name_Value),
18694 Make_Identifier (Loc, Chars => Chars (Ent))),
18696 Make_Parameter_Specification (Loc,
18697 Defining_Identifier =>
18698 Make_Defining_Identifier (Loc, Name_Amount),
18700 New_Occurrence_Of (Standard_Natural, Loc)))));
18704 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
18705 Pragma_Argument_Associations => New_List (
18706 Make_Pragma_Argument_Association (Loc,
18707 Expression => Make_Identifier (Loc, Name_Intrinsic)),
18708 Make_Pragma_Argument_Association (Loc,
18709 Expression => Make_Identifier (Loc, Nam))));
18711 Insert_After (N, Import);
18712 Insert_After (N, Func);
18713 end Declare_Shift_Operator;
18715 -- Start of processing for Provide_Shift_Operators
18719 Check_Arg_Count (1);
18720 Check_Arg_Is_Local_Name (Arg1);
18722 Arg1 := Get_Pragma_Arg (Arg1);
18724 -- We must have an entity name
18726 if not Is_Entity_Name (Arg1) then
18728 ("pragma % must apply to integer first subtype", Arg1);
18731 -- If no Entity, means there was a prior error so ignore
18733 if Present (Entity (Arg1)) then
18734 Ent := Entity (Arg1);
18736 -- Apply error checks
18738 if not Is_First_Subtype (Ent) then
18740 ("cannot apply pragma %",
18741 "\& is not a first subtype",
18744 elsif not Is_Integer_Type (Ent) then
18746 ("cannot apply pragma %",
18747 "\& is not an integer type",
18750 elsif Has_Shift_Operator (Ent) then
18752 ("cannot apply pragma %",
18753 "\& already has declared shift operators",
18756 elsif Is_Frozen (Ent) then
18758 ("pragma % appears too late",
18759 "\& is already frozen",
18763 -- Now declare the operators. We do this during analysis rather
18764 -- than expansion, since we want the operators available if we
18765 -- are operating in -gnatc or ASIS mode.
18767 Declare_Shift_Operator (Name_Rotate_Left);
18768 Declare_Shift_Operator (Name_Rotate_Right);
18769 Declare_Shift_Operator (Name_Shift_Left);
18770 Declare_Shift_Operator (Name_Shift_Right);
18771 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
18773 end Provide_Shift_Operators;
18779 -- pragma Psect_Object (
18780 -- [Internal =>] LOCAL_NAME,
18781 -- [, [External =>] EXTERNAL_SYMBOL]
18782 -- [, [Size =>] EXTERNAL_SYMBOL]);
18784 when Pragma_Psect_Object | Pragma_Common_Object =>
18785 Psect_Object : declare
18786 Args : Args_List (1 .. 3);
18787 Names : constant Name_List (1 .. 3) := (
18792 Internal : Node_Id renames Args (1);
18793 External : Node_Id renames Args (2);
18794 Size : Node_Id renames Args (3);
18796 Def_Id : Entity_Id;
18798 procedure Check_Too_Long (Arg : Node_Id);
18799 -- Posts message if the argument is an identifier with more
18800 -- than 31 characters, or a string literal with more than
18801 -- 31 characters, and we are operating under VMS
18803 --------------------
18804 -- Check_Too_Long --
18805 --------------------
18807 procedure Check_Too_Long (Arg : Node_Id) is
18808 X : constant Node_Id := Original_Node (Arg);
18811 if not Nkind_In (X, N_String_Literal, N_Identifier) then
18813 ("inappropriate argument for pragma %", Arg);
18816 if OpenVMS_On_Target then
18817 if (Nkind (X) = N_String_Literal
18818 and then String_Length (Strval (X)) > 31)
18820 (Nkind (X) = N_Identifier
18821 and then Length_Of_Name (Chars (X)) > 31)
18824 ("argument for pragma % is longer than 31 characters",
18828 end Check_Too_Long;
18830 -- Start of processing for Common_Object/Psect_Object
18834 Gather_Associations (Names, Args);
18835 Process_Extended_Import_Export_Internal_Arg (Internal);
18837 Def_Id := Entity (Internal);
18839 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
18841 ("pragma% must designate an object", Internal);
18844 Check_Too_Long (Internal);
18846 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
18848 ("cannot use pragma% for imported/exported object",
18852 if Is_Concurrent_Type (Etype (Internal)) then
18854 ("cannot specify pragma % for task/protected object",
18858 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
18860 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
18862 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
18865 if Ekind (Def_Id) = E_Constant then
18867 ("cannot specify pragma % for a constant", Internal);
18870 if Is_Record_Type (Etype (Internal)) then
18876 Ent := First_Entity (Etype (Internal));
18877 while Present (Ent) loop
18878 Decl := Declaration_Node (Ent);
18880 if Ekind (Ent) = E_Component
18881 and then Nkind (Decl) = N_Component_Declaration
18882 and then Present (Expression (Decl))
18883 and then Warn_On_Export_Import
18886 ("?x?object for pragma % has defaults", Internal);
18896 if Present (Size) then
18897 Check_Too_Long (Size);
18900 if Present (External) then
18901 Check_Arg_Is_External_Name (External);
18902 Check_Too_Long (External);
18905 -- If all error tests pass, link pragma on to the rep item chain
18907 Record_Rep_Item (Def_Id, N);
18914 -- pragma Pure [(library_unit_NAME)];
18916 when Pragma_Pure => Pure : declare
18920 Check_Ada_83_Warning;
18921 Check_Valid_Library_Unit_Pragma;
18923 if Nkind (N) = N_Null_Statement then
18927 Ent := Find_Lib_Unit_Name;
18929 Set_Has_Pragma_Pure (Ent);
18930 Set_Suppress_Elaboration_Warnings (Ent);
18933 -------------------
18934 -- Pure_Function --
18935 -------------------
18937 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18939 when Pragma_Pure_Function => Pure_Function : declare
18942 Def_Id : Entity_Id;
18943 Effective : Boolean := False;
18947 Check_Arg_Count (1);
18948 Check_Optional_Identifier (Arg1, Name_Entity);
18949 Check_Arg_Is_Local_Name (Arg1);
18950 E_Id := Get_Pragma_Arg (Arg1);
18952 if Error_Posted (E_Id) then
18956 -- Loop through homonyms (overloadings) of referenced entity
18958 E := Entity (E_Id);
18960 if Present (E) then
18962 Def_Id := Get_Base_Subprogram (E);
18964 if not Ekind_In (Def_Id, E_Function,
18965 E_Generic_Function,
18969 ("pragma% requires a function name", Arg1);
18972 Set_Is_Pure (Def_Id);
18974 if not Has_Pragma_Pure_Function (Def_Id) then
18975 Set_Has_Pragma_Pure_Function (Def_Id);
18979 exit when From_Aspect_Specification (N);
18981 exit when No (E) or else Scope (E) /= Current_Scope;
18985 and then Warn_On_Redundant_Constructs
18988 ("pragma Pure_Function on& is redundant?r?",
18994 --------------------
18995 -- Queuing_Policy --
18996 --------------------
18998 -- pragma Queuing_Policy (policy_IDENTIFIER);
19000 when Pragma_Queuing_Policy => declare
19004 Check_Ada_83_Warning;
19005 Check_Arg_Count (1);
19006 Check_No_Identifiers;
19007 Check_Arg_Is_Queuing_Policy (Arg1);
19008 Check_Valid_Configuration_Pragma;
19009 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19010 QP := Fold_Upper (Name_Buffer (1));
19012 if Queuing_Policy /= ' '
19013 and then Queuing_Policy /= QP
19015 Error_Msg_Sloc := Queuing_Policy_Sloc;
19016 Error_Pragma ("queuing policy incompatible with policy#");
19018 -- Set new policy, but always preserve System_Location since we
19019 -- like the error message with the run time name.
19022 Queuing_Policy := QP;
19024 if Queuing_Policy_Sloc /= System_Location then
19025 Queuing_Policy_Sloc := Loc;
19034 -- pragma Rational, for compatibility with foreign compiler
19036 when Pragma_Rational =>
19037 Set_Rational_Profile;
19039 ------------------------------------
19040 -- Refined_Depends/Refined_Global --
19041 ------------------------------------
19043 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19045 -- DEPENDENCY_RELATION ::=
19047 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
19049 -- DEPENDENCY_CLAUSE ::=
19050 -- OUTPUT_LIST =>[+] INPUT_LIST
19051 -- | NULL_DEPENDENCY_CLAUSE
19053 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19055 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19057 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19059 -- OUTPUT ::= NAME | FUNCTION_RESULT
19062 -- where FUNCTION_RESULT is a function Result attribute_reference
19064 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19066 -- GLOBAL_SPECIFICATION ::=
19069 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
19071 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19073 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19074 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19075 -- GLOBAL_ITEM ::= NAME
19077 when Pragma_Refined_Depends |
19078 Pragma_Refined_Global => Refined_Depends_Global :
19080 Body_Id : Entity_Id;
19082 Spec_Id : Entity_Id;
19085 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
19087 -- Save the pragma in the contract of the subprogram body. The
19088 -- remaining analysis is performed at the end of the enclosing
19092 Add_Contract_Item (N, Body_Id);
19094 end Refined_Depends_Global;
19100 -- pragma Refined_Post (boolean_EXPRESSION);
19102 when Pragma_Refined_Post => Refined_Post : declare
19103 Body_Id : Entity_Id;
19105 Result_Seen : Boolean := False;
19106 Spec_Id : Entity_Id;
19109 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal);
19111 -- Analyze the boolean expression as a "spec expression"
19114 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
19116 -- Verify that the refined postcondition mentions attribute
19117 -- 'Result and its expression introduces a post-state.
19119 if Warn_On_Suspicious_Contract
19120 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
19122 Check_Result_And_Post_State (N, Result_Seen);
19124 if not Result_Seen then
19126 ("pragma % does not mention function result?T?");
19130 -- Chain the pragma on the contract for easy retrieval
19132 Add_Contract_Item (N, Body_Id);
19136 -------------------
19137 -- Refined_State --
19138 -------------------
19140 -- pragma Refined_State (REFINEMENT_LIST);
19142 -- REFINEMENT_LIST ::=
19143 -- REFINEMENT_CLAUSE
19144 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19146 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19148 -- CONSTITUENT_LIST ::=
19151 -- | (CONSTITUENT {, CONSTITUENT})
19153 -- CONSTITUENT ::= object_NAME | state_NAME
19155 when Pragma_Refined_State => Refined_State : declare
19156 Context : constant Node_Id := Parent (N);
19157 Spec_Id : Entity_Id;
19162 Check_Arg_Count (1);
19164 -- Ensure the proper placement of the pragma. Refined states must
19165 -- be associated with a package body.
19167 if Nkind (Context) /= N_Package_Body then
19173 while Present (Stmt) loop
19175 -- Skip prior pragmas, but check for duplicates
19177 if Nkind (Stmt) = N_Pragma then
19178 if Pragma_Name (Stmt) = Pname then
19179 Error_Msg_Name_1 := Pname;
19180 Error_Msg_Sloc := Sloc (Stmt);
19181 Error_Msg_N ("pragma % duplicates pragma declared #", N);
19184 -- Skip internally generated code
19186 elsif not Comes_From_Source (Stmt) then
19189 -- The pragma does not apply to a legal construct, issue an
19190 -- error and stop the analysis.
19197 Stmt := Prev (Stmt);
19200 Spec_Id := Corresponding_Spec (Context);
19202 -- State refinement is allowed only when the corresponding package
19203 -- declaration has non-null pragma Abstract_State. Refinement not
19204 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19206 if SPARK_Mode /= Off
19208 (No (Abstract_States (Spec_Id))
19209 or else Has_Null_Abstract_State (Spec_Id))
19212 ("useless refinement, package & does not define abstract "
19213 & "states", N, Spec_Id);
19217 -- The pragma must be analyzed at the end of the declarations as
19218 -- it has visibility over the whole declarative region. Save the
19219 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by
19220 -- adding it to the contract of the package body.
19222 Add_Contract_Item (N, Defining_Entity (Context));
19225 -----------------------
19226 -- Relative_Deadline --
19227 -----------------------
19229 -- pragma Relative_Deadline (time_span_EXPRESSION);
19231 when Pragma_Relative_Deadline => Relative_Deadline : declare
19232 P : constant Node_Id := Parent (N);
19237 Check_No_Identifiers;
19238 Check_Arg_Count (1);
19240 Arg := Get_Pragma_Arg (Arg1);
19242 -- The expression must be analyzed in the special manner described
19243 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19245 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19249 if Nkind (P) = N_Subprogram_Body then
19250 Check_In_Main_Program;
19252 -- Only Task and subprogram cases allowed
19254 elsif Nkind (P) /= N_Task_Definition then
19258 -- Check duplicate pragma before we set the corresponding flag
19260 if Has_Relative_Deadline_Pragma (P) then
19261 Error_Pragma ("duplicate pragma% not allowed");
19264 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19265 -- Relative_Deadline pragma node cannot be inserted in the Rep
19266 -- Item chain of Ent since it is rewritten by the expander as a
19267 -- procedure call statement that will break the chain.
19269 Set_Has_Relative_Deadline_Pragma (P, True);
19270 end Relative_Deadline;
19272 ------------------------
19273 -- Remote_Access_Type --
19274 ------------------------
19276 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19278 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19283 Check_Arg_Count (1);
19284 Check_Optional_Identifier (Arg1, Name_Entity);
19285 Check_Arg_Is_Local_Name (Arg1);
19287 E := Entity (Get_Pragma_Arg (Arg1));
19289 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19290 and then Ekind (E) = E_General_Access_Type
19291 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19292 and then Scope (Root_Type (Directly_Designated_Type (E)))
19294 and then Is_Valid_Remote_Object_Type
19295 (Root_Type (Directly_Designated_Type (E)))
19297 Set_Is_Remote_Types (E);
19301 ("pragma% applies only to formal access to classwide types",
19304 end Remote_Access_Type;
19306 ---------------------------
19307 -- Remote_Call_Interface --
19308 ---------------------------
19310 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19312 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
19313 Cunit_Node : Node_Id;
19314 Cunit_Ent : Entity_Id;
19318 Check_Ada_83_Warning;
19319 Check_Valid_Library_Unit_Pragma;
19321 if Nkind (N) = N_Null_Statement then
19325 Cunit_Node := Cunit (Current_Sem_Unit);
19326 K := Nkind (Unit (Cunit_Node));
19327 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19329 if K = N_Package_Declaration
19330 or else K = N_Generic_Package_Declaration
19331 or else K = N_Subprogram_Declaration
19332 or else K = N_Generic_Subprogram_Declaration
19333 or else (K = N_Subprogram_Body
19334 and then Acts_As_Spec (Unit (Cunit_Node)))
19339 "pragma% must apply to package or subprogram declaration");
19342 Set_Is_Remote_Call_Interface (Cunit_Ent);
19343 end Remote_Call_Interface;
19349 -- pragma Remote_Types [(library_unit_NAME)];
19351 when Pragma_Remote_Types => Remote_Types : declare
19352 Cunit_Node : Node_Id;
19353 Cunit_Ent : Entity_Id;
19356 Check_Ada_83_Warning;
19357 Check_Valid_Library_Unit_Pragma;
19359 if Nkind (N) = N_Null_Statement then
19363 Cunit_Node := Cunit (Current_Sem_Unit);
19364 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19366 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19367 N_Generic_Package_Declaration)
19370 ("pragma% can only apply to a package declaration");
19373 Set_Is_Remote_Types (Cunit_Ent);
19380 -- pragma Ravenscar;
19382 when Pragma_Ravenscar =>
19384 Check_Arg_Count (0);
19385 Check_Valid_Configuration_Pragma;
19386 Set_Ravenscar_Profile (N);
19388 if Warn_On_Obsolescent_Feature then
19390 ("pragma Ravenscar is an obsolescent feature?j?", N);
19392 ("|use pragma Profile (Ravenscar) instead?j?", N);
19395 -------------------------
19396 -- Restricted_Run_Time --
19397 -------------------------
19399 -- pragma Restricted_Run_Time;
19401 when Pragma_Restricted_Run_Time =>
19403 Check_Arg_Count (0);
19404 Check_Valid_Configuration_Pragma;
19405 Set_Profile_Restrictions
19406 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
19408 if Warn_On_Obsolescent_Feature then
19410 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19413 ("|use pragma Profile (Restricted) instead?j?", N);
19420 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19423 -- restriction_IDENTIFIER
19424 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19426 when Pragma_Restrictions =>
19427 Process_Restrictions_Or_Restriction_Warnings
19428 (Warn => Treat_Restrictions_As_Warnings);
19430 --------------------------
19431 -- Restriction_Warnings --
19432 --------------------------
19434 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19437 -- restriction_IDENTIFIER
19438 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19440 when Pragma_Restriction_Warnings =>
19442 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
19448 -- pragma Reviewable;
19450 when Pragma_Reviewable =>
19451 Check_Ada_83_Warning;
19452 Check_Arg_Count (0);
19454 -- Call dummy debugging function rv. This is done to assist front
19455 -- end debugging. By placing a Reviewable pragma in the source
19456 -- program, a breakpoint on rv catches this place in the source,
19457 -- allowing convenient stepping to the point of interest.
19461 --------------------------
19462 -- Short_Circuit_And_Or --
19463 --------------------------
19465 -- pragma Short_Circuit_And_Or;
19467 when Pragma_Short_Circuit_And_Or =>
19469 Check_Arg_Count (0);
19470 Check_Valid_Configuration_Pragma;
19471 Short_Circuit_And_Or := True;
19473 -------------------
19474 -- Share_Generic --
19475 -------------------
19477 -- pragma Share_Generic (GNAME {, GNAME});
19479 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19481 when Pragma_Share_Generic =>
19483 Process_Generic_List;
19489 -- pragma Shared (LOCAL_NAME);
19491 when Pragma_Shared =>
19493 Process_Atomic_Shared_Volatile;
19495 --------------------
19496 -- Shared_Passive --
19497 --------------------
19499 -- pragma Shared_Passive [(library_unit_NAME)];
19501 -- Set the flag Is_Shared_Passive of program unit name entity
19503 when Pragma_Shared_Passive => Shared_Passive : declare
19504 Cunit_Node : Node_Id;
19505 Cunit_Ent : Entity_Id;
19508 Check_Ada_83_Warning;
19509 Check_Valid_Library_Unit_Pragma;
19511 if Nkind (N) = N_Null_Statement then
19515 Cunit_Node := Cunit (Current_Sem_Unit);
19516 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
19518 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
19519 N_Generic_Package_Declaration)
19522 ("pragma% can only apply to a package declaration");
19525 Set_Is_Shared_Passive (Cunit_Ent);
19526 end Shared_Passive;
19528 -----------------------
19529 -- Short_Descriptors --
19530 -----------------------
19532 -- pragma Short_Descriptors;
19534 when Pragma_Short_Descriptors =>
19536 Check_Arg_Count (0);
19537 Check_Valid_Configuration_Pragma;
19538 Short_Descriptors := True;
19540 ------------------------------
19541 -- Simple_Storage_Pool_Type --
19542 ------------------------------
19544 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19546 when Pragma_Simple_Storage_Pool_Type =>
19547 Simple_Storage_Pool_Type : declare
19553 Check_Arg_Count (1);
19554 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19556 Type_Id := Get_Pragma_Arg (Arg1);
19557 Find_Type (Type_Id);
19558 Typ := Entity (Type_Id);
19560 if Typ = Any_Type then
19564 -- We require the pragma to apply to a type declared in a package
19565 -- declaration, but not (immediately) within a package body.
19567 if Ekind (Current_Scope) /= E_Package
19568 or else In_Package_Body (Current_Scope)
19571 ("pragma% can only apply to type declared immediately "
19572 & "within a package declaration");
19575 -- A simple storage pool type must be an immutably limited record
19576 -- or private type. If the pragma is given for a private type,
19577 -- the full type is similarly restricted (which is checked later
19578 -- in Freeze_Entity).
19580 if Is_Record_Type (Typ)
19581 and then not Is_Limited_View (Typ)
19584 ("pragma% can only apply to explicitly limited record type");
19586 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
19588 ("pragma% can only apply to a private type that is limited");
19590 elsif not Is_Record_Type (Typ)
19591 and then not Is_Private_Type (Typ)
19594 ("pragma% can only apply to limited record or private type");
19597 Record_Rep_Item (Typ, N);
19598 end Simple_Storage_Pool_Type;
19600 ----------------------
19601 -- Source_File_Name --
19602 ----------------------
19604 -- There are five forms for this pragma:
19606 -- pragma Source_File_Name (
19607 -- [UNIT_NAME =>] unit_NAME,
19608 -- BODY_FILE_NAME => STRING_LITERAL
19609 -- [, [INDEX =>] INTEGER_LITERAL]);
19611 -- pragma Source_File_Name (
19612 -- [UNIT_NAME =>] unit_NAME,
19613 -- SPEC_FILE_NAME => STRING_LITERAL
19614 -- [, [INDEX =>] INTEGER_LITERAL]);
19616 -- pragma Source_File_Name (
19617 -- BODY_FILE_NAME => STRING_LITERAL
19618 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19619 -- [, CASING => CASING_SPEC]);
19621 -- pragma Source_File_Name (
19622 -- SPEC_FILE_NAME => STRING_LITERAL
19623 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19624 -- [, CASING => CASING_SPEC]);
19626 -- pragma Source_File_Name (
19627 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19628 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19629 -- [, CASING => CASING_SPEC]);
19631 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19633 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19634 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19635 -- only be used when no project file is used, while SFNP can only be
19636 -- used when a project file is used.
19638 -- No processing here. Processing was completed during parsing, since
19639 -- we need to have file names set as early as possible. Units are
19640 -- loaded well before semantic processing starts.
19642 -- The only processing we defer to this point is the check for
19643 -- correct placement.
19645 when Pragma_Source_File_Name =>
19647 Check_Valid_Configuration_Pragma;
19649 ------------------------------
19650 -- Source_File_Name_Project --
19651 ------------------------------
19653 -- See Source_File_Name for syntax
19655 -- No processing here. Processing was completed during parsing, since
19656 -- we need to have file names set as early as possible. Units are
19657 -- loaded well before semantic processing starts.
19659 -- The only processing we defer to this point is the check for
19660 -- correct placement.
19662 when Pragma_Source_File_Name_Project =>
19664 Check_Valid_Configuration_Pragma;
19666 -- Check that a pragma Source_File_Name_Project is used only in a
19667 -- configuration pragmas file.
19669 -- Pragmas Source_File_Name_Project should only be generated by
19670 -- the Project Manager in configuration pragmas files.
19672 -- This is really an ugly test. It seems to depend on some
19673 -- accidental and undocumented property. At the very least it
19674 -- needs to be documented, but it would be better to have a
19675 -- clean way of testing if we are in a configuration file???
19677 if Present (Parent (N)) then
19679 ("pragma% can only appear in a configuration pragmas file");
19682 ----------------------
19683 -- Source_Reference --
19684 ----------------------
19686 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19688 -- Nothing to do, all processing completed in Par.Prag, since we need
19689 -- the information for possible parser messages that are output.
19691 when Pragma_Source_Reference =>
19698 -- pragma SPARK_Mode [(On | Off)];
19700 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
19701 Body_Id : Entity_Id;
19704 Mode_Id : SPARK_Mode_Type;
19705 Spec_Id : Entity_Id;
19708 procedure Check_Pragma_Conformance
19709 (Context_Pragma : Node_Id;
19710 Entity_Pragma : Node_Id;
19711 Entity : Entity_Id);
19712 -- If Context_Pragma is not Empty, verify that the new pragma N
19713 -- is compatible with the pragma Context_Pragma that was inherited
19714 -- from the context:
19715 -- . if Context_Pragma is ON, then the new mode can be anything
19716 -- . if Context_Pragma is OFF, then the only allowed new mode is
19719 -- If Entity is not Empty, verify that the new pragma N is
19720 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19721 -- for Entity (which may be Empty):
19722 -- . if Entity_Pragma is ON, then the new mode can be anything
19723 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19725 -- . if Entity_Pragma is Empty, we always issue an error, as this
19726 -- corresponds to a case where a previous section of Entity
19727 -- had no SPARK_Mode set.
19729 procedure Check_Library_Level_Entity (E : Entity_Id);
19730 -- Verify that pragma is applied to library-level entity E
19732 ------------------------------
19733 -- Check_Pragma_Conformance --
19734 ------------------------------
19736 procedure Check_Pragma_Conformance
19737 (Context_Pragma : Node_Id;
19738 Entity_Pragma : Node_Id;
19739 Entity : Entity_Id)
19742 if Present (Context_Pragma) then
19743 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
19745 -- New mode less restrictive than the established mode
19747 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off
19748 and then Mode_Id = On
19751 ("cannot change SPARK_Mode from Off to On", Arg1);
19752 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19753 Error_Msg_N ("\SPARK_Mode was set to Off#", Arg1);
19758 if Present (Entity) then
19759 if Present (Entity_Pragma) then
19760 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off
19761 and then Mode_Id = On
19763 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1);
19764 Error_Msg_Sloc := Sloc (Entity_Pragma);
19766 ("\value Off was set for SPARK_Mode on&#",
19772 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1);
19773 Error_Msg_Sloc := Sloc (Entity);
19775 ("\no value was set for SPARK_Mode on&#",
19780 end Check_Pragma_Conformance;
19782 --------------------------------
19783 -- Check_Library_Level_Entity --
19784 --------------------------------
19786 procedure Check_Library_Level_Entity (E : Entity_Id) is
19787 MsgF : constant String := "incorrect placement of pragma%";
19790 if not Is_Library_Level_Entity (E) then
19791 Error_Msg_Name_1 := Pname;
19792 Error_Msg_N (Fix_Error (MsgF), N);
19794 if Ekind_In (E, E_Generic_Package,
19799 ("\& is not a library-level package", N, E);
19802 ("\& is not a library-level subprogram", N, E);
19807 end Check_Library_Level_Entity;
19809 -- Start of processing for Do_SPARK_Mode
19813 Check_No_Identifiers;
19814 Check_At_Most_N_Arguments (1);
19816 -- Check the legality of the mode (no argument = ON)
19818 if Arg_Count = 1 then
19819 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19820 Mode := Chars (Get_Pragma_Arg (Arg1));
19825 Mode_Id := Get_SPARK_Mode_Type (Mode);
19826 Context := Parent (N);
19828 -- Packages and subprograms declared in a generic unit cannot be
19829 -- subject to the pragma.
19831 if Inside_A_Generic then
19832 Error_Pragma ("incorrect placement of pragma% in a generic");
19834 -- The pragma appears in a configuration pragmas file
19836 elsif No (Context) then
19837 Check_Valid_Configuration_Pragma;
19839 if Present (SPARK_Mode_Pragma) then
19840 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
19841 Error_Msg_N ("pragma% duplicates pragma declared#", N);
19845 SPARK_Mode_Pragma := N;
19846 SPARK_Mode := Mode_Id;
19848 -- When the pragma is placed before the declaration of a unit, it
19849 -- configures the whole unit.
19851 elsif Nkind (Context) = N_Compilation_Unit then
19852 Check_Valid_Configuration_Pragma;
19854 if Nkind (Unit (Context)) in N_Generic_Declaration
19855 or else (Present (Library_Unit (Context))
19856 and then Nkind (Unit (Library_Unit (Context))) in
19857 N_Generic_Declaration)
19859 Error_Pragma ("incorrect placement of pragma% in a generic");
19862 SPARK_Mode_Pragma := N;
19863 SPARK_Mode := Mode_Id;
19865 -- The pragma applies to a [library unit] subprogram or package
19868 -- Verify the placement of the pragma with respect to package
19869 -- or subprogram declarations and detect duplicates.
19872 while Present (Stmt) loop
19874 -- Skip prior pragmas, but check for duplicates
19876 if Nkind (Stmt) = N_Pragma then
19877 if Pragma_Name (Stmt) = Pname then
19878 Error_Msg_Name_1 := Pname;
19879 Error_Msg_Sloc := Sloc (Stmt);
19880 Error_Msg_N ("pragma% duplicates pragma declared#", N);
19884 elsif Nkind (Stmt) in N_Generic_Declaration then
19886 ("incorrect placement of pragma% on a generic");
19888 -- The pragma applies to a package declaration
19890 elsif Nkind (Stmt) = N_Package_Declaration then
19891 Spec_Id := Defining_Entity (Stmt);
19892 Check_Library_Level_Entity (Spec_Id);
19893 Check_Pragma_Conformance
19894 (Context_Pragma => SPARK_Pragma (Spec_Id),
19895 Entity_Pragma => Empty,
19898 Set_SPARK_Pragma (Spec_Id, N);
19899 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19900 Set_SPARK_Aux_Pragma (Spec_Id, N);
19901 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
19904 -- The pragma applies to a subprogram declaration
19906 elsif Nkind (Stmt) = N_Subprogram_Declaration then
19907 Spec_Id := Defining_Entity (Stmt);
19908 Check_Library_Level_Entity (Spec_Id);
19909 Check_Pragma_Conformance
19910 (Context_Pragma => SPARK_Pragma (Spec_Id),
19911 Entity_Pragma => Empty,
19914 Set_SPARK_Pragma (Spec_Id, N);
19915 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19918 -- Skip internally generated code
19920 elsif not Comes_From_Source (Stmt) then
19923 -- The pragma does not apply to a legal construct, issue an
19924 -- error and stop the analysis.
19931 Stmt := Prev (Stmt);
19934 -- Handle all cases where the pragma is actually an aspect and
19935 -- applies to a library-level package spec, body or subprogram.
19937 -- function F ... with SPARK_Mode => ...;
19938 -- package P with SPARK_Mode => ...;
19939 -- package body P with SPARK_Mode => ... is
19941 -- The following circuitry simply prepares the proper context
19942 -- for the general pragma processing mechanism below.
19944 if Nkind (Context) = N_Compilation_Unit_Aux then
19945 Context := Unit (Parent (Context));
19947 if Nkind_In (Context, N_Package_Declaration,
19948 N_Subprogram_Declaration)
19950 Context := Specification (Context);
19954 -- The pragma is at the top level of a package spec
19957 -- pragma SPARK_Mode;
19964 -- pragma SPARK_Mode;
19966 if Nkind (Context) = N_Package_Specification then
19967 Spec_Id := Defining_Entity (Context);
19969 -- Pragma applies to private part
19971 if List_Containing (N) = Private_Declarations (Context) then
19972 Check_Library_Level_Entity (Spec_Id);
19973 Check_Pragma_Conformance
19974 (Context_Pragma => Empty,
19975 Entity_Pragma => SPARK_Pragma (Spec_Id),
19976 Entity => Spec_Id);
19977 SPARK_Mode_Pragma := N;
19978 SPARK_Mode := Mode_Id;
19980 Set_SPARK_Aux_Pragma (Spec_Id, N);
19981 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
19983 -- Pragma applies to public part
19986 Check_Library_Level_Entity (Spec_Id);
19987 Check_Pragma_Conformance
19988 (Context_Pragma => SPARK_Pragma (Spec_Id),
19989 Entity_Pragma => Empty,
19991 SPARK_Mode_Pragma := N;
19992 SPARK_Mode := Mode_Id;
19994 Set_SPARK_Pragma (Spec_Id, N);
19995 Set_SPARK_Pragma_Inherited (Spec_Id, False);
19996 Set_SPARK_Aux_Pragma (Spec_Id, N);
19997 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20000 -- The pragma appears as an aspect on a subprogram.
20002 -- function F ... with SPARK_Mode => ...;
20004 elsif Nkind_In (Context, N_Function_Specification,
20005 N_Procedure_Specification)
20007 Spec_Id := Defining_Entity (Context);
20008 Check_Library_Level_Entity (Spec_Id);
20009 Check_Pragma_Conformance
20010 (Context_Pragma => SPARK_Pragma (Spec_Id),
20011 Entity_Pragma => Empty,
20013 Set_SPARK_Pragma (Spec_Id, N);
20014 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20016 -- Pragma is immediately within a package body
20018 -- package body P is
20019 -- pragma SPARK_Mode;
20021 elsif Nkind (Context) = N_Package_Body then
20022 Spec_Id := Corresponding_Spec (Context);
20023 Body_Id := Defining_Entity (Context);
20024 Check_Library_Level_Entity (Body_Id);
20025 Check_Pragma_Conformance
20026 (Context_Pragma => SPARK_Pragma (Body_Id),
20027 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id),
20028 Entity => Spec_Id);
20029 SPARK_Mode_Pragma := N;
20030 SPARK_Mode := Mode_Id;
20032 Set_SPARK_Pragma (Body_Id, N);
20033 Set_SPARK_Pragma_Inherited (Body_Id, False);
20034 Set_SPARK_Aux_Pragma (Body_Id, N);
20035 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20037 -- Pragma is immediately within a subprogram body
20039 -- function F ... is
20040 -- pragma SPARK_Mode;
20042 elsif Nkind (Context) = N_Subprogram_Body then
20043 Spec_Id := Corresponding_Spec (Context);
20044 Context := Specification (Context);
20045 Body_Id := Defining_Entity (Context);
20047 -- Ignore pragma when applied to the special body created
20048 -- for inlining, recognized by its internal name _Parent.
20050 if Chars (Body_Id) = Name_uParent then
20054 Check_Library_Level_Entity (Body_Id);
20056 if Present (Spec_Id) then
20057 Check_Pragma_Conformance
20058 (Context_Pragma => SPARK_Pragma (Body_Id),
20059 Entity_Pragma => SPARK_Pragma (Spec_Id),
20060 Entity => Spec_Id);
20062 Check_Pragma_Conformance
20063 (Context_Pragma => SPARK_Pragma (Body_Id),
20064 Entity_Pragma => Empty,
20068 SPARK_Mode_Pragma := N;
20069 SPARK_Mode := Mode_Id;
20071 Set_SPARK_Pragma (Body_Id, N);
20072 Set_SPARK_Pragma_Inherited (Body_Id, False);
20074 -- The pragma applies to the statements of a package body
20076 -- package body P is
20078 -- pragma SPARK_Mode;
20080 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
20081 and then Nkind (Parent (Context)) = N_Package_Body
20083 Context := Parent (Context);
20084 Spec_Id := Corresponding_Spec (Context);
20085 Body_Id := Defining_Entity (Context);
20086 Check_Library_Level_Entity (Body_Id);
20087 Check_Pragma_Conformance
20088 (Context_Pragma => Empty,
20089 Entity_Pragma => SPARK_Pragma (Body_Id),
20090 Entity => Body_Id);
20091 SPARK_Mode_Pragma := N;
20092 SPARK_Mode := Mode_Id;
20094 Set_SPARK_Aux_Pragma (Body_Id, N);
20095 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20097 -- The pragma does not apply to a legal construct, issue error
20105 --------------------------------
20106 -- Static_Elaboration_Desired --
20107 --------------------------------
20109 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20111 when Pragma_Static_Elaboration_Desired =>
20113 Check_At_Most_N_Arguments (1);
20115 if Is_Compilation_Unit (Current_Scope)
20116 and then Ekind (Current_Scope) = E_Package
20118 Set_Static_Elaboration_Desired (Current_Scope, True);
20120 Error_Pragma ("pragma% must apply to a library-level package");
20127 -- pragma Storage_Size (EXPRESSION);
20129 when Pragma_Storage_Size => Storage_Size : declare
20130 P : constant Node_Id := Parent (N);
20134 Check_No_Identifiers;
20135 Check_Arg_Count (1);
20137 -- The expression must be analyzed in the special manner described
20138 -- in "Handling of Default Expressions" in sem.ads.
20140 Arg := Get_Pragma_Arg (Arg1);
20141 Preanalyze_Spec_Expression (Arg, Any_Integer);
20143 if not Is_OK_Static_Expression (Arg) then
20144 Check_Restriction (Static_Storage_Size, Arg);
20147 if Nkind (P) /= N_Task_Definition then
20152 if Has_Storage_Size_Pragma (P) then
20153 Error_Pragma ("duplicate pragma% not allowed");
20155 Set_Has_Storage_Size_Pragma (P, True);
20158 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
20166 -- pragma Storage_Unit (NUMERIC_LITERAL);
20168 -- Only permitted argument is System'Storage_Unit value
20170 when Pragma_Storage_Unit =>
20171 Check_No_Identifiers;
20172 Check_Arg_Count (1);
20173 Check_Arg_Is_Integer_Literal (Arg1);
20175 if Intval (Get_Pragma_Arg (Arg1)) /=
20176 UI_From_Int (Ttypes.System_Storage_Unit)
20178 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
20180 ("the only allowed argument for pragma% is ^", Arg1);
20183 --------------------
20184 -- Stream_Convert --
20185 --------------------
20187 -- pragma Stream_Convert (
20188 -- [Entity =>] type_LOCAL_NAME,
20189 -- [Read =>] function_NAME,
20190 -- [Write =>] function NAME);
20192 when Pragma_Stream_Convert => Stream_Convert : declare
20194 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
20195 -- Check that the given argument is the name of a local function
20196 -- of one argument that is not overloaded earlier in the current
20197 -- local scope. A check is also made that the argument is a
20198 -- function with one parameter.
20200 --------------------------------------
20201 -- Check_OK_Stream_Convert_Function --
20202 --------------------------------------
20204 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
20208 Check_Arg_Is_Local_Name (Arg);
20209 Ent := Entity (Get_Pragma_Arg (Arg));
20211 if Has_Homonym (Ent) then
20213 ("argument for pragma% may not be overloaded", Arg);
20216 if Ekind (Ent) /= E_Function
20217 or else No (First_Formal (Ent))
20218 or else Present (Next_Formal (First_Formal (Ent)))
20221 ("argument for pragma% must be function of one argument",
20224 end Check_OK_Stream_Convert_Function;
20226 -- Start of processing for Stream_Convert
20230 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
20231 Check_Arg_Count (3);
20232 Check_Optional_Identifier (Arg1, Name_Entity);
20233 Check_Optional_Identifier (Arg2, Name_Read);
20234 Check_Optional_Identifier (Arg3, Name_Write);
20235 Check_Arg_Is_Local_Name (Arg1);
20236 Check_OK_Stream_Convert_Function (Arg2);
20237 Check_OK_Stream_Convert_Function (Arg3);
20240 Typ : constant Entity_Id :=
20241 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
20242 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
20243 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
20246 Check_First_Subtype (Arg1);
20248 -- Check for too early or too late. Note that we don't enforce
20249 -- the rule about primitive operations in this case, since, as
20250 -- is the case for explicit stream attributes themselves, these
20251 -- restrictions are not appropriate. Note that the chaining of
20252 -- the pragma by Rep_Item_Too_Late is actually the critical
20253 -- processing done for this pragma.
20255 if Rep_Item_Too_Early (Typ, N)
20257 Rep_Item_Too_Late (Typ, N, FOnly => True)
20262 -- Return if previous error
20264 if Etype (Typ) = Any_Type
20266 Etype (Read) = Any_Type
20268 Etype (Write) = Any_Type
20275 if Underlying_Type (Etype (Read)) /= Typ then
20277 ("incorrect return type for function&", Arg2);
20280 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
20282 ("incorrect parameter type for function&", Arg3);
20285 if Underlying_Type (Etype (First_Formal (Read))) /=
20286 Underlying_Type (Etype (Write))
20289 ("result type of & does not match Read parameter type",
20293 end Stream_Convert;
20299 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20301 -- This is processed by the parser since some of the style checks
20302 -- take place during source scanning and parsing. This means that
20303 -- we don't need to issue error messages here.
20305 when Pragma_Style_Checks => Style_Checks : declare
20306 A : constant Node_Id := Get_Pragma_Arg (Arg1);
20312 Check_No_Identifiers;
20314 -- Two argument form
20316 if Arg_Count = 2 then
20317 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20324 E_Id := Get_Pragma_Arg (Arg2);
20327 if not Is_Entity_Name (E_Id) then
20329 ("second argument of pragma% must be entity name",
20333 E := Entity (E_Id);
20335 if not Ignore_Style_Checks_Pragmas then
20340 Set_Suppress_Style_Checks
20341 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
20342 exit when No (Homonym (E));
20349 -- One argument form
20352 Check_Arg_Count (1);
20354 if Nkind (A) = N_String_Literal then
20358 Slen : constant Natural := Natural (String_Length (S));
20359 Options : String (1 .. Slen);
20365 C := Get_String_Char (S, Int (J));
20366 exit when not In_Character_Range (C);
20367 Options (J) := Get_Character (C);
20369 -- If at end of string, set options. As per discussion
20370 -- above, no need to check for errors, since we issued
20371 -- them in the parser.
20374 if not Ignore_Style_Checks_Pragmas then
20375 Set_Style_Check_Options (Options);
20385 elsif Nkind (A) = N_Identifier then
20386 if Chars (A) = Name_All_Checks then
20387 if not Ignore_Style_Checks_Pragmas then
20389 Set_GNAT_Style_Check_Options;
20391 Set_Default_Style_Check_Options;
20395 elsif Chars (A) = Name_On then
20396 if not Ignore_Style_Checks_Pragmas then
20397 Style_Check := True;
20400 elsif Chars (A) = Name_Off then
20401 if not Ignore_Style_Checks_Pragmas then
20402 Style_Check := False;
20413 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20415 when Pragma_Subtitle =>
20417 Check_Arg_Count (1);
20418 Check_Optional_Identifier (Arg1, Name_Subtitle);
20419 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20426 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20428 when Pragma_Suppress =>
20429 Process_Suppress_Unsuppress (True);
20435 -- pragma Suppress_All;
20437 -- The only check made here is that the pragma has no arguments.
20438 -- There are no placement rules, and the processing required (setting
20439 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20440 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20441 -- then creates and inserts a pragma Suppress (All_Checks).
20443 when Pragma_Suppress_All =>
20445 Check_Arg_Count (0);
20447 -------------------------
20448 -- Suppress_Debug_Info --
20449 -------------------------
20451 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20453 when Pragma_Suppress_Debug_Info =>
20455 Check_Arg_Count (1);
20456 Check_Optional_Identifier (Arg1, Name_Entity);
20457 Check_Arg_Is_Local_Name (Arg1);
20458 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
20460 ----------------------------------
20461 -- Suppress_Exception_Locations --
20462 ----------------------------------
20464 -- pragma Suppress_Exception_Locations;
20466 when Pragma_Suppress_Exception_Locations =>
20468 Check_Arg_Count (0);
20469 Check_Valid_Configuration_Pragma;
20470 Exception_Locations_Suppressed := True;
20472 -----------------------------
20473 -- Suppress_Initialization --
20474 -----------------------------
20476 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20478 when Pragma_Suppress_Initialization => Suppress_Init : declare
20484 Check_Arg_Count (1);
20485 Check_Optional_Identifier (Arg1, Name_Entity);
20486 Check_Arg_Is_Local_Name (Arg1);
20488 E_Id := Get_Pragma_Arg (Arg1);
20490 if Etype (E_Id) = Any_Type then
20494 E := Entity (E_Id);
20496 if not Is_Type (E) then
20497 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
20500 if Rep_Item_Too_Early (E, N)
20502 Rep_Item_Too_Late (E, N, FOnly => True)
20507 -- For incomplete/private type, set flag on full view
20509 if Is_Incomplete_Or_Private_Type (E) then
20510 if No (Full_View (Base_Type (E))) then
20512 ("argument of pragma% cannot be an incomplete type", Arg1);
20514 Set_Suppress_Initialization (Full_View (Base_Type (E)));
20517 -- For first subtype, set flag on base type
20519 elsif Is_First_Subtype (E) then
20520 Set_Suppress_Initialization (Base_Type (E));
20522 -- For other than first subtype, set flag on subtype itself
20525 Set_Suppress_Initialization (E);
20533 -- pragma System_Name (DIRECT_NAME);
20535 -- Syntax check: one argument, which must be the identifier GNAT or
20536 -- the identifier GCC, no other identifiers are acceptable.
20538 when Pragma_System_Name =>
20540 Check_No_Identifiers;
20541 Check_Arg_Count (1);
20542 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
20544 -----------------------------
20545 -- Task_Dispatching_Policy --
20546 -----------------------------
20548 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20550 when Pragma_Task_Dispatching_Policy => declare
20554 Check_Ada_83_Warning;
20555 Check_Arg_Count (1);
20556 Check_No_Identifiers;
20557 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
20558 Check_Valid_Configuration_Pragma;
20559 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
20560 DP := Fold_Upper (Name_Buffer (1));
20562 if Task_Dispatching_Policy /= ' '
20563 and then Task_Dispatching_Policy /= DP
20565 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
20567 ("task dispatching policy incompatible with policy#");
20569 -- Set new policy, but always preserve System_Location since we
20570 -- like the error message with the run time name.
20573 Task_Dispatching_Policy := DP;
20575 if Task_Dispatching_Policy_Sloc /= System_Location then
20576 Task_Dispatching_Policy_Sloc := Loc;
20585 -- pragma Task_Info (EXPRESSION);
20587 when Pragma_Task_Info => Task_Info : declare
20588 P : constant Node_Id := Parent (N);
20594 if Warn_On_Obsolescent_Feature then
20596 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20597 & "instead?j?", N);
20600 if Nkind (P) /= N_Task_Definition then
20601 Error_Pragma ("pragma% must appear in task definition");
20604 Check_No_Identifiers;
20605 Check_Arg_Count (1);
20607 Analyze_And_Resolve
20608 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
20610 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
20614 Ent := Defining_Identifier (Parent (P));
20616 -- Check duplicate pragma before we chain the pragma in the Rep
20617 -- Item chain of Ent.
20620 (Ent, Name_Task_Info, Check_Parents => False)
20622 Error_Pragma ("duplicate pragma% not allowed");
20625 Record_Rep_Item (Ent, N);
20632 -- pragma Task_Name (string_EXPRESSION);
20634 when Pragma_Task_Name => Task_Name : declare
20635 P : constant Node_Id := Parent (N);
20640 Check_No_Identifiers;
20641 Check_Arg_Count (1);
20643 Arg := Get_Pragma_Arg (Arg1);
20645 -- The expression is used in the call to Create_Task, and must be
20646 -- expanded there, not in the context of the current spec. It must
20647 -- however be analyzed to capture global references, in case it
20648 -- appears in a generic context.
20650 Preanalyze_And_Resolve (Arg, Standard_String);
20652 if Nkind (P) /= N_Task_Definition then
20656 Ent := Defining_Identifier (Parent (P));
20658 -- Check duplicate pragma before we chain the pragma in the Rep
20659 -- Item chain of Ent.
20662 (Ent, Name_Task_Name, Check_Parents => False)
20664 Error_Pragma ("duplicate pragma% not allowed");
20667 Record_Rep_Item (Ent, N);
20674 -- pragma Task_Storage (
20675 -- [Task_Type =>] LOCAL_NAME,
20676 -- [Top_Guard =>] static_integer_EXPRESSION);
20678 when Pragma_Task_Storage => Task_Storage : declare
20679 Args : Args_List (1 .. 2);
20680 Names : constant Name_List (1 .. 2) := (
20684 Task_Type : Node_Id renames Args (1);
20685 Top_Guard : Node_Id renames Args (2);
20691 Gather_Associations (Names, Args);
20693 if No (Task_Type) then
20695 ("missing task_type argument for pragma%");
20698 Check_Arg_Is_Local_Name (Task_Type);
20700 Ent := Entity (Task_Type);
20702 if not Is_Task_Type (Ent) then
20704 ("argument for pragma% must be task type", Task_Type);
20707 if No (Top_Guard) then
20709 ("pragma% takes two arguments", Task_Type);
20711 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
20714 Check_First_Subtype (Task_Type);
20716 if Rep_Item_Too_Late (Ent, N) then
20725 -- pragma Test_Case
20726 -- ([Name =>] Static_String_EXPRESSION
20727 -- ,[Mode =>] MODE_TYPE
20728 -- [, Requires => Boolean_EXPRESSION]
20729 -- [, Ensures => Boolean_EXPRESSION]);
20731 -- MODE_TYPE ::= Nominal | Robustness
20733 when Pragma_Test_Case =>
20737 --------------------------
20738 -- Thread_Local_Storage --
20739 --------------------------
20741 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20743 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
20749 Check_Arg_Count (1);
20750 Check_Optional_Identifier (Arg1, Name_Entity);
20751 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20753 Id := Get_Pragma_Arg (Arg1);
20756 if not Is_Entity_Name (Id)
20757 or else Ekind (Entity (Id)) /= E_Variable
20759 Error_Pragma_Arg ("local variable name required", Arg1);
20764 if Rep_Item_Too_Early (E, N)
20765 or else Rep_Item_Too_Late (E, N)
20770 Set_Has_Pragma_Thread_Local_Storage (E);
20771 Set_Has_Gigi_Rep_Item (E);
20772 end Thread_Local_Storage;
20778 -- pragma Time_Slice (static_duration_EXPRESSION);
20780 when Pragma_Time_Slice => Time_Slice : declare
20786 Check_Arg_Count (1);
20787 Check_No_Identifiers;
20788 Check_In_Main_Program;
20789 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
20791 if not Error_Posted (Arg1) then
20793 while Present (Nod) loop
20794 if Nkind (Nod) = N_Pragma
20795 and then Pragma_Name (Nod) = Name_Time_Slice
20797 Error_Msg_Name_1 := Pname;
20798 Error_Msg_N ("duplicate pragma% not permitted", Nod);
20805 -- Process only if in main unit
20807 if Get_Source_Unit (Loc) = Main_Unit then
20808 Opt.Time_Slice_Set := True;
20809 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
20811 if Val <= Ureal_0 then
20812 Opt.Time_Slice_Value := 0;
20814 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
20815 Opt.Time_Slice_Value := 1_000_000_000;
20818 Opt.Time_Slice_Value :=
20819 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
20828 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20830 -- TITLING_OPTION ::=
20831 -- [Title =>] STRING_LITERAL
20832 -- | [Subtitle =>] STRING_LITERAL
20834 when Pragma_Title => Title : declare
20835 Args : Args_List (1 .. 2);
20836 Names : constant Name_List (1 .. 2) := (
20842 Gather_Associations (Names, Args);
20845 for J in 1 .. 2 loop
20846 if Present (Args (J)) then
20847 Check_Arg_Is_OK_Static_Expression
20848 (Args (J), Standard_String);
20853 ----------------------------
20854 -- Type_Invariant[_Class] --
20855 ----------------------------
20857 -- pragma Type_Invariant[_Class]
20858 -- ([Entity =>] type_LOCAL_NAME,
20859 -- [Check =>] EXPRESSION);
20861 when Pragma_Type_Invariant |
20862 Pragma_Type_Invariant_Class =>
20863 Type_Invariant : declare
20864 I_Pragma : Node_Id;
20867 Check_Arg_Count (2);
20869 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20870 -- setting Class_Present for the Type_Invariant_Class case.
20872 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
20873 I_Pragma := New_Copy (N);
20874 Set_Pragma_Identifier
20875 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
20876 Rewrite (N, I_Pragma);
20877 Set_Analyzed (N, False);
20879 end Type_Invariant;
20881 ---------------------
20882 -- Unchecked_Union --
20883 ---------------------
20885 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20887 when Pragma_Unchecked_Union => Unchecked_Union : declare
20888 Assoc : constant Node_Id := Arg1;
20889 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
20899 Check_No_Identifiers;
20900 Check_Arg_Count (1);
20901 Check_Arg_Is_Local_Name (Arg1);
20903 Find_Type (Type_Id);
20905 Typ := Entity (Type_Id);
20908 or else Rep_Item_Too_Early (Typ, N)
20912 Typ := Underlying_Type (Typ);
20915 if Rep_Item_Too_Late (Typ, N) then
20919 Check_First_Subtype (Arg1);
20921 -- Note remaining cases are references to a type in the current
20922 -- declarative part. If we find an error, we post the error on
20923 -- the relevant type declaration at an appropriate point.
20925 if not Is_Record_Type (Typ) then
20926 Error_Msg_N ("unchecked union must be record type", Typ);
20929 elsif Is_Tagged_Type (Typ) then
20930 Error_Msg_N ("unchecked union must not be tagged", Typ);
20933 elsif not Has_Discriminants (Typ) then
20935 ("unchecked union must have one discriminant", Typ);
20938 -- Note: in previous versions of GNAT we used to check for limited
20939 -- types and give an error, but in fact the standard does allow
20940 -- Unchecked_Union on limited types, so this check was removed.
20942 -- Similarly, GNAT used to require that all discriminants have
20943 -- default values, but this is not mandated by the RM.
20945 -- Proceed with basic error checks completed
20948 Tdef := Type_Definition (Declaration_Node (Typ));
20949 Clist := Component_List (Tdef);
20951 -- Check presence of component list and variant part
20953 if No (Clist) or else No (Variant_Part (Clist)) then
20955 ("unchecked union must have variant part", Tdef);
20959 -- Check components
20961 Comp := First (Component_Items (Clist));
20962 while Present (Comp) loop
20963 Check_Component (Comp, Typ);
20967 -- Check variant part
20969 Vpart := Variant_Part (Clist);
20971 Variant := First (Variants (Vpart));
20972 while Present (Variant) loop
20973 Check_Variant (Variant, Typ);
20978 Set_Is_Unchecked_Union (Typ);
20979 Set_Convention (Typ, Convention_C);
20980 Set_Has_Unchecked_Union (Base_Type (Typ));
20981 Set_Is_Unchecked_Union (Base_Type (Typ));
20982 end Unchecked_Union;
20984 ------------------------
20985 -- Unimplemented_Unit --
20986 ------------------------
20988 -- pragma Unimplemented_Unit;
20990 -- Note: this only gives an error if we are generating code, or if
20991 -- we are in a generic library unit (where the pragma appears in the
20992 -- body, not in the spec).
20994 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
20995 Cunitent : constant Entity_Id :=
20996 Cunit_Entity (Get_Source_Unit (Loc));
20997 Ent_Kind : constant Entity_Kind :=
21002 Check_Arg_Count (0);
21004 if Operating_Mode = Generate_Code
21005 or else Ent_Kind = E_Generic_Function
21006 or else Ent_Kind = E_Generic_Procedure
21007 or else Ent_Kind = E_Generic_Package
21009 Get_Name_String (Chars (Cunitent));
21010 Set_Casing (Mixed_Case);
21011 Write_Str (Name_Buffer (1 .. Name_Len));
21012 Write_Str (" is not supported in this configuration");
21014 raise Unrecoverable_Error;
21016 end Unimplemented_Unit;
21018 ------------------------
21019 -- Universal_Aliasing --
21020 ------------------------
21022 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
21024 when Pragma_Universal_Aliasing => Universal_Alias : declare
21029 Check_Arg_Count (1);
21030 Check_Optional_Identifier (Arg2, Name_Entity);
21031 Check_Arg_Is_Local_Name (Arg1);
21032 E_Id := Entity (Get_Pragma_Arg (Arg1));
21034 if E_Id = Any_Type then
21036 elsif No (E_Id) or else not Is_Type (E_Id) then
21037 Error_Pragma_Arg ("pragma% requires type", Arg1);
21040 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
21041 Record_Rep_Item (E_Id, N);
21042 end Universal_Alias;
21044 --------------------
21045 -- Universal_Data --
21046 --------------------
21048 -- pragma Universal_Data [(library_unit_NAME)];
21050 when Pragma_Universal_Data =>
21053 -- If this is a configuration pragma, then set the universal
21054 -- addressing option, otherwise confirm that the pragma satisfies
21055 -- the requirements of library unit pragma placement and leave it
21056 -- to the GNAAMP back end to detect the pragma (avoids transitive
21057 -- setting of the option due to withed units).
21059 if Is_Configuration_Pragma then
21060 Universal_Addressing_On_AAMP := True;
21062 Check_Valid_Library_Unit_Pragma;
21065 if not AAMP_On_Target then
21066 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
21073 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
21075 when Pragma_Unmodified => Unmodified : declare
21076 Arg_Node : Node_Id;
21077 Arg_Expr : Node_Id;
21078 Arg_Ent : Entity_Id;
21082 Check_At_Least_N_Arguments (1);
21084 -- Loop through arguments
21087 while Present (Arg_Node) loop
21088 Check_No_Identifier (Arg_Node);
21090 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21091 -- in fact generate reference, so that the entity will have a
21092 -- reference, which will inhibit any warnings about it not
21093 -- being referenced, and also properly show up in the ali file
21094 -- as a reference. But this reference is recorded before the
21095 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21096 -- generated for this reference.
21098 Check_Arg_Is_Local_Name (Arg_Node);
21099 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21101 if Is_Entity_Name (Arg_Expr) then
21102 Arg_Ent := Entity (Arg_Expr);
21104 if not Is_Assignable (Arg_Ent) then
21106 ("pragma% can only be applied to a variable",
21109 Set_Has_Pragma_Unmodified (Arg_Ent);
21121 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21123 -- or when used in a context clause:
21125 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21127 when Pragma_Unreferenced => Unreferenced : declare
21128 Arg_Node : Node_Id;
21129 Arg_Expr : Node_Id;
21130 Arg_Ent : Entity_Id;
21135 Check_At_Least_N_Arguments (1);
21137 -- Check case of appearing within context clause
21139 if Is_In_Context_Clause then
21141 -- The arguments must all be units mentioned in a with clause
21142 -- in the same context clause. Note we already checked (in
21143 -- Par.Prag) that the arguments are either identifiers or
21144 -- selected components.
21147 while Present (Arg_Node) loop
21148 Citem := First (List_Containing (N));
21149 while Citem /= N loop
21150 if Nkind (Citem) = N_With_Clause
21152 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
21154 Set_Has_Pragma_Unreferenced
21157 (Library_Unit (Citem))));
21159 (Get_Pragma_Arg (Arg_Node), Name (Citem));
21168 ("argument of pragma% is not withed unit", Arg_Node);
21174 -- Case of not in list of context items
21178 while Present (Arg_Node) loop
21179 Check_No_Identifier (Arg_Node);
21181 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21182 -- will in fact generate reference, so that the entity will
21183 -- have a reference, which will inhibit any warnings about
21184 -- it not being referenced, and also properly show up in the
21185 -- ali file as a reference. But this reference is recorded
21186 -- before the Has_Pragma_Unreferenced flag is set, so that
21187 -- no warning is generated for this reference.
21189 Check_Arg_Is_Local_Name (Arg_Node);
21190 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21192 if Is_Entity_Name (Arg_Expr) then
21193 Arg_Ent := Entity (Arg_Expr);
21195 -- If the entity is overloaded, the pragma applies to the
21196 -- most recent overloading, as documented. In this case,
21197 -- name resolution does not generate a reference, so it
21198 -- must be done here explicitly.
21200 if Is_Overloaded (Arg_Expr) then
21201 Generate_Reference (Arg_Ent, N);
21204 Set_Has_Pragma_Unreferenced (Arg_Ent);
21212 --------------------------
21213 -- Unreferenced_Objects --
21214 --------------------------
21216 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21218 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
21219 Arg_Node : Node_Id;
21220 Arg_Expr : Node_Id;
21224 Check_At_Least_N_Arguments (1);
21227 while Present (Arg_Node) loop
21228 Check_No_Identifier (Arg_Node);
21229 Check_Arg_Is_Local_Name (Arg_Node);
21230 Arg_Expr := Get_Pragma_Arg (Arg_Node);
21232 if not Is_Entity_Name (Arg_Expr)
21233 or else not Is_Type (Entity (Arg_Expr))
21236 ("argument for pragma% must be type or subtype", Arg_Node);
21239 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
21242 end Unreferenced_Objects;
21244 ------------------------------
21245 -- Unreserve_All_Interrupts --
21246 ------------------------------
21248 -- pragma Unreserve_All_Interrupts;
21250 when Pragma_Unreserve_All_Interrupts =>
21252 Check_Arg_Count (0);
21254 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
21255 Unreserve_All_Interrupts := True;
21262 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21264 when Pragma_Unsuppress =>
21266 Process_Suppress_Unsuppress (False);
21268 ----------------------------
21269 -- Unevaluated_Use_Of_Old --
21270 ----------------------------
21272 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21274 when Pragma_Unevaluated_Use_Of_Old =>
21276 Check_Arg_Count (1);
21277 Check_No_Identifiers;
21278 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
21280 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21281 -- a declarative part or a package spec.
21283 if not Is_Configuration_Pragma then
21284 Check_Is_In_Decl_Part_Or_Package_Spec;
21287 -- Store proper setting of Uneval_Old
21289 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21290 Uneval_Old := Fold_Upper (Name_Buffer (1));
21292 -------------------
21293 -- Use_VADS_Size --
21294 -------------------
21296 -- pragma Use_VADS_Size;
21298 when Pragma_Use_VADS_Size =>
21300 Check_Arg_Count (0);
21301 Check_Valid_Configuration_Pragma;
21302 Use_VADS_Size := True;
21304 ---------------------
21305 -- Validity_Checks --
21306 ---------------------
21308 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21310 when Pragma_Validity_Checks => Validity_Checks : declare
21311 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21317 Check_Arg_Count (1);
21318 Check_No_Identifiers;
21320 -- Pragma always active unless in CodePeer or GNATprove modes,
21321 -- which use a fixed configuration of validity checks.
21323 if not (CodePeer_Mode or GNATprove_Mode) then
21324 if Nkind (A) = N_String_Literal then
21328 Slen : constant Natural := Natural (String_Length (S));
21329 Options : String (1 .. Slen);
21333 -- Couldn't we use a for loop here over Options'Range???
21337 C := Get_String_Char (S, Int (J));
21339 -- This is a weird test, it skips setting validity
21340 -- checks entirely if any element of S is out of
21341 -- range of Character, what is that about ???
21343 exit when not In_Character_Range (C);
21344 Options (J) := Get_Character (C);
21347 Set_Validity_Check_Options (Options);
21355 elsif Nkind (A) = N_Identifier then
21356 if Chars (A) = Name_All_Checks then
21357 Set_Validity_Check_Options ("a");
21358 elsif Chars (A) = Name_On then
21359 Validity_Checks_On := True;
21360 elsif Chars (A) = Name_Off then
21361 Validity_Checks_On := False;
21365 end Validity_Checks;
21371 -- pragma Volatile (LOCAL_NAME);
21373 when Pragma_Volatile =>
21374 Process_Atomic_Shared_Volatile;
21376 -------------------------
21377 -- Volatile_Components --
21378 -------------------------
21380 -- pragma Volatile_Components (array_LOCAL_NAME);
21382 -- Volatile is handled by the same circuit as Atomic_Components
21384 ----------------------
21385 -- Warning_As_Error --
21386 ----------------------
21388 when Pragma_Warning_As_Error =>
21390 Check_Arg_Count (1);
21391 Check_No_Identifiers;
21392 Check_Valid_Configuration_Pragma;
21394 if not Is_Static_String_Expression (Arg1) then
21396 ("argument of pragma% must be static string expression",
21399 -- OK static string expression
21402 Acquire_Warning_Match_String (Arg1);
21403 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
21404 Warnings_As_Errors (Warnings_As_Errors_Count) :=
21405 new String'(Name_Buffer (1 .. Name_Len));
21412 -- pragma Warnings (On | Off [,REASON]);
21413 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
21414 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
21415 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
21417 -- REASON ::= Reason => Static_String_Expression
21419 when Pragma_Warnings => Warnings : declare
21420 Reason : String_Id;
21424 Check_At_Least_N_Arguments (1);
21426 -- See if last argument is labeled Reason. If so, make sure we
21427 -- have a static string expression, and acquire the REASON string.
21428 -- Then remove the REASON argument by decreasing Num_Args by one;
21429 -- Remaining processing looks only at first Num_Args arguments).
21432 Last_Arg : constant Node_Id :=
21433 Last (Pragma_Argument_Associations (N));
21436 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21437 and then Chars (Last_Arg) = Name_Reason
21440 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21441 Reason := End_String;
21442 Arg_Count := Arg_Count - 1;
21444 -- Not allowed in compiler units (bootstrap issues)
21446 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21448 -- No REASON string, set null string as reason
21451 Reason := Null_String_Id;
21455 -- Now proceed with REASON taken care of and eliminated
21457 Check_No_Identifiers;
21459 -- If debug flag -gnatd.i is set, pragma is ignored
21461 if Debug_Flag_Dot_I then
21465 -- Process various forms of the pragma
21468 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21471 -- One argument case
21473 if Arg_Count = 1 then
21475 -- On/Off one argument case was processed by parser
21477 if Nkind (Argx) = N_Identifier
21478 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21482 -- One argument case must be ON/OFF or static string expr
21484 elsif not Is_Static_String_Expression (Arg1) then
21486 ("argument of pragma% must be On/Off or static string "
21487 & "expression", Arg1);
21489 -- One argument string expression case
21493 Lit : constant Node_Id := Expr_Value_S (Argx);
21494 Str : constant String_Id := Strval (Lit);
21495 Len : constant Nat := String_Length (Str);
21503 while J <= Len loop
21504 C := Get_String_Char (Str, J);
21505 OK := In_Character_Range (C);
21508 Chr := Get_Character (C);
21510 -- Dash case: only -Wxxx is accepted
21517 C := Get_String_Char (Str, J);
21518 Chr := Get_Character (C);
21519 exit when Chr = 'W';
21524 elsif J < Len and then Chr = '.' then
21526 C := Get_String_Char (Str, J);
21527 Chr := Get_Character (C);
21529 if not Set_Dot_Warning_Switch (Chr) then
21531 ("invalid warning switch character "
21532 & '.' & Chr, Arg1);
21538 OK := Set_Warning_Switch (Chr);
21544 ("invalid warning switch character " & Chr,
21553 -- Two or more arguments (must be two)
21556 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21557 Check_Arg_Count (2);
21565 E_Id := Get_Pragma_Arg (Arg2);
21568 -- In the expansion of an inlined body, a reference to
21569 -- the formal may be wrapped in a conversion if the
21570 -- actual is a conversion. Retrieve the real entity name.
21572 if (In_Instance_Body or In_Inlined_Body)
21573 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21575 E_Id := Expression (E_Id);
21578 -- Entity name case
21580 if Is_Entity_Name (E_Id) then
21581 E := Entity (E_Id);
21588 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21591 -- For OFF case, make entry in warnings off
21592 -- pragma table for later processing. But we do
21593 -- not do that within an instance, since these
21594 -- warnings are about what is needed in the
21595 -- template, not an instance of it.
21597 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21598 and then Warn_On_Warnings_Off
21599 and then not In_Instance
21601 Warnings_Off_Pragmas.Append ((N, E, Reason));
21604 if Is_Enumeration_Type (E) then
21608 Lit := First_Literal (E);
21609 while Present (Lit) loop
21610 Set_Warnings_Off (Lit);
21611 Next_Literal (Lit);
21616 exit when No (Homonym (E));
21621 -- Error if not entity or static string expression case
21623 elsif not Is_Static_String_Expression (Arg2) then
21625 ("second argument of pragma% must be entity name "
21626 & "or static string expression", Arg2);
21628 -- Static string expression case
21631 Acquire_Warning_Match_String (Arg2);
21633 -- Note on configuration pragma case: If this is a
21634 -- configuration pragma, then for an OFF pragma, we
21635 -- just set Config True in the call, which is all
21636 -- that needs to be done. For the case of ON, this
21637 -- is normally an error, unless it is canceling the
21638 -- effect of a previous OFF pragma in the same file.
21639 -- In any other case, an error will be signalled (ON
21640 -- with no matching OFF).
21642 -- Note: We set Used if we are inside a generic to
21643 -- disable the test that the non-config case actually
21644 -- cancels a warning. That's because we can't be sure
21645 -- there isn't an instantiation in some other unit
21646 -- where a warning is suppressed.
21648 -- We could do a little better here by checking if the
21649 -- generic unit we are inside is public, but for now
21650 -- we don't bother with that refinement.
21652 if Chars (Argx) = Name_Off then
21653 Set_Specific_Warning_Off
21654 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21655 Config => Is_Configuration_Pragma,
21656 Used => Inside_A_Generic or else In_Instance);
21658 elsif Chars (Argx) = Name_On then
21659 Set_Specific_Warning_On
21660 (Loc, Name_Buffer (1 .. Name_Len), Err);
21664 ("??pragma Warnings On with no matching "
21665 & "Warnings Off", Loc);
21674 -------------------
21675 -- Weak_External --
21676 -------------------
21678 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21680 when Pragma_Weak_External => Weak_External : declare
21685 Check_Arg_Count (1);
21686 Check_Optional_Identifier (Arg1, Name_Entity);
21687 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21688 Ent := Entity (Get_Pragma_Arg (Arg1));
21690 if Rep_Item_Too_Early (Ent, N) then
21693 Ent := Underlying_Type (Ent);
21696 -- The only processing required is to link this item on to the
21697 -- list of rep items for the given entity. This is accomplished
21698 -- by the call to Rep_Item_Too_Late (when no error is detected
21699 -- and False is returned).
21701 if Rep_Item_Too_Late (Ent, N) then
21704 Set_Has_Gigi_Rep_Item (Ent);
21708 -----------------------------
21709 -- Wide_Character_Encoding --
21710 -----------------------------
21712 -- pragma Wide_Character_Encoding (IDENTIFIER);
21714 when Pragma_Wide_Character_Encoding =>
21717 -- Nothing to do, handled in parser. Note that we do not enforce
21718 -- configuration pragma placement, this pragma can appear at any
21719 -- place in the source, allowing mixed encodings within a single
21724 --------------------
21725 -- Unknown_Pragma --
21726 --------------------
21728 -- Should be impossible, since the case of an unknown pragma is
21729 -- separately processed before the case statement is entered.
21731 when Unknown_Pragma =>
21732 raise Program_Error;
21735 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21736 -- until AI is formally approved.
21738 -- Check_Order_Dependence;
21741 when Pragma_Exit => null;
21742 end Analyze_Pragma;
21744 ---------------------------------------------
21745 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21746 ---------------------------------------------
21748 procedure Analyze_Pre_Post_Condition_In_Decl_Part
21750 Subp_Id : Entity_Id)
21752 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag));
21753 Nam : constant Name_Id := Original_Aspect_Name (Prag);
21756 Restore_Scope : Boolean := False;
21757 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21760 -- Ensure that the subprogram and its formals are visible when analyzing
21761 -- the expression of the pragma.
21763 if not In_Open_Scopes (Subp_Id) then
21764 Restore_Scope := True;
21765 Push_Scope (Subp_Id);
21766 Install_Formals (Subp_Id);
21769 -- Preanalyze the boolean expression, we treat this as a spec expression
21770 -- (i.e. similar to a default expression).
21772 Expr := Get_Pragma_Arg (Arg1);
21774 -- In ASIS mode, for a pragma generated from a source aspect, analyze
21775 -- the original aspect expression, which is shared with the generated
21778 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
21779 Expr := Expression (Corresponding_Aspect (Prag));
21782 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21784 -- For a class-wide condition, a reference to a controlling formal must
21785 -- be interpreted as having the class-wide type (or an access to such)
21786 -- so that the inherited condition can be properly applied to any
21787 -- overriding operation (see ARM12 6.6.1 (7)).
21789 if Class_Present (Prag) then
21790 Class_Wide_Condition : declare
21791 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
21793 ACW : Entity_Id := Empty;
21794 -- Access to T'class, created if there is a controlling formal
21795 -- that is an access parameter.
21797 function Get_ACW return Entity_Id;
21798 -- If the expression has a reference to an controlling access
21799 -- parameter, create an access to T'class for the necessary
21800 -- conversions if one does not exist.
21802 function Process (N : Node_Id) return Traverse_Result;
21803 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21804 -- aspect for a primitive subprogram of a tagged type T, a name
21805 -- that denotes a formal parameter of type T is interpreted as
21806 -- having type T'Class. Similarly, a name that denotes a formal
21807 -- accessparameter of type access-to-T is interpreted as having
21808 -- type access-to-T'Class. This ensures the expression is well-
21809 -- defined for a primitive subprogram of a type descended from T.
21810 -- Note that this replacement is not done for selector names in
21811 -- parameter associations. These carry an entity for reference
21812 -- purposes, but semantically they are just identifiers.
21818 function Get_ACW return Entity_Id is
21819 Loc : constant Source_Ptr := Sloc (Prag);
21825 Make_Full_Type_Declaration (Loc,
21826 Defining_Identifier => Make_Temporary (Loc, 'T'),
21828 Make_Access_To_Object_Definition (Loc,
21829 Subtype_Indication =>
21830 New_Occurrence_Of (Class_Wide_Type (T), Loc),
21831 All_Present => True));
21833 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
21835 ACW := Defining_Identifier (Decl);
21836 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
21846 function Process (N : Node_Id) return Traverse_Result is
21847 Loc : constant Source_Ptr := Sloc (N);
21851 if Is_Entity_Name (N)
21852 and then Present (Entity (N))
21853 and then Is_Formal (Entity (N))
21854 and then Nkind (Parent (N)) /= N_Type_Conversion
21856 (Nkind (Parent (N)) /= N_Parameter_Association
21857 or else N /= Selector_Name (Parent (N)))
21859 if Etype (Entity (N)) = T then
21860 Typ := Class_Wide_Type (T);
21862 elsif Is_Access_Type (Etype (Entity (N)))
21863 and then Designated_Type (Etype (Entity (N))) = T
21870 if Present (Typ) then
21872 Make_Type_Conversion (Loc,
21874 New_Occurrence_Of (Typ, Loc),
21875 Expression => New_Occurrence_Of (Entity (N), Loc)));
21876 Set_Etype (N, Typ);
21883 procedure Replace_Type is new Traverse_Proc (Process);
21885 -- Start of processing for Class_Wide_Condition
21888 if not Present (T) then
21890 -- Pre'Class/Post'Class aspect cases
21892 if From_Aspect_Specification (Prag) then
21893 if Nam = Name_uPre then
21894 Error_Msg_Name_1 := Name_Pre;
21896 Error_Msg_Name_1 := Name_Post;
21899 Error_Msg_Name_2 := Name_Class;
21902 ("aspect `%''%` can only be specified for a primitive "
21903 & "operation of a tagged type",
21904 Corresponding_Aspect (Prag));
21906 -- Pre_Class, Post_Class pragma cases
21909 if Nam = Name_uPre then
21910 Error_Msg_Name_1 := Name_Pre_Class;
21912 Error_Msg_Name_1 := Name_Post_Class;
21916 ("pragma% can only be specified for a primitive "
21917 & "operation of a tagged type",
21918 Corresponding_Aspect (Prag));
21922 Replace_Type (Get_Pragma_Arg (Arg1));
21923 end Class_Wide_Condition;
21926 -- Remove the subprogram from the scope stack now that the pre-analysis
21927 -- of the precondition/postcondition is done.
21929 if Restore_Scope then
21932 end Analyze_Pre_Post_Condition_In_Decl_Part;
21934 ------------------------------------------
21935 -- Analyze_Refined_Depends_In_Decl_Part --
21936 ------------------------------------------
21938 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21939 Dependencies : List_Id := No_List;
21941 -- The corresponding Depends pragma along with its clauses
21943 Matched_Items : Elist_Id := No_Elist;
21944 -- A list containing the entities of all successfully matched items
21945 -- found in pragma Depends.
21947 Refinements : List_Id := No_List;
21948 -- The clauses of pragma Refined_Depends
21950 Spec_Id : Entity_Id;
21951 -- The entity of the subprogram subject to pragma Refined_Depends
21953 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21954 -- Try to match a single dependency clause Dep_Clause against one or
21955 -- more refinement clauses found in list Refinements. Each successful
21956 -- match eliminates at least one refinement clause from Refinements.
21958 procedure Normalize_Clauses (Clauses : List_Id);
21959 -- Given a list of dependence or refinement clauses Clauses, normalize
21960 -- each clause by creating multiple dependencies with exactly one input
21963 procedure Report_Extra_Clauses;
21964 -- Emit an error for each extra clause found in list Refinements
21966 -----------------------------
21967 -- Check_Dependency_Clause --
21968 -----------------------------
21970 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21971 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21972 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21974 function Is_In_Out_State_Clause return Boolean;
21975 -- Determine whether dependence clause Dep_Clause denotes an abstract
21976 -- state that depends on itself (State => State).
21978 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21979 -- Determine whether item Item denotes an abstract state with visible
21980 -- null refinement.
21982 procedure Match_Items
21983 (Dep_Item : Node_Id;
21984 Ref_Item : Node_Id;
21985 Matched : out Boolean);
21986 -- Try to match dependence item Dep_Item against refinement item
21987 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21988 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21989 -- the following conformance scenarios is in effect:
21990 -- 1) Both items denote null
21991 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21992 -- 3) Both items denote attribute 'Result
21993 -- 4) Both items denote the same formal parameter
21994 -- 5) Both items denote the same variable
21995 -- 6) Dep_Item is an abstract state with visible null refinement
21996 -- and Ref_Item denotes null.
21997 -- 7) Dep_Item is an abstract state with visible null refinement
21998 -- and Ref_Item is Empty (special case).
21999 -- 8) Dep_Item is an abstract state with visible non-null
22000 -- refinement and Ref_Item denotes one of its constituents.
22001 -- 9) Dep_Item is an abstract state without a visible refinement
22002 -- and Ref_Item denotes the same state.
22003 -- When scenario 8 is in effect, the entity of the abstract state
22004 -- denoted by Dep_Item is added to list Refined_States.
22006 procedure Record_Item (Item_Id : Entity_Id);
22007 -- Store the entity of an item denoted by Item_Id in Matched_Items
22009 ----------------------------
22010 -- Is_In_Out_State_Clause --
22011 ----------------------------
22013 function Is_In_Out_State_Clause return Boolean is
22014 Dep_Input_Id : Entity_Id;
22015 Dep_Output_Id : Entity_Id;
22018 -- Detect the following clause:
22021 if Is_Entity_Name (Dep_Input)
22022 and then Is_Entity_Name (Dep_Output)
22024 -- Handle abstract views generated for limited with clauses
22026 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
22027 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
22030 Ekind (Dep_Input_Id) = E_Abstract_State
22031 and then Dep_Input_Id = Dep_Output_Id;
22035 end Is_In_Out_State_Clause;
22037 ---------------------------
22038 -- Is_Null_Refined_State --
22039 ---------------------------
22041 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
22042 Item_Id : Entity_Id;
22045 if Is_Entity_Name (Item) then
22047 -- Handle abstract views generated for limited with clauses
22049 Item_Id := Available_View (Entity_Of (Item));
22051 return Ekind (Item_Id) = E_Abstract_State
22052 and then Has_Null_Refinement (Item_Id);
22057 end Is_Null_Refined_State;
22063 procedure Match_Items
22064 (Dep_Item : Node_Id;
22065 Ref_Item : Node_Id;
22066 Matched : out Boolean)
22068 Dep_Item_Id : Entity_Id;
22069 Ref_Item_Id : Entity_Id;
22072 -- Assume that the two items do not match
22076 -- A null matches null or Empty (special case)
22078 if Nkind (Dep_Item) = N_Null
22079 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
22083 -- Attribute 'Result matches attribute 'Result
22085 elsif Is_Attribute_Result (Dep_Item)
22086 and then Is_Attribute_Result (Dep_Item)
22090 -- Abstract states, formal parameters and variables
22092 elsif Is_Entity_Name (Dep_Item) then
22094 -- Handle abstract views generated for limited with clauses
22096 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
22098 if Ekind (Dep_Item_Id) = E_Abstract_State then
22100 -- An abstract state with visible null refinement matches
22101 -- null or Empty (special case).
22103 if Has_Null_Refinement (Dep_Item_Id)
22104 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
22106 Record_Item (Dep_Item_Id);
22109 -- An abstract state with visible non-null refinement
22110 -- matches one of its constituents.
22112 elsif Has_Non_Null_Refinement (Dep_Item_Id) then
22113 if Is_Entity_Name (Ref_Item) then
22114 Ref_Item_Id := Entity_Of (Ref_Item);
22116 if Ekind_In (Ref_Item_Id, E_Abstract_State, E_Variable)
22117 and then Present (Encapsulating_State (Ref_Item_Id))
22118 and then Encapsulating_State (Ref_Item_Id) =
22121 Record_Item (Dep_Item_Id);
22126 -- An abstract state without a visible refinement matches
22129 elsif Is_Entity_Name (Ref_Item)
22130 and then Entity_Of (Ref_Item) = Dep_Item_Id
22132 Record_Item (Dep_Item_Id);
22136 -- A formal parameter or a variable matches itself
22138 elsif Is_Entity_Name (Ref_Item)
22139 and then Entity_Of (Ref_Item) = Dep_Item_Id
22141 Record_Item (Dep_Item_Id);
22151 procedure Record_Item (Item_Id : Entity_Id) is
22153 if not Contains (Matched_Items, Item_Id) then
22154 Add_Item (Item_Id, Matched_Items);
22160 Clause_Matched : Boolean := False;
22161 Dummy : Boolean := False;
22162 Inputs_Match : Boolean;
22163 Next_Ref_Clause : Node_Id;
22164 Outputs_Match : Boolean;
22165 Ref_Clause : Node_Id;
22166 Ref_Input : Node_Id;
22167 Ref_Output : Node_Id;
22169 -- Start of processing for Check_Dependency_Clause
22172 -- Examine all refinement clauses and compare them against the
22173 -- dependence clause.
22175 Ref_Clause := First (Refinements);
22176 while Present (Ref_Clause) loop
22177 Next_Ref_Clause := Next (Ref_Clause);
22179 -- Obtain the attributes of the current refinement clause
22181 Ref_Input := Expression (Ref_Clause);
22182 Ref_Output := First (Choices (Ref_Clause));
22184 -- The current refinement clause matches the dependence clause
22185 -- when both outputs match and both inputs match. See routine
22186 -- Match_Items for all possible conformance scenarios.
22188 -- Depends Dep_Output => Dep_Input
22192 -- Refined_Depends Ref_Output => Ref_Input
22195 (Dep_Item => Dep_Input,
22196 Ref_Item => Ref_Input,
22197 Matched => Inputs_Match);
22200 (Dep_Item => Dep_Output,
22201 Ref_Item => Ref_Output,
22202 Matched => Outputs_Match);
22204 -- An In_Out state clause may be matched against a refinement with
22205 -- a null input or null output as long as the non-null side of the
22206 -- relation contains a valid constituent of the In_Out_State.
22208 if Is_In_Out_State_Clause then
22210 -- Depends => (State => State)
22211 -- Refined_Depends => (null => Constit) -- OK
22214 and then not Outputs_Match
22215 and then Nkind (Ref_Output) = N_Null
22217 Outputs_Match := True;
22220 -- Depends => (State => State)
22221 -- Refined_Depends => (Constit => null) -- OK
22223 if not Inputs_Match
22224 and then Outputs_Match
22225 and then Nkind (Ref_Input) = N_Null
22227 Inputs_Match := True;
22231 -- The current refinement clause is legally constructed following
22232 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22233 -- the pool of candidates. The seach continues because a single
22234 -- dependence clause may have multiple matching refinements.
22236 if Inputs_Match and then Outputs_Match then
22237 Clause_Matched := True;
22238 Remove (Ref_Clause);
22241 Ref_Clause := Next_Ref_Clause;
22244 -- Depending on the order or composition of refinement clauses, an
22245 -- In_Out state clause may not be directly refinable.
22247 -- Depends => ((Output, State) => (Input, State))
22248 -- Refined_State => (State => (Constit_1, Constit_2))
22249 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22251 -- Matching normalized clause (State => State) fails because there is
22252 -- no direct refinement capable of satisfying this relation. Another
22253 -- similar case arises when clauses (Constit_1 => Input) and (Output
22254 -- => Constit_2) are matched first, leaving no candidates for clause
22255 -- (State => State). Both scenarios are legal as long as one of the
22256 -- previous clauses mentioned a valid constituent of State.
22258 if not Clause_Matched
22259 and then Is_In_Out_State_Clause
22261 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
22263 Clause_Matched := True;
22266 -- A clause where the input is an abstract state with visible null
22267 -- refinement is implicitly matched when the output has already been
22268 -- matched in a previous clause.
22270 -- Depends => (Output => State) -- implicitly OK
22271 -- Refined_State => (State => null)
22272 -- Refined_Depends => (Output => ...)
22274 if not Clause_Matched
22275 and then Is_Null_Refined_State (Dep_Input)
22276 and then Is_Entity_Name (Dep_Output)
22278 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
22280 Clause_Matched := True;
22283 -- A clause where the output is an abstract state with visible null
22284 -- refinement is implicitly matched when the input has already been
22285 -- matched in a previous clause.
22287 -- Depends => (State => Input) -- implicitly OK
22288 -- Refined_State => (State => null)
22289 -- Refined_Depends => (... => Input)
22291 if not Clause_Matched
22292 and then Is_Null_Refined_State (Dep_Output)
22293 and then Is_Entity_Name (Dep_Input)
22295 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
22297 Clause_Matched := True;
22300 -- At this point either all refinement clauses have been examined or
22301 -- pragma Refined_Depends contains a solitary null. Only an abstract
22302 -- state with null refinement can possibly match these cases.
22304 -- Depends => (State => null)
22305 -- Refined_State => (State => null)
22306 -- Refined_Depends => null -- OK
22308 if not Clause_Matched then
22310 (Dep_Item => Dep_Input,
22312 Matched => Inputs_Match);
22315 (Dep_Item => Dep_Output,
22317 Matched => Outputs_Match);
22319 Clause_Matched := Inputs_Match and Outputs_Match;
22322 -- If the contents of Refined_Depends are legal, then the current
22323 -- dependence clause should be satisfied either by an explicit match
22324 -- or by one of the special cases.
22326 if not Clause_Matched then
22328 ("dependence clause of subprogram & has no matching refinement "
22329 & "in body", Dep_Clause, Spec_Id);
22331 end Check_Dependency_Clause;
22333 -----------------------
22334 -- Normalize_Clauses --
22335 -----------------------
22337 procedure Normalize_Clauses (Clauses : List_Id) is
22338 procedure Normalize_Inputs (Clause : Node_Id);
22339 -- Normalize clause Clause by creating multiple clauses for each
22340 -- input item of Clause. It is assumed that Clause has exactly one
22341 -- output. The transformation is as follows:
22343 -- Output => (Input_1, Input_2) -- original
22345 -- Output => Input_1 -- normalizations
22346 -- Output => Input_2
22348 ----------------------
22349 -- Normalize_Inputs --
22350 ----------------------
22352 procedure Normalize_Inputs (Clause : Node_Id) is
22353 Inputs : constant Node_Id := Expression (Clause);
22354 Loc : constant Source_Ptr := Sloc (Clause);
22355 Output : constant List_Id := Choices (Clause);
22356 Last_Input : Node_Id;
22358 New_Clause : Node_Id;
22359 Next_Input : Node_Id;
22362 -- Normalization is performed only when the original clause has
22363 -- more than one input. Multiple inputs appear as an aggregate.
22365 if Nkind (Inputs) = N_Aggregate then
22366 Last_Input := Last (Expressions (Inputs));
22368 -- Create a new clause for each input
22370 Input := First (Expressions (Inputs));
22371 while Present (Input) loop
22372 Next_Input := Next (Input);
22374 -- Unhook the current input from the original input list
22375 -- because it will be relocated to a new clause.
22379 -- Special processing for the last input. At this point the
22380 -- original aggregate has been stripped down to one element.
22381 -- Replace the aggregate by the element itself.
22383 if Input = Last_Input then
22384 Rewrite (Inputs, Input);
22386 -- Generate a clause of the form:
22391 Make_Component_Association (Loc,
22392 Choices => New_Copy_List_Tree (Output),
22393 Expression => Input);
22395 -- The new clause contains replicated content that has
22396 -- already been analyzed, mark the clause as analyzed.
22398 Set_Analyzed (New_Clause);
22399 Insert_After (Clause, New_Clause);
22402 Input := Next_Input;
22405 end Normalize_Inputs;
22411 -- Start of processing for Normalize_Clauses
22414 Clause := First (Clauses);
22415 while Present (Clause) loop
22416 Normalize_Inputs (Clause);
22419 end Normalize_Clauses;
22421 --------------------------
22422 -- Report_Extra_Clauses --
22423 --------------------------
22425 procedure Report_Extra_Clauses is
22429 if Present (Refinements) then
22430 Clause := First (Refinements);
22431 while Present (Clause) loop
22433 -- Do not complain about a null input refinement, since a null
22434 -- input legitimately matches anything.
22436 if Nkind (Clause) /= N_Component_Association
22437 or else Nkind (Expression (Clause)) /= N_Null
22440 ("unmatched or extra clause in dependence refinement",
22447 end Report_Extra_Clauses;
22451 Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
22452 Errors : constant Nat := Serious_Errors_Detected;
22453 Refs : constant Node_Id :=
22454 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
22458 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22461 if Nkind (Body_Decl) = N_Subprogram_Body_Stub then
22462 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
22464 Spec_Id := Corresponding_Spec (Body_Decl);
22467 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
22469 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22470 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22472 if No (Depends) then
22474 ("useless refinement, declaration of subprogram & lacks aspect or "
22475 & "pragma Depends", N, Spec_Id);
22479 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends)));
22481 -- A null dependency relation renders the refinement useless because it
22482 -- cannot possibly mention abstract states with visible refinement. Note
22483 -- that the inverse is not true as states may be refined to null
22484 -- (SPARK RM 7.2.5(2)).
22486 if Nkind (Deps) = N_Null then
22488 ("useless refinement, subprogram & does not depend on abstract "
22489 & "state with visible refinement", N, Spec_Id);
22493 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22494 -- This ensures that the categorization of all refined dependency items
22495 -- is consistent with their role.
22497 Analyze_Depends_In_Decl_Part (N);
22499 -- Do not match dependencies against refinements if Refined_Depends is
22500 -- illegal to avoid emitting misleading error.
22502 if Serious_Errors_Detected = Errors then
22504 -- Multiple dependency clauses appear as component associations of an
22505 -- aggregate. Note that the clauses are copied because the algorithm
22506 -- modifies them and this should not be visible in Depends.
22508 pragma Assert (Nkind (Deps) = N_Aggregate);
22509 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
22510 Normalize_Clauses (Dependencies);
22512 if Nkind (Refs) = N_Null then
22513 Refinements := No_List;
22515 -- Multiple dependency clauses appear as component associations of an
22516 -- aggregate. Note that the clauses are copied because the algorithm
22517 -- modifies them and this should not be visible in Refined_Depends.
22519 else pragma Assert (Nkind (Refs) = N_Aggregate);
22520 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
22521 Normalize_Clauses (Refinements);
22524 -- At this point the clauses of pragmas Depends and Refined_Depends
22525 -- have been normalized into simple dependencies between one output
22526 -- and one input. Examine all clauses of pragma Depends looking for
22527 -- matching clauses in pragma Refined_Depends.
22529 Clause := First (Dependencies);
22530 while Present (Clause) loop
22531 Check_Dependency_Clause (Clause);
22535 if Serious_Errors_Detected = Errors then
22536 Report_Extra_Clauses;
22539 end Analyze_Refined_Depends_In_Decl_Part;
22541 -----------------------------------------
22542 -- Analyze_Refined_Global_In_Decl_Part --
22543 -----------------------------------------
22545 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
22547 -- The corresponding Global pragma
22549 Has_In_State : Boolean := False;
22550 Has_In_Out_State : Boolean := False;
22551 Has_Out_State : Boolean := False;
22552 Has_Proof_In_State : Boolean := False;
22553 -- These flags are set when the corresponding Global pragma has a state
22554 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22557 Has_Null_State : Boolean := False;
22558 -- This flag is set when the corresponding Global pragma has at least
22559 -- one state with a null refinement.
22561 In_Constits : Elist_Id := No_Elist;
22562 In_Out_Constits : Elist_Id := No_Elist;
22563 Out_Constits : Elist_Id := No_Elist;
22564 Proof_In_Constits : Elist_Id := No_Elist;
22565 -- These lists contain the entities of all Input, In_Out, Output and
22566 -- Proof_In constituents that appear in Refined_Global and participate
22567 -- in state refinement.
22569 In_Items : Elist_Id := No_Elist;
22570 In_Out_Items : Elist_Id := No_Elist;
22571 Out_Items : Elist_Id := No_Elist;
22572 Proof_In_Items : Elist_Id := No_Elist;
22573 -- These list contain the entities of all Input, In_Out, Output and
22574 -- Proof_In items defined in the corresponding Global pragma.
22576 procedure Check_In_Out_States;
22577 -- Determine whether the corresponding Global pragma mentions In_Out
22578 -- states with visible refinement and if so, ensure that one of the
22579 -- following completions apply to the constituents of the state:
22580 -- 1) there is at least one constituent of mode In_Out
22581 -- 2) there is at least one Input and one Output constituent
22582 -- 3) not all constituents are present and one of them is of mode
22584 -- This routine may remove elements from In_Constits, In_Out_Constits,
22585 -- Out_Constits and Proof_In_Constits.
22587 procedure Check_Input_States;
22588 -- Determine whether the corresponding Global pragma mentions Input
22589 -- states with visible refinement and if so, ensure that at least one of
22590 -- its constituents appears as an Input item in Refined_Global.
22591 -- This routine may remove elements from In_Constits, In_Out_Constits,
22592 -- Out_Constits and Proof_In_Constits.
22594 procedure Check_Output_States;
22595 -- Determine whether the corresponding Global pragma mentions Output
22596 -- states with visible refinement and if so, ensure that all of its
22597 -- constituents appear as Output items in Refined_Global.
22598 -- This routine may remove elements from In_Constits, In_Out_Constits,
22599 -- Out_Constits and Proof_In_Constits.
22601 procedure Check_Proof_In_States;
22602 -- Determine whether the corresponding Global pragma mentions Proof_In
22603 -- states with visible refinement and if so, ensure that at least one of
22604 -- its constituents appears as a Proof_In item in Refined_Global.
22605 -- This routine may remove elements from In_Constits, In_Out_Constits,
22606 -- Out_Constits and Proof_In_Constits.
22608 procedure Check_Refined_Global_List
22610 Global_Mode : Name_Id := Name_Input);
22611 -- Verify the legality of a single global list declaration. Global_Mode
22612 -- denotes the current mode in effect.
22614 function Present_Then_Remove
22616 Item : Entity_Id) return Boolean;
22617 -- Search List for a particular entity Item. If Item has been found,
22618 -- remove it from List. This routine is used to strip lists In_Constits,
22619 -- In_Out_Constits and Out_Constits of valid constituents.
22621 procedure Report_Extra_Constituents;
22622 -- Emit an error for each constituent found in lists In_Constits,
22623 -- In_Out_Constits and Out_Constits.
22625 -------------------------
22626 -- Check_In_Out_States --
22627 -------------------------
22629 procedure Check_In_Out_States is
22630 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22631 -- Determine whether one of the following coverage scenarios is in
22633 -- 1) there is at least one constituent of mode In_Out
22634 -- 2) there is at least one Input and one Output constituent
22635 -- 3) not all constituents are present and one of them is of mode
22637 -- If this is not the case, emit an error.
22639 -----------------------------
22640 -- Check_Constituent_Usage --
22641 -----------------------------
22643 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22644 Constit_Elmt : Elmt_Id;
22645 Constit_Id : Entity_Id;
22646 Has_Missing : Boolean := False;
22647 In_Out_Seen : Boolean := False;
22648 In_Seen : Boolean := False;
22649 Out_Seen : Boolean := False;
22652 -- Process all the constituents of the state and note their modes
22653 -- within the global refinement.
22655 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22656 while Present (Constit_Elmt) loop
22657 Constit_Id := Node (Constit_Elmt);
22659 if Present_Then_Remove (In_Constits, Constit_Id) then
22662 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
22663 In_Out_Seen := True;
22665 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
22668 -- A Proof_In constituent cannot participate in the completion
22669 -- of an Output state (SPARK RM 7.2.4(5)).
22671 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then
22672 Error_Msg_Name_1 := Chars (State_Id);
22674 ("constituent & of state % must have mode Input, In_Out "
22675 & "or Output in global refinement",
22679 Has_Missing := True;
22682 Next_Elmt (Constit_Elmt);
22685 -- A single In_Out constituent is a valid completion
22687 if In_Out_Seen then
22690 -- A pair of one Input and one Output constituent is a valid
22693 elsif In_Seen and then Out_Seen then
22696 -- A single Output constituent is a valid completion only when
22697 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22699 elsif Has_Missing and then Out_Seen then
22704 ("global refinement of state & redefines the mode of its "
22705 & "constituents", N, State_Id);
22707 end Check_Constituent_Usage;
22711 Item_Elmt : Elmt_Id;
22712 Item_Id : Entity_Id;
22714 -- Start of processing for Check_In_Out_States
22717 -- Inspect the In_Out items of the corresponding Global pragma
22718 -- looking for a state with a visible refinement.
22720 if Has_In_Out_State and then Present (In_Out_Items) then
22721 Item_Elmt := First_Elmt (In_Out_Items);
22722 while Present (Item_Elmt) loop
22723 Item_Id := Node (Item_Elmt);
22725 -- Ensure that one of the three coverage variants is satisfied
22727 if Ekind (Item_Id) = E_Abstract_State
22728 and then Has_Non_Null_Refinement (Item_Id)
22730 Check_Constituent_Usage (Item_Id);
22733 Next_Elmt (Item_Elmt);
22736 end Check_In_Out_States;
22738 ------------------------
22739 -- Check_Input_States --
22740 ------------------------
22742 procedure Check_Input_States is
22743 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22744 -- Determine whether at least one constituent of state State_Id with
22745 -- visible refinement is used and has mode Input. Ensure that the
22746 -- remaining constituents do not have In_Out, Output or Proof_In
22749 -----------------------------
22750 -- Check_Constituent_Usage --
22751 -----------------------------
22753 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22754 Constit_Elmt : Elmt_Id;
22755 Constit_Id : Entity_Id;
22756 In_Seen : Boolean := False;
22759 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22760 while Present (Constit_Elmt) loop
22761 Constit_Id := Node (Constit_Elmt);
22763 -- At least one of the constituents appears as an Input
22765 if Present_Then_Remove (In_Constits, Constit_Id) then
22768 -- The constituent appears in the global refinement, but has
22769 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22771 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
22772 or else Present_Then_Remove (Out_Constits, Constit_Id)
22773 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
22775 Error_Msg_Name_1 := Chars (State_Id);
22777 ("constituent & of state % must have mode Input in global "
22778 & "refinement", N, Constit_Id);
22781 Next_Elmt (Constit_Elmt);
22784 -- Not one of the constituents appeared as Input
22786 if not In_Seen then
22788 ("global refinement of state & must include at least one "
22789 & "constituent of mode Input", N, State_Id);
22791 end Check_Constituent_Usage;
22795 Item_Elmt : Elmt_Id;
22796 Item_Id : Entity_Id;
22798 -- Start of processing for Check_Input_States
22801 -- Inspect the Input items of the corresponding Global pragma
22802 -- looking for a state with a visible refinement.
22804 if Has_In_State and then Present (In_Items) then
22805 Item_Elmt := First_Elmt (In_Items);
22806 while Present (Item_Elmt) loop
22807 Item_Id := Node (Item_Elmt);
22809 -- Ensure that at least one of the constituents is utilized and
22810 -- is of mode Input.
22812 if Ekind (Item_Id) = E_Abstract_State
22813 and then Has_Non_Null_Refinement (Item_Id)
22815 Check_Constituent_Usage (Item_Id);
22818 Next_Elmt (Item_Elmt);
22821 end Check_Input_States;
22823 -------------------------
22824 -- Check_Output_States --
22825 -------------------------
22827 procedure Check_Output_States is
22828 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22829 -- Determine whether all constituents of state State_Id with visible
22830 -- refinement are used and have mode Output. Emit an error if this is
22833 -----------------------------
22834 -- Check_Constituent_Usage --
22835 -----------------------------
22837 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22838 Constit_Elmt : Elmt_Id;
22839 Constit_Id : Entity_Id;
22840 Posted : Boolean := False;
22843 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22844 while Present (Constit_Elmt) loop
22845 Constit_Id := Node (Constit_Elmt);
22847 if Present_Then_Remove (Out_Constits, Constit_Id) then
22850 -- The constituent appears in the global refinement, but has
22851 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22853 elsif Present_Then_Remove (In_Constits, Constit_Id)
22854 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
22855 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
22857 Error_Msg_Name_1 := Chars (State_Id);
22859 ("constituent & of state % must have mode Output in "
22860 & "global refinement", N, Constit_Id);
22862 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22868 ("output state & must be replaced by all its "
22869 & "constituents in global refinement", N, State_Id);
22873 ("\constituent & is missing in output list",
22877 Next_Elmt (Constit_Elmt);
22879 end Check_Constituent_Usage;
22883 Item_Elmt : Elmt_Id;
22884 Item_Id : Entity_Id;
22886 -- Start of processing for Check_Output_States
22889 -- Inspect the Output items of the corresponding Global pragma
22890 -- looking for a state with a visible refinement.
22892 if Has_Out_State and then Present (Out_Items) then
22893 Item_Elmt := First_Elmt (Out_Items);
22894 while Present (Item_Elmt) loop
22895 Item_Id := Node (Item_Elmt);
22897 -- Ensure that all of the constituents are utilized and they
22898 -- have mode Output.
22900 if Ekind (Item_Id) = E_Abstract_State
22901 and then Has_Non_Null_Refinement (Item_Id)
22903 Check_Constituent_Usage (Item_Id);
22906 Next_Elmt (Item_Elmt);
22909 end Check_Output_States;
22911 ---------------------------
22912 -- Check_Proof_In_States --
22913 ---------------------------
22915 procedure Check_Proof_In_States is
22916 procedure Check_Constituent_Usage (State_Id : Entity_Id);
22917 -- Determine whether at least one constituent of state State_Id with
22918 -- visible refinement is used and has mode Proof_In. Ensure that the
22919 -- remaining constituents do not have Input, In_Out or Output modes.
22921 -----------------------------
22922 -- Check_Constituent_Usage --
22923 -----------------------------
22925 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
22926 Constit_Elmt : Elmt_Id;
22927 Constit_Id : Entity_Id;
22928 Proof_In_Seen : Boolean := False;
22931 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
22932 while Present (Constit_Elmt) loop
22933 Constit_Id := Node (Constit_Elmt);
22935 -- At least one of the constituents appears as Proof_In
22937 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
22938 Proof_In_Seen := True;
22940 -- The constituent appears in the global refinement, but has
22941 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
22943 elsif Present_Then_Remove (In_Constits, Constit_Id)
22944 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
22945 or else Present_Then_Remove (Out_Constits, Constit_Id)
22947 Error_Msg_Name_1 := Chars (State_Id);
22949 ("constituent & of state % must have mode Proof_In in "
22950 & "global refinement", N, Constit_Id);
22953 Next_Elmt (Constit_Elmt);
22956 -- Not one of the constituents appeared as Proof_In
22958 if not Proof_In_Seen then
22960 ("global refinement of state & must include at least one "
22961 & "constituent of mode Proof_In", N, State_Id);
22963 end Check_Constituent_Usage;
22967 Item_Elmt : Elmt_Id;
22968 Item_Id : Entity_Id;
22970 -- Start of processing for Check_Proof_In_States
22973 -- Inspect the Proof_In items of the corresponding Global pragma
22974 -- looking for a state with a visible refinement.
22976 if Has_Proof_In_State and then Present (Proof_In_Items) then
22977 Item_Elmt := First_Elmt (Proof_In_Items);
22978 while Present (Item_Elmt) loop
22979 Item_Id := Node (Item_Elmt);
22981 -- Ensure that at least one of the constituents is utilized and
22982 -- is of mode Proof_In
22984 if Ekind (Item_Id) = E_Abstract_State
22985 and then Has_Non_Null_Refinement (Item_Id)
22987 Check_Constituent_Usage (Item_Id);
22990 Next_Elmt (Item_Elmt);
22993 end Check_Proof_In_States;
22995 -------------------------------
22996 -- Check_Refined_Global_List --
22997 -------------------------------
22999 procedure Check_Refined_Global_List
23001 Global_Mode : Name_Id := Name_Input)
23003 procedure Check_Refined_Global_Item
23005 Global_Mode : Name_Id);
23006 -- Verify the legality of a single global item declaration. Parameter
23007 -- Global_Mode denotes the current mode in effect.
23009 -------------------------------
23010 -- Check_Refined_Global_Item --
23011 -------------------------------
23013 procedure Check_Refined_Global_Item
23015 Global_Mode : Name_Id)
23017 Item_Id : constant Entity_Id := Entity_Of (Item);
23019 procedure Inconsistent_Mode_Error (Expect : Name_Id);
23020 -- Issue a common error message for all mode mismatches. Expect
23021 -- denotes the expected mode.
23023 -----------------------------
23024 -- Inconsistent_Mode_Error --
23025 -----------------------------
23027 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
23030 ("global item & has inconsistent modes", Item, Item_Id);
23032 Error_Msg_Name_1 := Global_Mode;
23033 Error_Msg_Name_2 := Expect;
23034 SPARK_Msg_N ("\expected mode %, found mode %", Item);
23035 end Inconsistent_Mode_Error;
23037 -- Start of processing for Check_Refined_Global_Item
23040 -- When the state or variable acts as a constituent of another
23041 -- state with a visible refinement, collect it for the state
23042 -- completeness checks performed later on.
23044 if Present (Encapsulating_State (Item_Id))
23045 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
23047 if Global_Mode = Name_Input then
23048 Add_Item (Item_Id, In_Constits);
23050 elsif Global_Mode = Name_In_Out then
23051 Add_Item (Item_Id, In_Out_Constits);
23053 elsif Global_Mode = Name_Output then
23054 Add_Item (Item_Id, Out_Constits);
23056 elsif Global_Mode = Name_Proof_In then
23057 Add_Item (Item_Id, Proof_In_Constits);
23060 -- When not a constituent, ensure that both occurrences of the
23061 -- item in pragmas Global and Refined_Global match.
23063 elsif Contains (In_Items, Item_Id) then
23064 if Global_Mode /= Name_Input then
23065 Inconsistent_Mode_Error (Name_Input);
23068 elsif Contains (In_Out_Items, Item_Id) then
23069 if Global_Mode /= Name_In_Out then
23070 Inconsistent_Mode_Error (Name_In_Out);
23073 elsif Contains (Out_Items, Item_Id) then
23074 if Global_Mode /= Name_Output then
23075 Inconsistent_Mode_Error (Name_Output);
23078 elsif Contains (Proof_In_Items, Item_Id) then
23081 -- The item does not appear in the corresponding Global pragma,
23082 -- it must be an extra (SPARK RM 7.2.4(3)).
23085 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
23087 end Check_Refined_Global_Item;
23093 -- Start of processing for Check_Refined_Global_List
23096 if Nkind (List) = N_Null then
23099 -- Single global item declaration
23101 elsif Nkind_In (List, N_Expanded_Name,
23103 N_Selected_Component)
23105 Check_Refined_Global_Item (List, Global_Mode);
23107 -- Simple global list or moded global list declaration
23109 elsif Nkind (List) = N_Aggregate then
23111 -- The declaration of a simple global list appear as a collection
23114 if Present (Expressions (List)) then
23115 Item := First (Expressions (List));
23116 while Present (Item) loop
23117 Check_Refined_Global_Item (Item, Global_Mode);
23122 -- The declaration of a moded global list appears as a collection
23123 -- of component associations where individual choices denote
23126 elsif Present (Component_Associations (List)) then
23127 Item := First (Component_Associations (List));
23128 while Present (Item) loop
23129 Check_Refined_Global_List
23130 (List => Expression (Item),
23131 Global_Mode => Chars (First (Choices (Item))));
23139 raise Program_Error;
23145 raise Program_Error;
23147 end Check_Refined_Global_List;
23149 -------------------------
23150 -- Present_Then_Remove --
23151 -------------------------
23153 function Present_Then_Remove
23155 Item : Entity_Id) return Boolean
23160 if Present (List) then
23161 Elmt := First_Elmt (List);
23162 while Present (Elmt) loop
23163 if Node (Elmt) = Item then
23164 Remove_Elmt (List, Elmt);
23173 end Present_Then_Remove;
23175 -------------------------------
23176 -- Report_Extra_Constituents --
23177 -------------------------------
23179 procedure Report_Extra_Constituents is
23180 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
23181 -- Emit an error for every element of List
23183 ---------------------------------------
23184 -- Report_Extra_Constituents_In_List --
23185 ---------------------------------------
23187 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
23188 Constit_Elmt : Elmt_Id;
23191 if Present (List) then
23192 Constit_Elmt := First_Elmt (List);
23193 while Present (Constit_Elmt) loop
23194 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
23195 Next_Elmt (Constit_Elmt);
23198 end Report_Extra_Constituents_In_List;
23200 -- Start of processing for Report_Extra_Constituents
23203 Report_Extra_Constituents_In_List (In_Constits);
23204 Report_Extra_Constituents_In_List (In_Out_Constits);
23205 Report_Extra_Constituents_In_List (Out_Constits);
23206 Report_Extra_Constituents_In_List (Proof_In_Constits);
23207 end Report_Extra_Constituents;
23211 Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
23212 Errors : constant Nat := Serious_Errors_Detected;
23213 Items : constant Node_Id :=
23214 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
23215 Spec_Id : Entity_Id;
23217 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23220 if Nkind (Body_Decl) = N_Subprogram_Body_Stub then
23221 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
23223 Spec_Id := Corresponding_Spec (Body_Decl);
23226 Global := Get_Pragma (Spec_Id, Pragma_Global);
23228 -- The subprogram declaration lacks pragma Global. This renders
23229 -- Refined_Global useless as there is nothing to refine.
23231 if No (Global) then
23233 ("useless refinement, declaration of subprogram & lacks aspect or "
23234 & "pragma Global", N, Spec_Id);
23238 -- Extract all relevant items from the corresponding Global pragma
23240 Collect_Global_Items
23242 In_Items => In_Items,
23243 In_Out_Items => In_Out_Items,
23244 Out_Items => Out_Items,
23245 Proof_In_Items => Proof_In_Items,
23246 Has_In_State => Has_In_State,
23247 Has_In_Out_State => Has_In_Out_State,
23248 Has_Out_State => Has_Out_State,
23249 Has_Proof_In_State => Has_Proof_In_State,
23250 Has_Null_State => Has_Null_State);
23252 -- Corresponding Global pragma must mention at least one state witha
23253 -- visible refinement at the point Refined_Global is processed. States
23254 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23256 if not Has_In_State
23257 and then not Has_In_Out_State
23258 and then not Has_Out_State
23259 and then not Has_Proof_In_State
23260 and then not Has_Null_State
23263 ("useless refinement, subprogram & does not depend on abstract "
23264 & "state with visible refinement", N, Spec_Id);
23268 -- The global refinement of inputs and outputs cannot be null when the
23269 -- corresponding Global pragma contains at least one item except in the
23270 -- case where we have states with null refinements.
23272 if Nkind (Items) = N_Null
23274 (Present (In_Items)
23275 or else Present (In_Out_Items)
23276 or else Present (Out_Items)
23277 or else Present (Proof_In_Items))
23278 and then not Has_Null_State
23281 ("refinement cannot be null, subprogram & has global items",
23286 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23287 -- This ensures that the categorization of all refined global items is
23288 -- consistent with their role.
23290 Analyze_Global_In_Decl_Part (N);
23292 -- Perform all refinement checks with respect to completeness and mode
23295 if Serious_Errors_Detected = Errors then
23296 Check_Refined_Global_List (Items);
23299 -- For Input states with visible refinement, at least one constituent
23300 -- must be used as an Input in the global refinement.
23302 if Serious_Errors_Detected = Errors then
23303 Check_Input_States;
23306 -- Verify all possible completion variants for In_Out states with
23307 -- visible refinement.
23309 if Serious_Errors_Detected = Errors then
23310 Check_In_Out_States;
23313 -- For Output states with visible refinement, all constituents must be
23314 -- used as Outputs in the global refinement.
23316 if Serious_Errors_Detected = Errors then
23317 Check_Output_States;
23320 -- For Proof_In states with visible refinement, at least one constituent
23321 -- must be used as Proof_In in the global refinement.
23323 if Serious_Errors_Detected = Errors then
23324 Check_Proof_In_States;
23327 -- Emit errors for all constituents that belong to other states with
23328 -- visible refinement that do not appear in Global.
23330 if Serious_Errors_Detected = Errors then
23331 Report_Extra_Constituents;
23333 end Analyze_Refined_Global_In_Decl_Part;
23335 ----------------------------------------
23336 -- Analyze_Refined_State_In_Decl_Part --
23337 ----------------------------------------
23339 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is
23340 Available_States : Elist_Id := No_Elist;
23341 -- A list of all abstract states defined in the package declaration that
23342 -- are available for refinement. The list is used to report unrefined
23345 Body_Id : Entity_Id;
23346 -- The body entity of the package subject to pragma Refined_State
23348 Body_States : Elist_Id := No_Elist;
23349 -- A list of all hidden states that appear in the body of the related
23350 -- package. The list is used to report unused hidden states.
23352 Constituents_Seen : Elist_Id := No_Elist;
23353 -- A list that contains all constituents processed so far. The list is
23354 -- used to detect multiple uses of the same constituent.
23356 Refined_States_Seen : Elist_Id := No_Elist;
23357 -- A list that contains all refined states processed so far. The list is
23358 -- used to detect duplicate refinements.
23360 Spec_Id : Entity_Id;
23361 -- The spec entity of the package subject to pragma Refined_State
23363 procedure Analyze_Refinement_Clause (Clause : Node_Id);
23364 -- Perform full analysis of a single refinement clause
23366 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id;
23367 -- Gather the entities of all abstract states and variables declared in
23368 -- the body state space of package Pack_Id.
23370 procedure Report_Unrefined_States (States : Elist_Id);
23371 -- Emit errors for all unrefined abstract states found in list States
23373 procedure Report_Unused_States (States : Elist_Id);
23374 -- Emit errors for all unused states found in list States
23376 -------------------------------
23377 -- Analyze_Refinement_Clause --
23378 -------------------------------
23380 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
23381 AR_Constit : Entity_Id := Empty;
23382 AW_Constit : Entity_Id := Empty;
23383 ER_Constit : Entity_Id := Empty;
23384 EW_Constit : Entity_Id := Empty;
23385 -- The entities of external constituents that contain one of the
23386 -- following enabled properties: Async_Readers, Async_Writers,
23387 -- Effective_Reads and Effective_Writes.
23389 External_Constit_Seen : Boolean := False;
23390 -- Flag used to mark when at least one external constituent is part
23391 -- of the state refinement.
23393 Non_Null_Seen : Boolean := False;
23394 Null_Seen : Boolean := False;
23395 -- Flags used to detect multiple uses of null in a single clause or a
23396 -- mixture of null and non-null constituents.
23398 Part_Of_Constits : Elist_Id := No_Elist;
23399 -- A list of all candidate constituents subject to indicator Part_Of
23400 -- where the encapsulating state is the current state.
23403 State_Id : Entity_Id;
23404 -- The current state being refined
23406 procedure Analyze_Constituent (Constit : Node_Id);
23407 -- Perform full analysis of a single constituent
23409 procedure Check_External_Property
23410 (Prop_Nam : Name_Id;
23412 Constit : Entity_Id);
23413 -- Determine whether a property denoted by name Prop_Nam is present
23414 -- in both the refined state and constituent Constit. Flag Enabled
23415 -- should be set when the property applies to the refined state. If
23416 -- this is not the case, emit an error message.
23418 procedure Check_Matching_State;
23419 -- Determine whether the state being refined appears in list
23420 -- Available_States. Emit an error when attempting to re-refine the
23421 -- state or when the state is not defined in the package declaration,
23422 -- otherwise remove the state from Available_States.
23424 procedure Report_Unused_Constituents (Constits : Elist_Id);
23425 -- Emit errors for all unused Part_Of constituents in list Constits
23427 -------------------------
23428 -- Analyze_Constituent --
23429 -------------------------
23431 procedure Analyze_Constituent (Constit : Node_Id) is
23432 procedure Check_Matching_Constituent (Constit_Id : Entity_Id);
23433 -- Determine whether constituent Constit denoted by its entity
23434 -- Constit_Id appears in Hidden_States. Emit an error when the
23435 -- constituent is not a valid hidden state of the related package
23436 -- or when it is used more than once. Otherwise remove the
23437 -- constituent from Hidden_States.
23439 --------------------------------
23440 -- Check_Matching_Constituent --
23441 --------------------------------
23443 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is
23444 procedure Collect_Constituent;
23445 -- Add constituent Constit_Id to the refinements of State_Id
23447 -------------------------
23448 -- Collect_Constituent --
23449 -------------------------
23451 procedure Collect_Constituent is
23453 -- Add the constituent to the list of processed items to aid
23454 -- with the detection of duplicates.
23456 Add_Item (Constit_Id, Constituents_Seen);
23458 -- Collect the constituent in the list of refinement items
23459 -- and establish a relation between the refined state and
23462 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
23463 Set_Encapsulating_State (Constit_Id, State_Id);
23465 -- The state has at least one legal constituent, mark the
23466 -- start of the refinement region. The region ends when the
23467 -- body declarations end (see routine Analyze_Declarations).
23469 Set_Has_Visible_Refinement (State_Id);
23471 -- When the constituent is external, save its relevant
23472 -- property for further checks.
23474 if Async_Readers_Enabled (Constit_Id) then
23475 AR_Constit := Constit_Id;
23476 External_Constit_Seen := True;
23479 if Async_Writers_Enabled (Constit_Id) then
23480 AW_Constit := Constit_Id;
23481 External_Constit_Seen := True;
23484 if Effective_Reads_Enabled (Constit_Id) then
23485 ER_Constit := Constit_Id;
23486 External_Constit_Seen := True;
23489 if Effective_Writes_Enabled (Constit_Id) then
23490 EW_Constit := Constit_Id;
23491 External_Constit_Seen := True;
23493 end Collect_Constituent;
23497 State_Elmt : Elmt_Id;
23499 -- Start of processing for Check_Matching_Constituent
23502 -- Detect a duplicate use of a constituent
23504 if Contains (Constituents_Seen, Constit_Id) then
23506 ("duplicate use of constituent &", Constit, Constit_Id);
23510 -- The constituent is subject to a Part_Of indicator
23512 if Present (Encapsulating_State (Constit_Id)) then
23513 if Encapsulating_State (Constit_Id) = State_Id then
23514 Remove (Part_Of_Constits, Constit_Id);
23515 Collect_Constituent;
23517 -- The constituent is part of another state and is used
23518 -- incorrectly in the refinement of the current state.
23521 Error_Msg_Name_1 := Chars (State_Id);
23523 ("& cannot act as constituent of state %",
23524 Constit, Constit_Id);
23526 ("\Part_Of indicator specifies & as encapsulating "
23527 & "state", Constit, Encapsulating_State (Constit_Id));
23530 -- The only other source of legal constituents is the body
23531 -- state space of the related package.
23534 if Present (Body_States) then
23535 State_Elmt := First_Elmt (Body_States);
23536 while Present (State_Elmt) loop
23538 -- Consume a valid constituent to signal that it has
23539 -- been encountered.
23541 if Node (State_Elmt) = Constit_Id then
23542 Remove_Elmt (Body_States, State_Elmt);
23543 Collect_Constituent;
23547 Next_Elmt (State_Elmt);
23551 -- If we get here, then the constituent is not a hidden
23552 -- state of the related package and may not be used in a
23553 -- refinement (SPARK RM 7.2.2(9)).
23555 Error_Msg_Name_1 := Chars (Spec_Id);
23557 ("cannot use & in refinement, constituent is not a hidden "
23558 & "state of package %", Constit, Constit_Id);
23560 end Check_Matching_Constituent;
23564 Constit_Id : Entity_Id;
23566 -- Start of processing for Analyze_Constituent
23569 -- Detect multiple uses of null in a single refinement clause or a
23570 -- mixture of null and non-null constituents.
23572 if Nkind (Constit) = N_Null then
23575 ("multiple null constituents not allowed", Constit);
23577 elsif Non_Null_Seen then
23579 ("cannot mix null and non-null constituents", Constit);
23584 -- Collect the constituent in the list of refinement items
23586 Append_Elmt (Constit, Refinement_Constituents (State_Id));
23588 -- The state has at least one legal constituent, mark the
23589 -- start of the refinement region. The region ends when the
23590 -- body declarations end (see Analyze_Declarations).
23592 Set_Has_Visible_Refinement (State_Id);
23595 -- Non-null constituents
23598 Non_Null_Seen := True;
23602 ("cannot mix null and non-null constituents", Constit);
23606 Resolve_State (Constit);
23608 -- Ensure that the constituent denotes a valid state or a
23611 if Is_Entity_Name (Constit) then
23612 Constit_Id := Entity_Of (Constit);
23614 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then
23615 Check_Matching_Constituent (Constit_Id);
23619 ("constituent & must denote a variable or state (SPARK "
23620 & "RM 7.2.2(5))", Constit, Constit_Id);
23623 -- The constituent is illegal
23626 SPARK_Msg_N ("malformed constituent", Constit);
23629 end Analyze_Constituent;
23631 -----------------------------
23632 -- Check_External_Property --
23633 -----------------------------
23635 procedure Check_External_Property
23636 (Prop_Nam : Name_Id;
23638 Constit : Entity_Id)
23641 Error_Msg_Name_1 := Prop_Nam;
23643 -- The property is enabled in the related Abstract_State pragma
23644 -- that defines the state (SPARK RM 7.2.8(3)).
23647 if No (Constit) then
23649 ("external state & requires at least one constituent with "
23650 & "property %", State, State_Id);
23653 -- The property is missing in the declaration of the state, but
23654 -- a constituent is introducing it in the state refinement
23655 -- (SPARK RM 7.2.8(3)).
23657 elsif Present (Constit) then
23658 Error_Msg_Name_2 := Chars (Constit);
23660 ("external state & lacks property % set by constituent %",
23663 end Check_External_Property;
23665 --------------------------
23666 -- Check_Matching_State --
23667 --------------------------
23669 procedure Check_Matching_State is
23670 State_Elmt : Elmt_Id;
23673 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23675 if Contains (Refined_States_Seen, State_Id) then
23677 ("duplicate refinement of state &", State, State_Id);
23681 -- Inspect the abstract states defined in the package declaration
23682 -- looking for a match.
23684 State_Elmt := First_Elmt (Available_States);
23685 while Present (State_Elmt) loop
23687 -- A valid abstract state is being refined in the body. Add
23688 -- the state to the list of processed refined states to aid
23689 -- with the detection of duplicate refinements. Remove the
23690 -- state from Available_States to signal that it has already
23693 if Node (State_Elmt) = State_Id then
23694 Add_Item (State_Id, Refined_States_Seen);
23695 Remove_Elmt (Available_States, State_Elmt);
23699 Next_Elmt (State_Elmt);
23702 -- If we get here, we are refining a state that is not defined in
23703 -- the package declaration.
23705 Error_Msg_Name_1 := Chars (Spec_Id);
23707 ("cannot refine state, & is not defined in package %",
23709 end Check_Matching_State;
23711 --------------------------------
23712 -- Report_Unused_Constituents --
23713 --------------------------------
23715 procedure Report_Unused_Constituents (Constits : Elist_Id) is
23716 Constit_Elmt : Elmt_Id;
23717 Constit_Id : Entity_Id;
23718 Posted : Boolean := False;
23721 if Present (Constits) then
23722 Constit_Elmt := First_Elmt (Constits);
23723 while Present (Constit_Elmt) loop
23724 Constit_Id := Node (Constit_Elmt);
23726 -- Generate an error message of the form:
23728 -- state ... has unused Part_Of constituents
23729 -- abstract state ... defined at ...
23730 -- variable ... defined at ...
23735 ("state & has unused Part_Of constituents",
23739 Error_Msg_Sloc := Sloc (Constit_Id);
23741 if Ekind (Constit_Id) = E_Abstract_State then
23743 ("\abstract state & defined #", State, Constit_Id);
23746 ("\variable & defined #", State, Constit_Id);
23749 Next_Elmt (Constit_Elmt);
23752 end Report_Unused_Constituents;
23754 -- Local declarations
23756 Body_Ref : Node_Id;
23757 Body_Ref_Elmt : Elmt_Id;
23759 Extra_State : Node_Id;
23761 -- Start of processing for Analyze_Refinement_Clause
23764 -- A refinement clause appears as a component association where the
23765 -- sole choice is the state and the expressions are the constituents.
23766 -- This is a syntax error, always report.
23768 if Nkind (Clause) /= N_Component_Association then
23769 Error_Msg_N ("malformed state refinement clause", Clause);
23773 -- Analyze the state name of a refinement clause
23775 State := First (Choices (Clause));
23778 Resolve_State (State);
23780 -- Ensure that the state name denotes a valid abstract state that is
23781 -- defined in the spec of the related package.
23783 if Is_Entity_Name (State) then
23784 State_Id := Entity_Of (State);
23786 -- Catch any attempts to re-refine a state or refine a state that
23787 -- is not defined in the package declaration.
23789 if Ekind (State_Id) = E_Abstract_State then
23790 Check_Matching_State;
23793 ("& must denote an abstract state", State, State_Id);
23797 -- References to a state with visible refinement are illegal.
23798 -- When nested packages are involved, detecting such references is
23799 -- tricky because pragma Refined_State is analyzed later than the
23800 -- offending pragma Depends or Global. References that occur in
23801 -- such nested context are stored in a list. Emit errors for all
23802 -- references found in Body_References (SPARK RM 6.1.4(8)).
23804 if Present (Body_References (State_Id)) then
23805 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
23806 while Present (Body_Ref_Elmt) loop
23807 Body_Ref := Node (Body_Ref_Elmt);
23809 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
23810 Error_Msg_Sloc := Sloc (State);
23811 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
23813 Next_Elmt (Body_Ref_Elmt);
23817 -- The state name is illegal. This is a syntax error, always report.
23820 Error_Msg_N ("malformed state name in refinement clause", State);
23824 -- A refinement clause may only refine one state at a time
23826 Extra_State := Next (State);
23828 if Present (Extra_State) then
23830 ("refinement clause cannot cover multiple states", Extra_State);
23833 -- Replicate the Part_Of constituents of the refined state because
23834 -- the algorithm will consume items.
23836 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
23838 -- Analyze all constituents of the refinement. Multiple constituents
23839 -- appear as an aggregate.
23841 Constit := Expression (Clause);
23843 if Nkind (Constit) = N_Aggregate then
23844 if Present (Component_Associations (Constit)) then
23846 ("constituents of refinement clause must appear in "
23847 & "positional form", Constit);
23849 else pragma Assert (Present (Expressions (Constit)));
23850 Constit := First (Expressions (Constit));
23851 while Present (Constit) loop
23852 Analyze_Constituent (Constit);
23858 -- Various forms of a single constituent. Note that these may include
23859 -- malformed constituents.
23862 Analyze_Constituent (Constit);
23865 -- A refined external state is subject to special rules with respect
23866 -- to its properties and constituents.
23868 if Is_External_State (State_Id) then
23870 -- The set of properties that all external constituents yield must
23871 -- match that of the refined state. There are two cases to detect:
23872 -- the refined state lacks a property or has an extra property.
23874 if External_Constit_Seen then
23875 Check_External_Property
23876 (Prop_Nam => Name_Async_Readers,
23877 Enabled => Async_Readers_Enabled (State_Id),
23878 Constit => AR_Constit);
23880 Check_External_Property
23881 (Prop_Nam => Name_Async_Writers,
23882 Enabled => Async_Writers_Enabled (State_Id),
23883 Constit => AW_Constit);
23885 Check_External_Property
23886 (Prop_Nam => Name_Effective_Reads,
23887 Enabled => Effective_Reads_Enabled (State_Id),
23888 Constit => ER_Constit);
23890 Check_External_Property
23891 (Prop_Nam => Name_Effective_Writes,
23892 Enabled => Effective_Writes_Enabled (State_Id),
23893 Constit => EW_Constit);
23895 -- An external state may be refined to null (SPARK RM 7.2.8(2))
23897 elsif Null_Seen then
23900 -- The external state has constituents, but none of them are
23901 -- external (SPARK RM 7.2.8(2)).
23905 ("external state & requires at least one external "
23906 & "constituent or null refinement", State, State_Id);
23909 -- When a refined state is not external, it should not have external
23910 -- constituents (SPARK RM 7.2.8(1)).
23912 elsif External_Constit_Seen then
23914 ("non-external state & cannot contain external constituents in "
23915 & "refinement", State, State_Id);
23918 -- Ensure that all Part_Of candidate constituents have been mentioned
23919 -- in the refinement clause.
23921 Report_Unused_Constituents (Part_Of_Constits);
23922 end Analyze_Refinement_Clause;
23924 -------------------------
23925 -- Collect_Body_States --
23926 -------------------------
23928 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id is
23929 Result : Elist_Id := No_Elist;
23930 -- A list containing all body states of Pack_Id
23932 procedure Collect_Visible_States (Pack_Id : Entity_Id);
23933 -- Gather the entities of all abstract states and variables declared
23934 -- in the visible state space of package Pack_Id.
23936 ----------------------------
23937 -- Collect_Visible_States --
23938 ----------------------------
23940 procedure Collect_Visible_States (Pack_Id : Entity_Id) is
23941 Item_Id : Entity_Id;
23944 -- Traverse the entity chain of the package and inspect all
23947 Item_Id := First_Entity (Pack_Id);
23948 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
23950 -- Do not consider internally generated items as those cannot
23951 -- be named and participate in refinement.
23953 if not Comes_From_Source (Item_Id) then
23956 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
23957 Add_Item (Item_Id, Result);
23959 -- Recursively gather the visible states of a nested package
23961 elsif Ekind (Item_Id) = E_Package then
23962 Collect_Visible_States (Item_Id);
23965 Next_Entity (Item_Id);
23967 end Collect_Visible_States;
23971 Pack_Body : constant Node_Id :=
23972 Declaration_Node (Body_Entity (Pack_Id));
23974 Item_Id : Entity_Id;
23976 -- Start of processing for Collect_Body_States
23979 -- Inspect the declarations of the body looking for source variables,
23980 -- packages and package instantiations.
23982 Decl := First (Declarations (Pack_Body));
23983 while Present (Decl) loop
23984 if Nkind (Decl) = N_Object_Declaration then
23985 Item_Id := Defining_Entity (Decl);
23987 -- Capture source variables only as internally generated
23988 -- temporaries cannot be named and participate in refinement.
23990 if Ekind (Item_Id) = E_Variable
23991 and then Comes_From_Source (Item_Id)
23993 Add_Item (Item_Id, Result);
23996 elsif Nkind (Decl) = N_Package_Declaration then
23997 Item_Id := Defining_Entity (Decl);
23999 -- Capture the visible abstract states and variables of a
24000 -- source package [instantiation].
24002 if Comes_From_Source (Item_Id) then
24003 Collect_Visible_States (Item_Id);
24011 end Collect_Body_States;
24013 -----------------------------
24014 -- Report_Unrefined_States --
24015 -----------------------------
24017 procedure Report_Unrefined_States (States : Elist_Id) is
24018 State_Elmt : Elmt_Id;
24021 if Present (States) then
24022 State_Elmt := First_Elmt (States);
24023 while Present (State_Elmt) loop
24025 ("abstract state & must be refined", Node (State_Elmt));
24027 Next_Elmt (State_Elmt);
24030 end Report_Unrefined_States;
24032 --------------------------
24033 -- Report_Unused_States --
24034 --------------------------
24036 procedure Report_Unused_States (States : Elist_Id) is
24037 Posted : Boolean := False;
24038 State_Elmt : Elmt_Id;
24039 State_Id : Entity_Id;
24042 if Present (States) then
24043 State_Elmt := First_Elmt (States);
24044 while Present (State_Elmt) loop
24045 State_Id := Node (State_Elmt);
24047 -- Generate an error message of the form:
24049 -- body of package ... has unused hidden states
24050 -- abstract state ... defined at ...
24051 -- variable ... defined at ...
24056 ("body of package & has unused hidden states", Body_Id);
24059 Error_Msg_Sloc := Sloc (State_Id);
24061 if Ekind (State_Id) = E_Abstract_State then
24063 ("\abstract state & defined #", Body_Id, State_Id);
24066 ("\variable & defined #", Body_Id, State_Id);
24069 Next_Elmt (State_Elmt);
24072 end Report_Unused_States;
24074 -- Local declarations
24076 Body_Decl : constant Node_Id := Parent (N);
24077 Clauses : constant Node_Id :=
24078 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
24081 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24086 Body_Id := Defining_Entity (Body_Decl);
24087 Spec_Id := Corresponding_Spec (Body_Decl);
24089 -- Replicate the abstract states declared by the package because the
24090 -- matching algorithm will consume states.
24092 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
24094 -- Gather all abstract states and variables declared in the visible
24095 -- state space of the package body. These items must be utilized as
24096 -- constituents in a state refinement.
24098 Body_States := Collect_Body_States (Spec_Id);
24100 -- Multiple non-null state refinements appear as an aggregate
24102 if Nkind (Clauses) = N_Aggregate then
24103 if Present (Expressions (Clauses)) then
24105 ("state refinements must appear as component associations",
24108 else pragma Assert (Present (Component_Associations (Clauses)));
24109 Clause := First (Component_Associations (Clauses));
24110 while Present (Clause) loop
24111 Analyze_Refinement_Clause (Clause);
24117 -- Various forms of a single state refinement. Note that these may
24118 -- include malformed refinements.
24121 Analyze_Refinement_Clause (Clauses);
24124 -- List all abstract states that were left unrefined
24126 Report_Unrefined_States (Available_States);
24128 -- Ensure that all abstract states and variables declared in the body
24129 -- state space of the related package are utilized as constituents.
24131 Report_Unused_States (Body_States);
24132 end Analyze_Refined_State_In_Decl_Part;
24134 ------------------------------------
24135 -- Analyze_Test_Case_In_Decl_Part --
24136 ------------------------------------
24138 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is
24140 -- Install formals and push subprogram spec onto scope stack so that we
24141 -- can see the formals from the pragma.
24144 Install_Formals (S);
24146 -- Preanalyze the boolean expressions, we treat these as spec
24147 -- expressions (i.e. similar to a default expression).
24149 if Pragma_Name (N) = Name_Test_Case then
24150 Preanalyze_CTC_Args
24152 Get_Requires_From_CTC_Pragma (N),
24153 Get_Ensures_From_CTC_Pragma (N));
24156 -- Remove the subprogram from the scope stack now that the pre-analysis
24157 -- of the expressions in the contract case or test case is done.
24160 end Analyze_Test_Case_In_Decl_Part;
24166 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
24171 if Present (List) then
24172 Elmt := First_Elmt (List);
24173 while Present (Elmt) loop
24174 if Nkind (Node (Elmt)) = N_Defining_Identifier then
24177 Id := Entity_Of (Node (Elmt));
24180 if Id = Item_Id then
24191 -----------------------------
24192 -- Check_Applicable_Policy --
24193 -----------------------------
24195 procedure Check_Applicable_Policy (N : Node_Id) is
24199 Ename : constant Name_Id := Original_Aspect_Name (N);
24202 -- No effect if not valid assertion kind name
24204 if not Is_Valid_Assertion_Kind (Ename) then
24208 -- Loop through entries in check policy list
24210 PP := Opt.Check_Policy_List;
24211 while Present (PP) loop
24213 PPA : constant List_Id := Pragma_Argument_Associations (PP);
24214 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
24218 or else Pnm = Name_Assertion
24219 or else (Pnm = Name_Statement_Assertions
24220 and then Nam_In (Ename, Name_Assert,
24221 Name_Assert_And_Cut,
24223 Name_Loop_Invariant,
24224 Name_Loop_Variant))
24226 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
24229 when Name_Off | Name_Ignore =>
24230 Set_Is_Ignored (N, True);
24231 Set_Is_Checked (N, False);
24233 when Name_On | Name_Check =>
24234 Set_Is_Checked (N, True);
24235 Set_Is_Ignored (N, False);
24237 when Name_Disable =>
24238 Set_Is_Ignored (N, True);
24239 Set_Is_Checked (N, False);
24240 Set_Is_Disabled (N, True);
24242 -- That should be exhaustive, the null here is a defence
24243 -- against a malformed tree from previous errors.
24252 PP := Next_Pragma (PP);
24256 -- If there are no specific entries that matched, then we let the
24257 -- setting of assertions govern. Note that this provides the needed
24258 -- compatibility with the RM for the cases of assertion, invariant,
24259 -- precondition, predicate, and postcondition.
24261 if Assertions_Enabled then
24262 Set_Is_Checked (N, True);
24263 Set_Is_Ignored (N, False);
24265 Set_Is_Checked (N, False);
24266 Set_Is_Ignored (N, True);
24268 end Check_Applicable_Policy;
24270 -------------------------------
24271 -- Check_External_Properties --
24272 -------------------------------
24274 procedure Check_External_Properties
24282 -- All properties enabled
24284 if AR and AW and ER and EW then
24287 -- Async_Readers + Effective_Writes
24288 -- Async_Readers + Async_Writers + Effective_Writes
24290 elsif AR and EW and not ER then
24293 -- Async_Writers + Effective_Reads
24294 -- Async_Readers + Async_Writers + Effective_Reads
24296 elsif AW and ER and not EW then
24299 -- Async_Readers + Async_Writers
24301 elsif AR and AW and not ER and not EW then
24306 elsif AR and not AW and not ER and not EW then
24311 elsif AW and not AR and not ER and not EW then
24316 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24319 end Check_External_Properties;
24325 function Check_Kind (Nam : Name_Id) return Name_Id is
24329 -- Loop through entries in check policy list
24331 PP := Opt.Check_Policy_List;
24332 while Present (PP) loop
24334 PPA : constant List_Id := Pragma_Argument_Associations (PP);
24335 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
24339 or else (Pnm = Name_Assertion
24340 and then Is_Valid_Assertion_Kind (Nam))
24341 or else (Pnm = Name_Statement_Assertions
24342 and then Nam_In (Nam, Name_Assert,
24343 Name_Assert_And_Cut,
24345 Name_Loop_Invariant,
24346 Name_Loop_Variant))
24348 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
24349 when Name_On | Name_Check =>
24351 when Name_Off | Name_Ignore =>
24352 return Name_Ignore;
24353 when Name_Disable =>
24354 return Name_Disable;
24356 raise Program_Error;
24360 PP := Next_Pragma (PP);
24365 -- If there are no specific entries that matched, then we let the
24366 -- setting of assertions govern. Note that this provides the needed
24367 -- compatibility with the RM for the cases of assertion, invariant,
24368 -- precondition, predicate, and postcondition.
24370 if Assertions_Enabled then
24373 return Name_Ignore;
24377 ---------------------------
24378 -- Check_Missing_Part_Of --
24379 ---------------------------
24381 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
24382 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
24383 -- Determine whether a package denoted by Pack_Id declares at least one
24386 -----------------------
24387 -- Has_Visible_State --
24388 -----------------------
24390 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
24391 Item_Id : Entity_Id;
24394 -- Traverse the entity chain of the package trying to find at least
24395 -- one visible abstract state, variable or a package [instantiation]
24396 -- that declares a visible state.
24398 Item_Id := First_Entity (Pack_Id);
24399 while Present (Item_Id)
24400 and then not In_Private_Part (Item_Id)
24402 -- Do not consider internally generated items
24404 if not Comes_From_Source (Item_Id) then
24407 -- A visible state has been found
24409 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
24412 -- Recursively peek into nested packages and instantiations
24414 elsif Ekind (Item_Id) = E_Package
24415 and then Has_Visible_State (Item_Id)
24420 Next_Entity (Item_Id);
24424 end Has_Visible_State;
24428 Pack_Id : Entity_Id;
24429 Placement : State_Space_Kind;
24431 -- Start of processing for Check_Missing_Part_Of
24434 -- Do not consider abstract states, variables or package instantiations
24435 -- coming from an instance as those always inherit the Part_Of indicator
24436 -- of the instance itself.
24438 if In_Instance then
24441 -- Do not consider internally generated entities as these can never
24442 -- have a Part_Of indicator.
24444 elsif not Comes_From_Source (Item_Id) then
24447 -- Perform these checks only when SPARK_Mode is enabled as they will
24448 -- interfere with standard Ada rules and produce false positives.
24450 elsif SPARK_Mode /= On then
24454 -- Find where the abstract state, variable or package instantiation
24455 -- lives with respect to the state space.
24457 Find_Placement_In_State_Space
24458 (Item_Id => Item_Id,
24459 Placement => Placement,
24460 Pack_Id => Pack_Id);
24462 -- Items that appear in a non-package construct (subprogram, block, etc)
24463 -- do not require a Part_Of indicator because they can never act as a
24466 if Placement = Not_In_Package then
24469 -- An item declared in the body state space of a package always act as a
24470 -- constituent and does not need explicit Part_Of indicator.
24472 elsif Placement = Body_State_Space then
24475 -- In general an item declared in the visible state space of a package
24476 -- does not require a Part_Of indicator. The only exception is when the
24477 -- related package is a private child unit in which case Part_Of must
24478 -- denote a state in the parent unit or in one of its descendants.
24480 elsif Placement = Visible_State_Space then
24481 if Is_Child_Unit (Pack_Id)
24482 and then Is_Private_Descendant (Pack_Id)
24484 -- A package instantiation does not need a Part_Of indicator when
24485 -- the related generic template has no visible state.
24487 if Ekind (Item_Id) = E_Package
24488 and then Is_Generic_Instance (Item_Id)
24489 and then not Has_Visible_State (Item_Id)
24493 -- All other cases require Part_Of
24497 ("indicator Part_Of is required in this context "
24498 & "(SPARK RM 7.2.6(3))", Item_Id);
24499 Error_Msg_Name_1 := Chars (Pack_Id);
24501 ("\& is declared in the visible part of private child "
24502 & "unit %", Item_Id);
24506 -- When the item appears in the private state space of a packge, it must
24507 -- be a part of some state declared by the said package.
24509 else pragma Assert (Placement = Private_State_Space);
24511 -- The related package does not declare a state, the item cannot act
24512 -- as a Part_Of constituent.
24514 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
24517 -- A package instantiation does not need a Part_Of indicator when the
24518 -- related generic template has no visible state.
24520 elsif Ekind (Pack_Id) = E_Package
24521 and then Is_Generic_Instance (Pack_Id)
24522 and then not Has_Visible_State (Pack_Id)
24526 -- All other cases require Part_Of
24530 ("indicator Part_Of is required in this context "
24531 & "(SPARK RM 7.2.6(2))", Item_Id);
24532 Error_Msg_Name_1 := Chars (Pack_Id);
24534 ("\& is declared in the private part of package %", Item_Id);
24537 end Check_Missing_Part_Of;
24539 ---------------------------------
24540 -- Check_SPARK_Aspect_For_ASIS --
24541 ---------------------------------
24543 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id) is
24547 if ASIS_Mode and then From_Aspect_Specification (N) then
24548 Expr := Expression (Corresponding_Aspect (N));
24549 if Nkind (Expr) /= N_Aggregate then
24550 Preanalyze_And_Resolve (Expr);
24554 Comps : constant List_Id := Component_Associations (Expr);
24555 Exprs : constant List_Id := Expressions (Expr);
24560 E := First (Exprs);
24561 while Present (E) loop
24566 C := First (Comps);
24567 while Present (C) loop
24568 Analyze (Expression (C));
24574 end Check_SPARK_Aspect_For_ASIS;
24576 -------------------------------------
24577 -- Check_State_And_Constituent_Use --
24578 -------------------------------------
24580 procedure Check_State_And_Constituent_Use
24581 (States : Elist_Id;
24582 Constits : Elist_Id;
24585 function Find_Encapsulating_State
24586 (Constit_Id : Entity_Id) return Entity_Id;
24587 -- Given the entity of a constituent, try to find a corresponding
24588 -- encapsulating state that appears in the same context. The routine
24589 -- returns Empty is no such state is found.
24591 ------------------------------
24592 -- Find_Encapsulating_State --
24593 ------------------------------
24595 function Find_Encapsulating_State
24596 (Constit_Id : Entity_Id) return Entity_Id
24598 State_Id : Entity_Id;
24601 -- Since a constituent may be part of a larger constituent set, climb
24602 -- the encapsulated state chain looking for a state that appears in
24603 -- the same context.
24605 State_Id := Encapsulating_State (Constit_Id);
24606 while Present (State_Id) loop
24607 if Contains (States, State_Id) then
24611 State_Id := Encapsulating_State (State_Id);
24615 end Find_Encapsulating_State;
24619 Constit_Elmt : Elmt_Id;
24620 Constit_Id : Entity_Id;
24621 State_Id : Entity_Id;
24623 -- Start of processing for Check_State_And_Constituent_Use
24626 -- Nothing to do if there are no states or constituents
24628 if No (States) or else No (Constits) then
24632 -- Inspect the list of constituents and try to determine whether its
24633 -- encapsulating state is in list States.
24635 Constit_Elmt := First_Elmt (Constits);
24636 while Present (Constit_Elmt) loop
24637 Constit_Id := Node (Constit_Elmt);
24639 -- Determine whether the constituent is part of an encapsulating
24640 -- state that appears in the same context and if this is the case,
24641 -- emit an error (SPARK RM 7.2.6(7)).
24643 State_Id := Find_Encapsulating_State (Constit_Id);
24645 if Present (State_Id) then
24646 Error_Msg_Name_1 := Chars (Constit_Id);
24648 ("cannot mention state & and its constituent % in the same "
24649 & "context", Context, State_Id);
24653 Next_Elmt (Constit_Elmt);
24655 end Check_State_And_Constituent_Use;
24657 --------------------------
24658 -- Collect_Global_Items --
24659 --------------------------
24661 procedure Collect_Global_Items
24663 In_Items : in out Elist_Id;
24664 In_Out_Items : in out Elist_Id;
24665 Out_Items : in out Elist_Id;
24666 Proof_In_Items : in out Elist_Id;
24667 Has_In_State : out Boolean;
24668 Has_In_Out_State : out Boolean;
24669 Has_Out_State : out Boolean;
24670 Has_Proof_In_State : out Boolean;
24671 Has_Null_State : out Boolean)
24673 procedure Process_Global_List
24675 Mode : Name_Id := Name_Input);
24676 -- Collect all items housed in a global list. Formal Mode denotes the
24677 -- current mode in effect.
24679 -------------------------
24680 -- Process_Global_List --
24681 -------------------------
24683 procedure Process_Global_List
24685 Mode : Name_Id := Name_Input)
24687 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id);
24688 -- Add a single item to the appropriate list. Formal Mode denotes the
24689 -- current mode in effect.
24691 -------------------------
24692 -- Process_Global_Item --
24693 -------------------------
24695 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is
24696 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
24697 -- The above handles abstract views of variables and states built
24698 -- for limited with clauses.
24701 -- Signal that the global list contains at least one abstract
24702 -- state with a visible refinement. Note that the refinement may
24703 -- be null in which case there are no constituents.
24705 if Ekind (Item_Id) = E_Abstract_State then
24706 if Has_Null_Refinement (Item_Id) then
24707 Has_Null_State := True;
24709 elsif Has_Non_Null_Refinement (Item_Id) then
24710 if Mode = Name_Input then
24711 Has_In_State := True;
24712 elsif Mode = Name_In_Out then
24713 Has_In_Out_State := True;
24714 elsif Mode = Name_Output then
24715 Has_Out_State := True;
24716 elsif Mode = Name_Proof_In then
24717 Has_Proof_In_State := True;
24722 -- Add the item to the proper list
24724 if Mode = Name_Input then
24725 Add_Item (Item_Id, In_Items);
24726 elsif Mode = Name_In_Out then
24727 Add_Item (Item_Id, In_Out_Items);
24728 elsif Mode = Name_Output then
24729 Add_Item (Item_Id, Out_Items);
24730 elsif Mode = Name_Proof_In then
24731 Add_Item (Item_Id, Proof_In_Items);
24733 end Process_Global_Item;
24739 -- Start of processing for Process_Global_List
24742 if Nkind (List) = N_Null then
24745 -- Single global item declaration
24747 elsif Nkind_In (List, N_Expanded_Name,
24749 N_Selected_Component)
24751 Process_Global_Item (List, Mode);
24753 -- Single global list or moded global list declaration
24755 elsif Nkind (List) = N_Aggregate then
24757 -- The declaration of a simple global list appear as a collection
24760 if Present (Expressions (List)) then
24761 Item := First (Expressions (List));
24762 while Present (Item) loop
24763 Process_Global_Item (Item, Mode);
24768 -- The declaration of a moded global list appears as a collection
24769 -- of component associations where individual choices denote mode.
24771 elsif Present (Component_Associations (List)) then
24772 Item := First (Component_Associations (List));
24773 while Present (Item) loop
24774 Process_Global_List
24775 (List => Expression (Item),
24776 Mode => Chars (First (Choices (Item))));
24784 raise Program_Error;
24787 -- To accomodate partial decoration of disabled SPARK features, this
24788 -- routine may be called with illegal input. If this is the case, do
24789 -- not raise Program_Error.
24794 end Process_Global_List;
24798 Items : constant Node_Id :=
24799 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
24801 -- Start of processing for Collect_Global_Items
24804 -- Assume that no states have been encountered
24806 Has_In_State := False;
24807 Has_In_Out_State := False;
24808 Has_Out_State := False;
24809 Has_Proof_In_State := False;
24810 Has_Null_State := False;
24812 Process_Global_List (Items);
24813 end Collect_Global_Items;
24815 ---------------------------------------
24816 -- Collect_Subprogram_Inputs_Outputs --
24817 ---------------------------------------
24819 procedure Collect_Subprogram_Inputs_Outputs
24820 (Subp_Id : Entity_Id;
24821 Subp_Inputs : in out Elist_Id;
24822 Subp_Outputs : in out Elist_Id;
24823 Global_Seen : out Boolean)
24825 procedure Collect_Global_List
24827 Mode : Name_Id := Name_Input);
24828 -- Collect all relevant items from a global list
24830 -------------------------
24831 -- Collect_Global_List --
24832 -------------------------
24834 procedure Collect_Global_List
24836 Mode : Name_Id := Name_Input)
24838 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
24839 -- Add an item to the proper subprogram input or output collection
24841 -------------------------
24842 -- Collect_Global_Item --
24843 -------------------------
24845 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
24847 if Nam_In (Mode, Name_In_Out, Name_Input) then
24848 Add_Item (Item, Subp_Inputs);
24851 if Nam_In (Mode, Name_In_Out, Name_Output) then
24852 Add_Item (Item, Subp_Outputs);
24854 end Collect_Global_Item;
24861 -- Start of processing for Collect_Global_List
24864 if Nkind (List) = N_Null then
24867 -- Single global item declaration
24869 elsif Nkind_In (List, N_Expanded_Name,
24871 N_Selected_Component)
24873 Collect_Global_Item (List, Mode);
24875 -- Simple global list or moded global list declaration
24877 elsif Nkind (List) = N_Aggregate then
24878 if Present (Expressions (List)) then
24879 Item := First (Expressions (List));
24880 while Present (Item) loop
24881 Collect_Global_Item (Item, Mode);
24886 Assoc := First (Component_Associations (List));
24887 while Present (Assoc) loop
24888 Collect_Global_List
24889 (List => Expression (Assoc),
24890 Mode => Chars (First (Choices (Assoc))));
24895 -- To accomodate partial decoration of disabled SPARK features, this
24896 -- routine may be called with illegal input. If this is the case, do
24897 -- not raise Program_Error.
24902 end Collect_Global_List;
24906 Subp_Decl : constant Node_Id := Parent (Parent (Subp_Id));
24907 Formal : Entity_Id;
24910 Spec_Id : Entity_Id;
24912 -- Start of processing for Collect_Subprogram_Inputs_Outputs
24915 Global_Seen := False;
24917 -- Find the entity of the corresponding spec when processing a body
24919 if Nkind (Subp_Decl) = N_Subprogram_Body
24920 and then Present (Corresponding_Spec (Subp_Decl))
24922 Spec_Id := Corresponding_Spec (Subp_Decl);
24924 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
24925 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
24927 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
24930 Spec_Id := Subp_Id;
24933 -- Process all formal parameters
24935 Formal := First_Formal (Spec_Id);
24936 while Present (Formal) loop
24937 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
24938 Add_Item (Formal, Subp_Inputs);
24941 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
24942 Add_Item (Formal, Subp_Outputs);
24944 -- Out parameters can act as inputs when the related type is
24945 -- tagged, unconstrained array, unconstrained record or record
24946 -- with unconstrained components.
24948 if Ekind (Formal) = E_Out_Parameter
24949 and then Is_Unconstrained_Or_Tagged_Item (Formal)
24951 Add_Item (Formal, Subp_Inputs);
24955 Next_Formal (Formal);
24958 -- When processing a subprogram body, look for pragma Refined_Global as
24959 -- it provides finer granularity of inputs and outputs.
24961 if Ekind (Subp_Id) = E_Subprogram_Body then
24962 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
24964 -- Subprogram declaration case, look for pragma Global
24967 Global := Get_Pragma (Spec_Id, Pragma_Global);
24970 if Present (Global) then
24971 Global_Seen := True;
24972 List := Expression (First (Pragma_Argument_Associations (Global)));
24974 -- The pragma may not have been analyzed because of the arbitrary
24975 -- declaration order of aspects. Make sure that it is analyzed for
24976 -- the purposes of item extraction.
24978 if not Analyzed (List) then
24979 if Pragma_Name (Global) = Name_Refined_Global then
24980 Analyze_Refined_Global_In_Decl_Part (Global);
24982 Analyze_Global_In_Decl_Part (Global);
24986 -- Nothing to be done for a null global list
24988 if Nkind (List) /= N_Null then
24989 Collect_Global_List (List);
24992 end Collect_Subprogram_Inputs_Outputs;
24994 ---------------------------------
24995 -- Delay_Config_Pragma_Analyze --
24996 ---------------------------------
24998 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
25000 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
25001 Name_Priority_Specific_Dispatching);
25002 end Delay_Config_Pragma_Analyze;
25004 -------------------------------------
25005 -- Find_Related_Subprogram_Or_Body --
25006 -------------------------------------
25008 function Find_Related_Subprogram_Or_Body
25010 Do_Checks : Boolean := False) return Node_Id
25012 Context : constant Node_Id := Parent (Prag);
25013 Nam : constant Name_Id := Pragma_Name (Prag);
25016 Look_For_Body : constant Boolean :=
25017 Nam_In (Nam, Name_Refined_Depends,
25018 Name_Refined_Global,
25019 Name_Refined_Post);
25020 -- Refinement pragmas must be associated with a subprogram body [stub]
25023 pragma Assert (Nkind (Prag) = N_Pragma);
25025 -- If the pragma is a byproduct of aspect expansion, return the related
25026 -- context of the original aspect.
25028 if Present (Corresponding_Aspect (Prag)) then
25029 return Parent (Corresponding_Aspect (Prag));
25032 -- Otherwise the pragma is a source construct, most likely part of a
25033 -- declarative list. Skip preceding declarations while looking for a
25034 -- proper subprogram declaration.
25036 pragma Assert (Is_List_Member (Prag));
25038 Stmt := Prev (Prag);
25039 while Present (Stmt) loop
25041 -- Skip prior pragmas, but check for duplicates
25043 if Nkind (Stmt) = N_Pragma then
25044 if Do_Checks and then Pragma_Name (Stmt) = Nam then
25045 Error_Msg_Name_1 := Nam;
25046 Error_Msg_Sloc := Sloc (Stmt);
25047 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
25050 -- Emit an error when a refinement pragma appears on an expression
25051 -- function without a completion.
25054 and then Look_For_Body
25055 and then Nkind (Stmt) = N_Subprogram_Declaration
25056 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
25057 and then not Has_Completion (Defining_Entity (Stmt))
25059 Error_Msg_Name_1 := Nam;
25061 ("pragma % cannot apply to a stand alone expression function",
25066 -- The refinement pragma applies to a subprogram body stub
25068 elsif Look_For_Body
25069 and then Nkind (Stmt) = N_Subprogram_Body_Stub
25073 -- Skip internally generated code
25075 elsif not Comes_From_Source (Stmt) then
25078 -- Return the current construct which is either a subprogram body,
25079 -- a subprogram declaration or is illegal.
25088 -- If we fall through, then the pragma was either the first declaration
25089 -- or it was preceded by other pragmas and no source constructs.
25091 -- The pragma is associated with a library-level subprogram
25093 if Nkind (Context) = N_Compilation_Unit_Aux then
25094 return Unit (Parent (Context));
25096 -- The pragma appears inside the declarative part of a subprogram body
25098 elsif Nkind (Context) = N_Subprogram_Body then
25101 -- No candidate subprogram [body] found
25106 end Find_Related_Subprogram_Or_Body;
25108 -------------------------
25109 -- Get_Base_Subprogram --
25110 -------------------------
25112 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
25113 Result : Entity_Id;
25116 -- Follow subprogram renaming chain
25120 if Is_Subprogram (Result)
25122 Nkind (Parent (Declaration_Node (Result))) =
25123 N_Subprogram_Renaming_Declaration
25124 and then Present (Alias (Result))
25126 Result := Alias (Result);
25130 end Get_Base_Subprogram;
25132 -----------------------
25133 -- Get_SPARK_Mode_Type --
25134 -----------------------
25136 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
25138 if N = Name_On then
25140 elsif N = Name_Off then
25143 -- Any other argument is illegal
25146 raise Program_Error;
25148 end Get_SPARK_Mode_Type;
25150 --------------------------------
25151 -- Get_SPARK_Mode_From_Pragma --
25152 --------------------------------
25154 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is
25159 pragma Assert (Nkind (N) = N_Pragma);
25160 Args := Pragma_Argument_Associations (N);
25162 -- Extract the mode from the argument list
25164 if Present (Args) then
25165 Mode := First (Pragma_Argument_Associations (N));
25166 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode)));
25168 -- If SPARK_Mode pragma has no argument, default is ON
25173 end Get_SPARK_Mode_From_Pragma;
25175 ---------------------------
25176 -- Has_Extra_Parentheses --
25177 ---------------------------
25179 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
25183 -- The aggregate should not have an expression list because a clause
25184 -- is always interpreted as a component association. The only way an
25185 -- expression list can sneak in is by adding extra parentheses around
25186 -- the individual clauses:
25188 -- Depends (Output => Input) -- proper form
25189 -- Depends ((Output => Input)) -- extra parentheses
25191 -- Since the extra parentheses are not allowed by the syntax of the
25192 -- pragma, flag them now to avoid emitting misleading errors down the
25195 if Nkind (Clause) = N_Aggregate
25196 and then Present (Expressions (Clause))
25198 Expr := First (Expressions (Clause));
25199 while Present (Expr) loop
25201 -- A dependency clause surrounded by extra parentheses appears
25202 -- as an aggregate of component associations with an optional
25203 -- Paren_Count set.
25205 if Nkind (Expr) = N_Aggregate
25206 and then Present (Component_Associations (Expr))
25209 ("dependency clause contains extra parentheses", Expr);
25211 -- Otherwise the expression is a malformed construct
25214 SPARK_Msg_N ("malformed dependency clause", Expr);
25224 end Has_Extra_Parentheses;
25230 procedure Initialize is
25241 Dummy := Dummy + 1;
25244 -----------------------------
25245 -- Is_Config_Static_String --
25246 -----------------------------
25248 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
25250 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
25251 -- This is an internal recursive function that is just like the outer
25252 -- function except that it adds the string to the name buffer rather
25253 -- than placing the string in the name buffer.
25255 ------------------------------
25256 -- Add_Config_Static_String --
25257 ------------------------------
25259 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
25266 if Nkind (N) = N_Op_Concat then
25267 if Add_Config_Static_String (Left_Opnd (N)) then
25268 N := Right_Opnd (N);
25274 if Nkind (N) /= N_String_Literal then
25275 Error_Msg_N ("string literal expected for pragma argument", N);
25279 for J in 1 .. String_Length (Strval (N)) loop
25280 C := Get_String_Char (Strval (N), J);
25282 if not In_Character_Range (C) then
25284 ("string literal contains invalid wide character",
25285 Sloc (N) + 1 + Source_Ptr (J));
25289 Add_Char_To_Name_Buffer (Get_Character (C));
25294 end Add_Config_Static_String;
25296 -- Start of processing for Is_Config_Static_String
25301 return Add_Config_Static_String (Arg);
25302 end Is_Config_Static_String;
25304 -------------------------------
25305 -- Is_Elaboration_SPARK_Mode --
25306 -------------------------------
25308 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
25311 (Nkind (N) = N_Pragma
25312 and then Pragma_Name (N) = Name_SPARK_Mode
25313 and then Is_List_Member (N));
25315 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25316 -- appears in the statement part of the body.
25319 Present (Parent (N))
25320 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
25321 and then List_Containing (N) = Statements (Parent (N))
25322 and then Present (Parent (Parent (N)))
25323 and then Nkind (Parent (Parent (N))) = N_Package_Body;
25324 end Is_Elaboration_SPARK_Mode;
25326 -----------------------------------------
25327 -- Is_Non_Significant_Pragma_Reference --
25328 -----------------------------------------
25330 -- This function makes use of the following static table which indicates
25331 -- whether appearance of some name in a given pragma is to be considered
25332 -- as a reference for the purposes of warnings about unreferenced objects.
25334 -- -1 indicates that references in any argument position are significant
25335 -- 0 indicates that appearance in any argument is not significant
25336 -- +n indicates that appearance as argument n is significant, but all
25337 -- other arguments are not significant
25338 -- 99 special processing required (e.g. for pragma Check)
25340 Sig_Flags : constant array (Pragma_Id) of Int :=
25341 (Pragma_AST_Entry => -1,
25342 Pragma_Abort_Defer => -1,
25343 Pragma_Abstract_State => -1,
25344 Pragma_Ada_83 => -1,
25345 Pragma_Ada_95 => -1,
25346 Pragma_Ada_05 => -1,
25347 Pragma_Ada_2005 => -1,
25348 Pragma_Ada_12 => -1,
25349 Pragma_Ada_2012 => -1,
25350 Pragma_All_Calls_Remote => -1,
25351 Pragma_Allow_Integer_Address => 0,
25352 Pragma_Annotate => -1,
25353 Pragma_Assert => -1,
25354 Pragma_Assert_And_Cut => -1,
25355 Pragma_Assertion_Policy => 0,
25356 Pragma_Assume => -1,
25357 Pragma_Assume_No_Invalid_Values => 0,
25358 Pragma_Async_Readers => 0,
25359 Pragma_Async_Writers => 0,
25360 Pragma_Asynchronous => -1,
25361 Pragma_Atomic => 0,
25362 Pragma_Atomic_Components => 0,
25363 Pragma_Attach_Handler => -1,
25364 Pragma_Attribute_Definition => +3,
25365 Pragma_Check => 99,
25366 Pragma_Check_Float_Overflow => 0,
25367 Pragma_Check_Name => 0,
25368 Pragma_Check_Policy => 0,
25369 Pragma_CIL_Constructor => -1,
25370 Pragma_CPP_Class => 0,
25371 Pragma_CPP_Constructor => 0,
25372 Pragma_CPP_Virtual => 0,
25373 Pragma_CPP_Vtable => 0,
25375 Pragma_C_Pass_By_Copy => 0,
25376 Pragma_Comment => 0,
25377 Pragma_Common_Object => -1,
25378 Pragma_Compile_Time_Error => -1,
25379 Pragma_Compile_Time_Warning => -1,
25380 Pragma_Compiler_Unit => 0,
25381 Pragma_Compiler_Unit_Warning => 0,
25382 Pragma_Complete_Representation => 0,
25383 Pragma_Complex_Representation => 0,
25384 Pragma_Component_Alignment => -1,
25385 Pragma_Contract_Cases => -1,
25386 Pragma_Controlled => 0,
25387 Pragma_Convention => 0,
25388 Pragma_Convention_Identifier => 0,
25389 Pragma_Debug => -1,
25390 Pragma_Debug_Policy => 0,
25391 Pragma_Detect_Blocking => -1,
25392 Pragma_Default_Scalar_Storage_Order => 0,
25393 Pragma_Default_Storage_Pool => -1,
25394 Pragma_Depends => -1,
25395 Pragma_Disable_Atomic_Synchronization => -1,
25396 Pragma_Discard_Names => 0,
25397 Pragma_Dispatching_Domain => -1,
25398 Pragma_Effective_Reads => 0,
25399 Pragma_Effective_Writes => 0,
25400 Pragma_Elaborate => -1,
25401 Pragma_Elaborate_All => -1,
25402 Pragma_Elaborate_Body => -1,
25403 Pragma_Elaboration_Checks => -1,
25404 Pragma_Eliminate => -1,
25405 Pragma_Enable_Atomic_Synchronization => -1,
25406 Pragma_Export => -1,
25407 Pragma_Export_Exception => -1,
25408 Pragma_Export_Function => -1,
25409 Pragma_Export_Object => -1,
25410 Pragma_Export_Procedure => -1,
25411 Pragma_Export_Value => -1,
25412 Pragma_Export_Valued_Procedure => -1,
25413 Pragma_Extend_System => -1,
25414 Pragma_Extensions_Allowed => -1,
25415 Pragma_External => -1,
25416 Pragma_Favor_Top_Level => -1,
25417 Pragma_External_Name_Casing => -1,
25418 Pragma_Fast_Math => -1,
25419 Pragma_Finalize_Storage_Only => 0,
25420 Pragma_Float_Representation => 0,
25421 Pragma_Global => -1,
25422 Pragma_Ident => -1,
25423 Pragma_Implementation_Defined => -1,
25424 Pragma_Implemented => -1,
25425 Pragma_Implicit_Packing => 0,
25426 Pragma_Import => +2,
25427 Pragma_Import_Exception => 0,
25428 Pragma_Import_Function => 0,
25429 Pragma_Import_Object => 0,
25430 Pragma_Import_Procedure => 0,
25431 Pragma_Import_Valued_Procedure => 0,
25432 Pragma_Independent => 0,
25433 Pragma_Independent_Components => 0,
25434 Pragma_Initial_Condition => -1,
25435 Pragma_Initialize_Scalars => -1,
25436 Pragma_Initializes => -1,
25437 Pragma_Inline => 0,
25438 Pragma_Inline_Always => 0,
25439 Pragma_Inline_Generic => 0,
25440 Pragma_Inspection_Point => -1,
25441 Pragma_Interface => +2,
25442 Pragma_Interface_Name => +2,
25443 Pragma_Interrupt_Handler => -1,
25444 Pragma_Interrupt_Priority => -1,
25445 Pragma_Interrupt_State => -1,
25446 Pragma_Invariant => -1,
25447 Pragma_Java_Constructor => -1,
25448 Pragma_Java_Interface => -1,
25449 Pragma_Keep_Names => 0,
25450 Pragma_License => -1,
25451 Pragma_Link_With => -1,
25452 Pragma_Linker_Alias => -1,
25453 Pragma_Linker_Constructor => -1,
25454 Pragma_Linker_Destructor => -1,
25455 Pragma_Linker_Options => -1,
25456 Pragma_Linker_Section => -1,
25458 Pragma_Lock_Free => -1,
25459 Pragma_Locking_Policy => -1,
25460 Pragma_Long_Float => -1,
25461 Pragma_Loop_Invariant => -1,
25462 Pragma_Loop_Optimize => -1,
25463 Pragma_Loop_Variant => -1,
25464 Pragma_Machine_Attribute => -1,
25466 Pragma_Main_Storage => -1,
25467 Pragma_Memory_Size => -1,
25468 Pragma_No_Return => 0,
25469 Pragma_No_Body => 0,
25470 Pragma_No_Inline => 0,
25471 Pragma_No_Run_Time => -1,
25472 Pragma_No_Strict_Aliasing => -1,
25473 Pragma_Normalize_Scalars => -1,
25474 Pragma_Obsolescent => 0,
25475 Pragma_Optimize => -1,
25476 Pragma_Optimize_Alignment => -1,
25477 Pragma_Overflow_Mode => 0,
25478 Pragma_Overriding_Renamings => 0,
25479 Pragma_Ordered => 0,
25482 Pragma_Part_Of => -1,
25483 Pragma_Partition_Elaboration_Policy => -1,
25484 Pragma_Passive => -1,
25485 Pragma_Persistent_BSS => 0,
25486 Pragma_Polling => -1,
25488 Pragma_Postcondition => -1,
25489 Pragma_Post_Class => -1,
25491 Pragma_Precondition => -1,
25492 Pragma_Predicate => -1,
25493 Pragma_Preelaborable_Initialization => -1,
25494 Pragma_Preelaborate => -1,
25495 Pragma_Pre_Class => -1,
25496 Pragma_Priority => -1,
25497 Pragma_Priority_Specific_Dispatching => -1,
25498 Pragma_Profile => 0,
25499 Pragma_Profile_Warnings => 0,
25500 Pragma_Propagate_Exceptions => -1,
25501 Pragma_Provide_Shift_Operators => -1,
25502 Pragma_Psect_Object => -1,
25504 Pragma_Pure_Function => -1,
25505 Pragma_Queuing_Policy => -1,
25506 Pragma_Rational => -1,
25507 Pragma_Ravenscar => -1,
25508 Pragma_Refined_Depends => -1,
25509 Pragma_Refined_Global => -1,
25510 Pragma_Refined_Post => -1,
25511 Pragma_Refined_State => -1,
25512 Pragma_Relative_Deadline => -1,
25513 Pragma_Remote_Access_Type => -1,
25514 Pragma_Remote_Call_Interface => -1,
25515 Pragma_Remote_Types => -1,
25516 Pragma_Restricted_Run_Time => -1,
25517 Pragma_Restriction_Warnings => -1,
25518 Pragma_Restrictions => -1,
25519 Pragma_Reviewable => -1,
25520 Pragma_Short_Circuit_And_Or => -1,
25521 Pragma_Share_Generic => -1,
25522 Pragma_Shared => -1,
25523 Pragma_Shared_Passive => -1,
25524 Pragma_Short_Descriptors => 0,
25525 Pragma_Simple_Storage_Pool_Type => 0,
25526 Pragma_Source_File_Name => -1,
25527 Pragma_Source_File_Name_Project => -1,
25528 Pragma_Source_Reference => -1,
25529 Pragma_SPARK_Mode => 0,
25530 Pragma_Storage_Size => -1,
25531 Pragma_Storage_Unit => -1,
25532 Pragma_Static_Elaboration_Desired => -1,
25533 Pragma_Stream_Convert => -1,
25534 Pragma_Style_Checks => -1,
25535 Pragma_Subtitle => -1,
25536 Pragma_Suppress => 0,
25537 Pragma_Suppress_Exception_Locations => 0,
25538 Pragma_Suppress_All => -1,
25539 Pragma_Suppress_Debug_Info => 0,
25540 Pragma_Suppress_Initialization => 0,
25541 Pragma_System_Name => -1,
25542 Pragma_Task_Dispatching_Policy => -1,
25543 Pragma_Task_Info => -1,
25544 Pragma_Task_Name => -1,
25545 Pragma_Task_Storage => 0,
25546 Pragma_Test_Case => -1,
25547 Pragma_Thread_Local_Storage => 0,
25548 Pragma_Time_Slice => -1,
25549 Pragma_Title => -1,
25550 Pragma_Type_Invariant => -1,
25551 Pragma_Type_Invariant_Class => -1,
25552 Pragma_Unchecked_Union => 0,
25553 Pragma_Unimplemented_Unit => -1,
25554 Pragma_Universal_Aliasing => -1,
25555 Pragma_Universal_Data => -1,
25556 Pragma_Unmodified => -1,
25557 Pragma_Unreferenced => -1,
25558 Pragma_Unreferenced_Objects => -1,
25559 Pragma_Unreserve_All_Interrupts => -1,
25560 Pragma_Unsuppress => 0,
25561 Pragma_Unevaluated_Use_Of_Old => 0,
25562 Pragma_Use_VADS_Size => -1,
25563 Pragma_Validity_Checks => -1,
25564 Pragma_Volatile => 0,
25565 Pragma_Volatile_Components => 0,
25566 Pragma_Warning_As_Error => -1,
25567 Pragma_Warnings => -1,
25568 Pragma_Weak_External => -1,
25569 Pragma_Wide_Character_Encoding => 0,
25570 Unknown_Pragma => 0);
25572 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
25581 if Nkind (P) /= N_Pragma_Argument_Association then
25585 Id := Get_Pragma_Id (Parent (P));
25586 C := Sig_Flags (Id);
25598 -- For pragma Check, the first argument is not significant,
25599 -- the second and the third (if present) arguments are
25602 when Pragma_Check =>
25604 P = First (Pragma_Argument_Associations (Parent (P)));
25607 raise Program_Error;
25611 A := First (Pragma_Argument_Associations (Parent (P)));
25612 for J in 1 .. C - 1 loop
25620 return A = P; -- is this wrong way round ???
25623 end Is_Non_Significant_Pragma_Reference;
25625 ------------------------------
25626 -- Is_Pragma_String_Literal --
25627 ------------------------------
25629 -- This function returns true if the corresponding pragma argument is a
25630 -- static string expression. These are the only cases in which string
25631 -- literals can appear as pragma arguments. We also allow a string literal
25632 -- as the first argument to pragma Assert (although it will of course
25633 -- always generate a type error).
25635 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
25636 Pragn : constant Node_Id := Parent (Par);
25637 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
25638 Pname : constant Name_Id := Pragma_Name (Pragn);
25644 N := First (Assoc);
25651 if Pname = Name_Assert then
25654 elsif Pname = Name_Export then
25657 elsif Pname = Name_Ident then
25660 elsif Pname = Name_Import then
25663 elsif Pname = Name_Interface_Name then
25666 elsif Pname = Name_Linker_Alias then
25669 elsif Pname = Name_Linker_Section then
25672 elsif Pname = Name_Machine_Attribute then
25675 elsif Pname = Name_Source_File_Name then
25678 elsif Pname = Name_Source_Reference then
25681 elsif Pname = Name_Title then
25684 elsif Pname = Name_Subtitle then
25690 end Is_Pragma_String_Literal;
25692 ---------------------------
25693 -- Is_Private_SPARK_Mode --
25694 ---------------------------
25696 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
25699 (Nkind (N) = N_Pragma
25700 and then Pragma_Name (N) = Name_SPARK_Mode
25701 and then Is_List_Member (N));
25703 -- For pragma SPARK_Mode to be private, it has to appear in the private
25704 -- declarations of a package.
25707 Present (Parent (N))
25708 and then Nkind (Parent (N)) = N_Package_Specification
25709 and then List_Containing (N) = Private_Declarations (Parent (N));
25710 end Is_Private_SPARK_Mode;
25712 -------------------------------------
25713 -- Is_Unconstrained_Or_Tagged_Item --
25714 -------------------------------------
25716 function Is_Unconstrained_Or_Tagged_Item
25717 (Item : Entity_Id) return Boolean
25719 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
25720 -- Determine whether record type Typ has at least one unconstrained
25723 ---------------------------------
25724 -- Has_Unconstrained_Component --
25725 ---------------------------------
25727 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
25731 Comp := First_Component (Typ);
25732 while Present (Comp) loop
25733 if Is_Unconstrained_Or_Tagged_Item (Comp) then
25737 Next_Component (Comp);
25741 end Has_Unconstrained_Component;
25745 Typ : constant Entity_Id := Etype (Item);
25747 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25750 if Is_Tagged_Type (Typ) then
25753 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
25756 elsif Is_Record_Type (Typ) then
25757 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
25760 return Has_Unconstrained_Component (Typ);
25766 end Is_Unconstrained_Or_Tagged_Item;
25768 -----------------------------
25769 -- Is_Valid_Assertion_Kind --
25770 -----------------------------
25772 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
25779 Name_Static_Predicate |
25780 Name_Dynamic_Predicate |
25785 Name_Type_Invariant |
25786 Name_uType_Invariant |
25790 Name_Assert_And_Cut |
25792 Name_Contract_Cases |
25794 Name_Initial_Condition |
25797 Name_Loop_Invariant |
25798 Name_Loop_Variant |
25799 Name_Postcondition |
25800 Name_Precondition |
25802 Name_Refined_Post |
25803 Name_Statement_Assertions => return True;
25805 when others => return False;
25807 end Is_Valid_Assertion_Kind;
25809 -----------------------------------------
25810 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
25811 -----------------------------------------
25813 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
25814 Aspects : constant List_Id := New_List;
25815 Loc : constant Source_Ptr := Sloc (Decl);
25816 Or_Decl : constant Node_Id := Original_Node (Decl);
25818 Original_Aspects : List_Id;
25819 -- To capture global references, a copy of the created aspects must be
25820 -- inserted in the original tree.
25823 Prag_Arg_Ass : Node_Id;
25824 Prag_Id : Pragma_Id;
25827 -- Check for any PPC pragmas that appear within Decl
25829 Prag := Next (Decl);
25830 while Nkind (Prag) = N_Pragma loop
25831 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
25834 when Pragma_Postcondition | Pragma_Precondition =>
25835 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
25837 -- Make an aspect from any PPC pragma
25839 Append_To (Aspects,
25840 Make_Aspect_Specification (Loc,
25842 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
25844 Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
25846 -- Generate the analysis information in the pragma expression
25847 -- and then set the pragma node analyzed to avoid any further
25850 Analyze (Expression (Prag_Arg_Ass));
25851 Set_Analyzed (Prag, True);
25853 when others => null;
25859 -- Set all new aspects into the generic declaration node
25861 if Is_Non_Empty_List (Aspects) then
25863 -- Create the list of aspects to be inserted in the original tree
25865 Original_Aspects := Copy_Separate_List (Aspects);
25867 -- Check if Decl already has aspects
25869 -- Attach the new lists of aspects to both the generic copy and the
25872 if Has_Aspects (Decl) then
25873 Append_List (Aspects, Aspect_Specifications (Decl));
25874 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
25877 Set_Parent (Aspects, Decl);
25878 Set_Aspect_Specifications (Decl, Aspects);
25879 Set_Parent (Original_Aspects, Or_Decl);
25880 Set_Aspect_Specifications (Or_Decl, Original_Aspects);
25883 end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
25885 -------------------------
25886 -- Preanalyze_CTC_Args --
25887 -------------------------
25889 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
25891 -- Preanalyze the boolean expressions, we treat these as spec
25892 -- expressions (i.e. similar to a default expression).
25894 if Present (Arg_Req) then
25895 Preanalyze_Assert_Expression
25896 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
25898 -- In ASIS mode, for a pragma generated from a source aspect, also
25899 -- analyze the original aspect expression.
25901 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
25902 Preanalyze_Assert_Expression
25903 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
25907 if Present (Arg_Ens) then
25908 Preanalyze_Assert_Expression
25909 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
25911 -- In ASIS mode, for a pragma generated from a source aspect, also
25912 -- analyze the original aspect expression.
25914 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
25915 Preanalyze_Assert_Expression
25916 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
25919 end Preanalyze_CTC_Args;
25921 --------------------------------------
25922 -- Process_Compilation_Unit_Pragmas --
25923 --------------------------------------
25925 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
25927 -- A special check for pragma Suppress_All, a very strange DEC pragma,
25928 -- strange because it comes at the end of the unit. Rational has the
25929 -- same name for a pragma, but treats it as a program unit pragma, In
25930 -- GNAT we just decide to allow it anywhere at all. If it appeared then
25931 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
25932 -- node, and we insert a pragma Suppress (All_Checks) at the start of
25933 -- the context clause to ensure the correct processing.
25935 if Has_Pragma_Suppress_All (N) then
25936 Prepend_To (Context_Items (N),
25937 Make_Pragma (Sloc (N),
25938 Chars => Name_Suppress,
25939 Pragma_Argument_Associations => New_List (
25940 Make_Pragma_Argument_Association (Sloc (N),
25941 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
25944 -- Nothing else to do at the current time
25946 end Process_Compilation_Unit_Pragmas;
25948 ------------------------------------
25949 -- Record_Possible_Body_Reference --
25950 ------------------------------------
25952 procedure Record_Possible_Body_Reference
25953 (State_Id : Entity_Id;
25957 Spec_Id : Entity_Id;
25960 -- Ensure that we are dealing with a reference to a state
25962 pragma Assert (Ekind (State_Id) = E_Abstract_State);
25964 -- Climb the tree starting from the reference looking for a package body
25965 -- whose spec declares the referenced state. This criteria automatically
25966 -- excludes references in package specs which are legal. Note that it is
25967 -- not wise to emit an error now as the package body may lack pragma
25968 -- Refined_State or the referenced state may not be mentioned in the
25969 -- refinement. This approach avoids the generation of misleading errors.
25972 while Present (Context) loop
25973 if Nkind (Context) = N_Package_Body then
25974 Spec_Id := Corresponding_Spec (Context);
25976 if Present (Abstract_States (Spec_Id))
25977 and then Contains (Abstract_States (Spec_Id), State_Id)
25979 if No (Body_References (State_Id)) then
25980 Set_Body_References (State_Id, New_Elmt_List);
25983 Append_Elmt (Ref, Body_References (State_Id));
25988 Context := Parent (Context);
25990 end Record_Possible_Body_Reference;
25992 ------------------------------
25993 -- Relocate_Pragmas_To_Body --
25994 ------------------------------
25996 procedure Relocate_Pragmas_To_Body
25997 (Subp_Body : Node_Id;
25998 Target_Body : Node_Id := Empty)
26000 procedure Relocate_Pragma (Prag : Node_Id);
26001 -- Remove a single pragma from its current list and add it to the
26002 -- declarations of the proper body (either Subp_Body or Target_Body).
26004 ---------------------
26005 -- Relocate_Pragma --
26006 ---------------------
26008 procedure Relocate_Pragma (Prag : Node_Id) is
26013 -- When subprogram stubs or expression functions are involves, the
26014 -- destination declaration list belongs to the proper body.
26016 if Present (Target_Body) then
26017 Target := Target_Body;
26019 Target := Subp_Body;
26022 Decls := Declarations (Target);
26026 Set_Declarations (Target, Decls);
26029 -- Unhook the pragma from its current list
26032 Prepend (Prag, Decls);
26033 end Relocate_Pragma;
26037 Body_Id : constant Entity_Id :=
26038 Defining_Unit_Name (Specification (Subp_Body));
26039 Next_Stmt : Node_Id;
26042 -- Start of processing for Relocate_Pragmas_To_Body
26045 -- Do not process a body that comes from a separate unit as no construct
26046 -- can possibly follow it.
26048 if not Is_List_Member (Subp_Body) then
26051 -- Do not relocate pragmas that follow a stub if the stub does not have
26054 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
26055 and then No (Target_Body)
26059 -- Do not process internally generated routine _Postconditions
26061 elsif Ekind (Body_Id) = E_Procedure
26062 and then Chars (Body_Id) = Name_uPostconditions
26067 -- Look at what is following the body. We are interested in certain kind
26068 -- of pragmas (either from source or byproducts of expansion) that can
26069 -- apply to a body [stub].
26071 Stmt := Next (Subp_Body);
26072 while Present (Stmt) loop
26074 -- Preserve the following statement for iteration purposes due to a
26075 -- possible relocation of a pragma.
26077 Next_Stmt := Next (Stmt);
26079 -- Move a candidate pragma following the body to the declarations of
26082 if Nkind (Stmt) = N_Pragma
26083 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
26085 Relocate_Pragma (Stmt);
26087 -- Skip internally generated code
26089 elsif not Comes_From_Source (Stmt) then
26092 -- No candidate pragmas are available for relocation
26100 end Relocate_Pragmas_To_Body;
26102 -------------------
26103 -- Resolve_State --
26104 -------------------
26106 procedure Resolve_State (N : Node_Id) is
26111 if Is_Entity_Name (N) and then Present (Entity (N)) then
26112 Func := Entity (N);
26114 -- Handle overloading of state names by functions. Traverse the
26115 -- homonym chain looking for an abstract state.
26117 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
26118 State := Homonym (Func);
26119 while Present (State) loop
26121 -- Resolve the overloading by setting the proper entity of the
26122 -- reference to that of the state.
26124 if Ekind (State) = E_Abstract_State then
26125 Set_Etype (N, Standard_Void_Type);
26126 Set_Entity (N, State);
26127 Set_Associated_Node (N, State);
26131 State := Homonym (State);
26134 -- A function can never act as a state. If the homonym chain does
26135 -- not contain a corresponding state, then something went wrong in
26136 -- the overloading mechanism.
26138 raise Program_Error;
26143 ----------------------------
26144 -- Rewrite_Assertion_Kind --
26145 ----------------------------
26147 procedure Rewrite_Assertion_Kind (N : Node_Id) is
26151 if Nkind (N) = N_Attribute_Reference
26152 and then Attribute_Name (N) = Name_Class
26153 and then Nkind (Prefix (N)) = N_Identifier
26155 case Chars (Prefix (N)) is
26160 when Name_Type_Invariant =>
26161 Nam := Name_uType_Invariant;
26162 when Name_Invariant =>
26163 Nam := Name_uInvariant;
26168 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
26170 end Rewrite_Assertion_Kind;
26178 Dummy := Dummy + 1;
26181 --------------------------------
26182 -- Set_Encoded_Interface_Name --
26183 --------------------------------
26185 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
26186 Str : constant String_Id := Strval (S);
26187 Len : constant Int := String_Length (Str);
26192 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
26195 -- Stores encoded value of character code CC. The encoding we use an
26196 -- underscore followed by four lower case hex digits.
26202 procedure Encode is
26204 Store_String_Char (Get_Char_Code ('_'));
26206 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
26208 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
26210 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
26212 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
26215 -- Start of processing for Set_Encoded_Interface_Name
26218 -- If first character is asterisk, this is a link name, and we leave it
26219 -- completely unmodified. We also ignore null strings (the latter case
26220 -- happens only in error cases) and no encoding should occur for Java or
26221 -- AAMP interface names.
26224 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
26225 or else VM_Target /= No_VM
26226 or else AAMP_On_Target
26228 Set_Interface_Name (E, S);
26233 CC := Get_String_Char (Str, J);
26235 exit when not In_Character_Range (CC);
26237 C := Get_Character (CC);
26239 exit when C /= '_' and then C /= '$'
26240 and then C not in '0' .. '9'
26241 and then C not in 'a' .. 'z'
26242 and then C not in 'A' .. 'Z';
26245 Set_Interface_Name (E, S);
26253 -- Here we need to encode. The encoding we use as follows:
26254 -- three underscores + four hex digits (lower case)
26258 for J in 1 .. String_Length (Str) loop
26259 CC := Get_String_Char (Str, J);
26261 if not In_Character_Range (CC) then
26264 C := Get_Character (CC);
26266 if C = '_' or else C = '$'
26267 or else C in '0' .. '9'
26268 or else C in 'a' .. 'z'
26269 or else C in 'A' .. 'Z'
26271 Store_String_Char (CC);
26278 Set_Interface_Name (E,
26279 Make_String_Literal (Sloc (S),
26280 Strval => End_String));
26282 end Set_Encoded_Interface_Name;
26284 -------------------
26285 -- Set_Unit_Name --
26286 -------------------
26288 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
26293 if Nkind (N) = N_Identifier
26294 and then Nkind (With_Item) = N_Identifier
26296 Set_Entity (N, Entity (With_Item));
26298 elsif Nkind (N) = N_Selected_Component then
26299 Change_Selected_Component_To_Expanded_Name (N);
26300 Set_Entity (N, Entity (With_Item));
26301 Set_Entity (Selector_Name (N), Entity (N));
26303 Pref := Prefix (N);
26304 Scop := Scope (Entity (N));
26305 while Nkind (Pref) = N_Selected_Component loop
26306 Change_Selected_Component_To_Expanded_Name (Pref);
26307 Set_Entity (Selector_Name (Pref), Scop);
26308 Set_Entity (Pref, Scop);
26309 Pref := Prefix (Pref);
26310 Scop := Scope (Scop);
26313 Set_Entity (Pref, Scop);