1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with GNAT_CUDA; use GNAT_CUDA;
48 with Gnatvsn; use Gnatvsn;
50 with Lib.Writ; use Lib.Writ;
51 with Lib.Xref; use Lib.Xref;
52 with Namet.Sp; use Namet.Sp;
53 with Nlists; use Nlists;
54 with Nmake; use Nmake;
55 with Output; use Output;
56 with Par_SCO; use Par_SCO;
57 with Restrict; use Restrict;
58 with Rident; use Rident;
59 with Rtsfind; use Rtsfind;
61 with Sem_Aux; use Sem_Aux;
62 with Sem_Ch3; use Sem_Ch3;
63 with Sem_Ch6; use Sem_Ch6;
64 with Sem_Ch8; use Sem_Ch8;
65 with Sem_Ch12; use Sem_Ch12;
66 with Sem_Ch13; use Sem_Ch13;
67 with Sem_Disp; use Sem_Disp;
68 with Sem_Dist; use Sem_Dist;
69 with Sem_Elab; use Sem_Elab;
70 with Sem_Elim; use Sem_Elim;
71 with Sem_Eval; use Sem_Eval;
72 with Sem_Intr; use Sem_Intr;
73 with Sem_Mech; use Sem_Mech;
74 with Sem_Res; use Sem_Res;
75 with Sem_Type; use Sem_Type;
76 with Sem_Util; use Sem_Util;
77 with Sem_Warn; use Sem_Warn;
78 with Stand; use Stand;
79 with Sinfo; use Sinfo;
80 with Sinfo.CN; use Sinfo.CN;
81 with Sinput; use Sinput;
82 with Stringt; use Stringt;
83 with Stylesw; use Stylesw;
85 with Targparm; use Targparm;
86 with Tbuild; use Tbuild;
88 with Uintp; use Uintp;
89 with Uname; use Uname;
90 with Urealp; use Urealp;
91 with Validsw; use Validsw;
92 with Warnsw; use Warnsw;
94 with System.Case_Util;
96 package body Sem_Prag is
98 ----------------------------------------------
99 -- Common Handling of Import-Export Pragmas --
100 ----------------------------------------------
102 -- In the following section, a number of Import_xxx and Export_xxx pragmas
103 -- are defined by GNAT. These are compatible with the DEC pragmas of the
104 -- same name, and all have the following common form and processing:
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
112 -- [Internal =>] LOCAL_NAME
113 -- [, [External =>] EXTERNAL_SYMBOL]
114 -- [, other optional parameters ]);
116 -- EXTERNAL_SYMBOL ::=
118 -- | static_string_EXPRESSION
120 -- The internal LOCAL_NAME designates the entity that is imported or
121 -- exported, and must refer to an entity in the current declarative
122 -- part (as required by the rules for LOCAL_NAME).
124 -- The external linker name is designated by the External parameter if
125 -- given, or the Internal parameter if not (if there is no External
126 -- parameter, the External parameter is a copy of the Internal name).
128 -- If the External parameter is given as a string, then this string is
129 -- treated as an external name (exactly as though it had been given as an
130 -- External_Name parameter for a normal Import pragma).
132 -- If the External parameter is given as an identifier (or there is no
133 -- External parameter, so that the Internal identifier is used), then
134 -- the external name is the characters of the identifier, translated
135 -- to all lower case letters.
137 -- Note: the external name specified or implied by any of these special
138 -- Import_xxx or Export_xxx pragmas override an external or link name
139 -- specified in a previous Import or Export pragma.
141 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
142 -- named notation, following the standard rules for subprogram calls, i.e.
143 -- parameters can be given in any order if named notation is used, and
144 -- positional and named notation can be mixed, subject to the rule that all
145 -- positional parameters must appear first.
147 -- Note: All these pragmas are implemented exactly following the DEC design
148 -- and implementation and are intended to be fully compatible with the use
149 -- of these pragmas in the DEC Ada compiler.
151 --------------------------------------------
152 -- Checking for Duplicated External Names --
153 --------------------------------------------
155 -- It is suspicious if two separate Export pragmas use the same external
156 -- name. The following table is used to diagnose this situation so that
157 -- an appropriate warning can be issued.
159 -- The Node_Id stored is for the N_String_Literal node created to hold
160 -- the value of the external name. The Sloc of this node is used to
161 -- cross-reference the location of the duplication.
163 package Externals is new Table.Table (
164 Table_Component_Type => Node_Id,
165 Table_Index_Type => Int,
166 Table_Low_Bound => 0,
167 Table_Initial => 100,
168 Table_Increment => 100,
169 Table_Name => "Name_Externals");
171 -------------------------------------
172 -- Local Subprograms and Variables --
173 -------------------------------------
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 procedure Analyze_Part_Of
187 Encap_Id : out Entity_Id;
188 Legal : out Boolean);
189 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
190 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
191 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
192 -- package instantiation. Encap denotes the encapsulating state or single
193 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
194 -- the indicator is legal.
196 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
197 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
198 -- Query whether a particular item appears in a mixed list of nodes and
199 -- entities. It is assumed that all nodes in the list have entities.
201 procedure Check_Postcondition_Use_In_Inlined_Subprogram
203 Spec_Id : Entity_Id);
204 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
205 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
206 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
207 -- and assertions are enabled.
209 procedure Check_State_And_Constituent_Use
213 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
214 -- Global and Initializes. Determine whether a state from list States and a
215 -- corresponding constituent from list Constits (if any) appear in the same
216 -- context denoted by Context. If this is the case, emit an error.
218 procedure Contract_Freeze_Error
219 (Contract_Id : Entity_Id;
220 Freeze_Id : Entity_Id);
221 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
222 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
223 -- of a body which caused contract freezing and Contract_Id denotes the
224 -- entity of the affected contstruct.
226 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
227 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
228 -- Prag that duplicates previous pragma Prev.
230 function Find_Encapsulating_State
232 Constit_Id : Entity_Id) return Entity_Id;
233 -- Given the entity of a constituent Constit_Id, find the corresponding
234 -- encapsulating state which appears in States. The routine returns Empty
235 -- if no such state is found.
237 function Find_Related_Context
239 Do_Checks : Boolean := False) return Node_Id;
240 -- Subsidiary to the analysis of pragmas
243 -- Constant_After_Elaboration
247 -- Find the first source declaration or statement found while traversing
248 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
249 -- set, the routine reports duplicate pragmas. The routine returns Empty
250 -- when reaching the start of the node chain.
252 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
253 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
254 -- original one, following the renaming chain) is returned. Otherwise the
255 -- entity is returned unchanged. Should be in Einfo???
257 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
258 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
259 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
260 -- value of type SPARK_Mode_Type.
262 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
263 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
264 -- Determine whether dependency clause Clause is surrounded by extra
265 -- parentheses. If this is the case, issue an error message.
267 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
268 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
269 -- pragma Depends. Determine whether the type of dependency item Item is
270 -- tagged, unconstrained array, unconstrained record or a record with at
271 -- least one unconstrained component.
273 procedure Record_Possible_Body_Reference
274 (State_Id : Entity_Id;
276 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
277 -- Global. Given an abstract state denoted by State_Id and a reference Ref
278 -- to it, determine whether the reference appears in a package body that
279 -- will eventually refine the state. If this is the case, record the
280 -- reference for future checks (see Analyze_Refined_State_In_Decls).
282 procedure Resolve_State (N : Node_Id);
283 -- Handle the overloading of state names by functions. When N denotes a
284 -- function, this routine finds the corresponding state and sets the entity
285 -- of N to that of the state.
287 procedure Rewrite_Assertion_Kind
289 From_Policy : Boolean := False);
290 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
291 -- then it is rewritten as an identifier with the corresponding special
292 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
293 -- and Check_Policy. If the names are Precondition or Postcondition, this
294 -- combination is deprecated in favor of Assertion_Policy and Ada2012
295 -- Aspect names. The parameter From_Policy indicates that the pragma
296 -- is the old non-standard Check_Policy and not a rewritten pragma.
298 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
299 -- Place semantic information on the argument of an Elaborate/Elaborate_All
300 -- pragma. Entity name for unit and its parents is taken from item in
301 -- previous with_clause that mentions the unit.
303 procedure Validate_Compile_Time_Warning_Or_Error
306 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
307 -- pragma N. Called when the pragma is processed as part of its regular
308 -- analysis but also called after calling the back end to validate these
309 -- pragmas for size and alignment appropriateness.
311 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
312 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
313 -- expression is not known at compile time during the front end. This
314 -- procedure makes an entry in a table. The actual checking is performed by
315 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
318 Dummy : Integer := 0;
319 pragma Volatile (Dummy);
320 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
323 pragma No_Inline (ip);
324 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
325 -- is just to help debugging the front end. If a pragma Inspection_Point
326 -- is added to a source program, then breaking on ip will get you to that
327 -- point in the program.
330 pragma No_Inline (rv);
331 -- This is a dummy function called by the processing for pragma Reviewable.
332 -- It is there for assisting front end debugging. By placing a Reviewable
333 -- pragma in the source program, a breakpoint on rv catches this place in
334 -- the source, allowing convenient stepping to the point of interest.
336 ------------------------------------------------------
337 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
338 ------------------------------------------------------
340 -- The following table collects pragmas Compile_Time_Error and Compile_
341 -- Time_Warning for validation. Entries are made by calls to subprogram
342 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
343 -- Validate_Compile_Time_Warning_Errors does the actual error checking
344 -- and posting of warning and error messages. The reason for this delayed
345 -- processing is to take advantage of back-annotations of attributes size
346 -- and alignment values performed by the back end.
348 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
349 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
350 -- will already have modified all Sloc values if the -gnatD option is set.
352 type CTWE_Entry is record
354 -- Source location used in warnings and error messages
357 -- Pragma Compile_Time_Error or Compile_Time_Warning
360 -- The scope which encloses the pragma
363 package Compile_Time_Warnings_Errors is new Table.Table (
364 Table_Component_Type => CTWE_Entry,
365 Table_Index_Type => Int,
366 Table_Low_Bound => 1,
368 Table_Increment => 200,
369 Table_Name => "Compile_Time_Warnings_Errors");
371 -------------------------------
372 -- Adjust_External_Name_Case --
373 -------------------------------
375 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
379 -- Adjust case of literal if required
381 if Opt.External_Name_Exp_Casing = As_Is then
385 -- Copy existing string
391 for J in 1 .. String_Length (Strval (N)) loop
392 CC := Get_String_Char (Strval (N), J);
394 if Opt.External_Name_Exp_Casing = Uppercase
395 and then CC >= Get_Char_Code ('a')
396 and then CC <= Get_Char_Code ('z')
398 Store_String_Char (CC - 32);
400 elsif Opt.External_Name_Exp_Casing = Lowercase
401 and then CC >= Get_Char_Code ('A')
402 and then CC <= Get_Char_Code ('Z')
404 Store_String_Char (CC + 32);
407 Store_String_Char (CC);
412 Make_String_Literal (Sloc (N),
413 Strval => End_String);
415 end Adjust_External_Name_Case;
417 -----------------------------------------
418 -- Analyze_Contract_Cases_In_Decl_Part --
419 -----------------------------------------
421 -- WARNING: This routine manages Ghost regions. Return statements must be
422 -- replaced by gotos which jump to the end of the routine and restore the
425 procedure Analyze_Contract_Cases_In_Decl_Part
427 Freeze_Id : Entity_Id := Empty)
429 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
430 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
432 Others_Seen : Boolean := False;
433 -- This flag is set when an "others" choice is encountered. It is used
434 -- to detect multiple illegal occurrences of "others".
436 procedure Analyze_Contract_Case (CCase : Node_Id);
437 -- Verify the legality of a single contract case
439 ---------------------------
440 -- Analyze_Contract_Case --
441 ---------------------------
443 procedure Analyze_Contract_Case (CCase : Node_Id) is
444 Case_Guard : Node_Id;
447 Extra_Guard : Node_Id;
450 if Nkind (CCase) = N_Component_Association then
451 Case_Guard := First (Choices (CCase));
452 Conseq := Expression (CCase);
454 -- Each contract case must have exactly one case guard
456 Extra_Guard := Next (Case_Guard);
458 if Present (Extra_Guard) then
460 ("contract case must have exactly one case guard",
464 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
466 if Nkind (Case_Guard) = N_Others_Choice then
469 ("only one others choice allowed in contract cases",
475 elsif Others_Seen then
477 ("others must be the last choice in contract cases", N);
480 -- Preanalyze the case guard and consequence
482 if Nkind (Case_Guard) /= N_Others_Choice then
483 Errors := Serious_Errors_Detected;
484 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
486 -- Emit a clarification message when the case guard contains
487 -- at least one undefined reference, possibly due to contract
490 if Errors /= Serious_Errors_Detected
491 and then Present (Freeze_Id)
492 and then Has_Undefined_Reference (Case_Guard)
494 Contract_Freeze_Error (Spec_Id, Freeze_Id);
498 Errors := Serious_Errors_Detected;
499 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
501 -- Emit a clarification message when the consequence contains
502 -- at least one undefined reference, possibly due to contract
505 if Errors /= Serious_Errors_Detected
506 and then Present (Freeze_Id)
507 and then Has_Undefined_Reference (Conseq)
509 Contract_Freeze_Error (Spec_Id, Freeze_Id);
512 -- The contract case is malformed
515 Error_Msg_N ("wrong syntax in contract case", CCase);
517 end Analyze_Contract_Case;
521 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
523 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
524 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
525 -- Save the Ghost-related attributes to restore on exit
528 Restore_Scope : Boolean := False;
530 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
533 -- Do not analyze the pragma multiple times
535 if Is_Analyzed_Pragma (N) then
539 -- Set the Ghost mode in effect from the pragma. Due to the delayed
540 -- analysis of the pragma, the Ghost mode at point of declaration and
541 -- point of analysis may not necessarily be the same. Use the mode in
542 -- effect at the point of declaration.
546 -- Single and multiple contract cases must appear in aggregate form. If
547 -- this is not the case, then either the parser or the analysis of the
548 -- pragma failed to produce an aggregate.
550 pragma Assert (Nkind (CCases) = N_Aggregate);
552 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
554 if Present (Component_Associations (CCases))
555 and then No (Expressions (CCases))
558 -- Ensure that the formal parameters are visible when analyzing all
559 -- clauses. This falls out of the general rule of aspects pertaining
560 -- to subprogram declarations.
562 if not In_Open_Scopes (Spec_Id) then
563 Restore_Scope := True;
564 Push_Scope (Spec_Id);
566 if Is_Generic_Subprogram (Spec_Id) then
567 Install_Generic_Formals (Spec_Id);
569 Install_Formals (Spec_Id);
573 CCase := First (Component_Associations (CCases));
574 while Present (CCase) loop
575 Analyze_Contract_Case (CCase);
579 if Restore_Scope then
583 -- Currently it is not possible to inline pre/postconditions on a
584 -- subprogram subject to pragma Inline_Always.
586 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
588 -- Otherwise the pragma is illegal
591 Error_Msg_N ("wrong syntax for contract cases", N);
594 Set_Is_Analyzed_Pragma (N);
596 Restore_Ghost_Region (Saved_GM, Saved_IGR);
597 end Analyze_Contract_Cases_In_Decl_Part;
599 ----------------------------------
600 -- Analyze_Depends_In_Decl_Part --
601 ----------------------------------
603 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
604 Loc : constant Source_Ptr := Sloc (N);
605 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
606 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
608 All_Inputs_Seen : Elist_Id := No_Elist;
609 -- A list containing the entities of all the inputs processed so far.
610 -- The list is populated with unique entities because the same input
611 -- may appear in multiple input lists.
613 All_Outputs_Seen : Elist_Id := No_Elist;
614 -- A list containing the entities of all the outputs processed so far.
615 -- The list is populated with unique entities because output items are
616 -- unique in a dependence relation.
618 Constits_Seen : Elist_Id := No_Elist;
619 -- A list containing the entities of all constituents processed so far.
620 -- It aids in detecting illegal usage of a state and a corresponding
621 -- constituent in pragma [Refinde_]Depends.
623 Global_Seen : Boolean := False;
624 -- A flag set when pragma Global has been processed
626 Null_Output_Seen : Boolean := False;
627 -- A flag used to track the legality of a null output
629 Result_Seen : Boolean := False;
630 -- A flag set when Spec_Id'Result is processed
632 States_Seen : Elist_Id := No_Elist;
633 -- A list containing the entities of all states processed so far. It
634 -- helps in detecting illegal usage of a state and a corresponding
635 -- constituent in pragma [Refined_]Depends.
637 Subp_Inputs : Elist_Id := No_Elist;
638 Subp_Outputs : Elist_Id := No_Elist;
639 -- Two lists containing the full set of inputs and output of the related
640 -- subprograms. Note that these lists contain both nodes and entities.
642 Task_Input_Seen : Boolean := False;
643 Task_Output_Seen : Boolean := False;
644 -- Flags used to track the implicit dependence of a task unit on itself
646 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
647 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
648 -- to the name buffer. The individual kinds are as follows:
649 -- E_Abstract_State - "state"
650 -- E_Constant - "constant"
651 -- E_Generic_In_Out_Parameter - "generic parameter"
652 -- E_Generic_In_Parameter - "generic parameter"
653 -- E_In_Parameter - "parameter"
654 -- E_In_Out_Parameter - "parameter"
655 -- E_Loop_Parameter - "loop parameter"
656 -- E_Out_Parameter - "parameter"
657 -- E_Protected_Type - "current instance of protected type"
658 -- E_Task_Type - "current instance of task type"
659 -- E_Variable - "global"
661 procedure Analyze_Dependency_Clause
664 -- Verify the legality of a single dependency clause. Flag Is_Last
665 -- denotes whether Clause is the last clause in the relation.
667 procedure Check_Function_Return;
668 -- Verify that Funtion'Result appears as one of the outputs
669 -- (SPARK RM 6.1.5(10)).
676 -- Ensure that an item fulfills its designated input and/or output role
677 -- as specified by pragma Global (if any) or the enclosing context. If
678 -- this is not the case, emit an error. Item and Item_Id denote the
679 -- attributes of an item. Flag Is_Input should be set when item comes
680 -- from an input list. Flag Self_Ref should be set when the item is an
681 -- output and the dependency clause has operator "+".
683 procedure Check_Usage
684 (Subp_Items : Elist_Id;
685 Used_Items : Elist_Id;
687 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
688 -- error if this is not the case.
690 procedure Normalize_Clause (Clause : Node_Id);
691 -- Remove a self-dependency "+" from the input list of a clause
693 -----------------------------
694 -- Add_Item_To_Name_Buffer --
695 -----------------------------
697 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
699 if Ekind (Item_Id) = E_Abstract_State then
700 Add_Str_To_Name_Buffer ("state");
702 elsif Ekind (Item_Id) = E_Constant then
703 Add_Str_To_Name_Buffer ("constant");
705 elsif Ekind (Item_Id) in
706 E_Generic_In_Out_Parameter | E_Generic_In_Parameter
708 Add_Str_To_Name_Buffer ("generic parameter");
710 elsif Is_Formal (Item_Id) then
711 Add_Str_To_Name_Buffer ("parameter");
713 elsif Ekind (Item_Id) = E_Loop_Parameter then
714 Add_Str_To_Name_Buffer ("loop parameter");
716 elsif Ekind (Item_Id) = E_Protected_Type
717 or else Is_Single_Protected_Object (Item_Id)
719 Add_Str_To_Name_Buffer ("current instance of protected type");
721 elsif Ekind (Item_Id) = E_Task_Type
722 or else Is_Single_Task_Object (Item_Id)
724 Add_Str_To_Name_Buffer ("current instance of task type");
726 elsif Ekind (Item_Id) = E_Variable then
727 Add_Str_To_Name_Buffer ("global");
729 -- The routine should not be called with non-SPARK items
734 end Add_Item_To_Name_Buffer;
736 -------------------------------
737 -- Analyze_Dependency_Clause --
738 -------------------------------
740 procedure Analyze_Dependency_Clause
744 procedure Analyze_Input_List (Inputs : Node_Id);
745 -- Verify the legality of a single input list
747 procedure Analyze_Input_Output
752 Seen : in out Elist_Id;
753 Null_Seen : in out Boolean;
754 Non_Null_Seen : in out Boolean);
755 -- Verify the legality of a single input or output item. Flag
756 -- Is_Input should be set whenever Item is an input, False when it
757 -- denotes an output. Flag Self_Ref should be set when the item is an
758 -- output and the dependency clause has a "+". Flag Top_Level should
759 -- be set whenever Item appears immediately within an input or output
760 -- list. Seen is a collection of all abstract states, objects and
761 -- formals processed so far. Flag Null_Seen denotes whether a null
762 -- input or output has been encountered. Flag Non_Null_Seen denotes
763 -- whether a non-null input or output has been encountered.
765 ------------------------
766 -- Analyze_Input_List --
767 ------------------------
769 procedure Analyze_Input_List (Inputs : Node_Id) is
770 Inputs_Seen : Elist_Id := No_Elist;
771 -- A list containing the entities of all inputs that appear in the
772 -- current input list.
774 Non_Null_Input_Seen : Boolean := False;
775 Null_Input_Seen : Boolean := False;
776 -- Flags used to check the legality of an input list
781 -- Multiple inputs appear as an aggregate
783 if Nkind (Inputs) = N_Aggregate then
784 if Present (Component_Associations (Inputs)) then
786 ("nested dependency relations not allowed", Inputs);
788 elsif Present (Expressions (Inputs)) then
789 Input := First (Expressions (Inputs));
790 while Present (Input) loop
797 Null_Seen => Null_Input_Seen,
798 Non_Null_Seen => Non_Null_Input_Seen);
803 -- Syntax error, always report
806 Error_Msg_N ("malformed input dependency list", Inputs);
809 -- Process a solitary input
818 Null_Seen => Null_Input_Seen,
819 Non_Null_Seen => Non_Null_Input_Seen);
822 -- Detect an illegal dependency clause of the form
826 if Null_Output_Seen and then Null_Input_Seen then
828 ("null dependency clause cannot have a null input list",
831 end Analyze_Input_List;
833 --------------------------
834 -- Analyze_Input_Output --
835 --------------------------
837 procedure Analyze_Input_Output
842 Seen : in out Elist_Id;
843 Null_Seen : in out Boolean;
844 Non_Null_Seen : in out Boolean)
846 procedure Current_Task_Instance_Seen;
847 -- Set the appropriate global flag when the current instance of a
848 -- task unit is encountered.
850 --------------------------------
851 -- Current_Task_Instance_Seen --
852 --------------------------------
854 procedure Current_Task_Instance_Seen is
857 Task_Input_Seen := True;
859 Task_Output_Seen := True;
861 end Current_Task_Instance_Seen;
865 Is_Output : constant Boolean := not Is_Input;
869 -- Start of processing for Analyze_Input_Output
872 -- Multiple input or output items appear as an aggregate
874 if Nkind (Item) = N_Aggregate then
875 if not Top_Level then
876 SPARK_Msg_N ("nested grouping of items not allowed", Item);
878 elsif Present (Component_Associations (Item)) then
880 ("nested dependency relations not allowed", Item);
882 -- Recursively analyze the grouped items
884 elsif Present (Expressions (Item)) then
885 Grouped := First (Expressions (Item));
886 while Present (Grouped) loop
889 Is_Input => Is_Input,
890 Self_Ref => Self_Ref,
893 Null_Seen => Null_Seen,
894 Non_Null_Seen => Non_Null_Seen);
899 -- Syntax error, always report
902 Error_Msg_N ("malformed dependency list", Item);
905 -- Process attribute 'Result in the context of a dependency clause
907 elsif Is_Attribute_Result (Item) then
908 Non_Null_Seen := True;
912 -- Attribute 'Result is allowed to appear on the output side of
913 -- a dependency clause (SPARK RM 6.1.5(6)).
916 SPARK_Msg_N ("function result cannot act as input", Item);
920 ("cannot mix null and non-null dependency items", Item);
926 -- Detect multiple uses of null in a single dependency list or
927 -- throughout the whole relation. Verify the placement of a null
928 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
930 elsif Nkind (Item) = N_Null then
933 ("multiple null dependency relations not allowed", Item);
935 elsif Non_Null_Seen then
937 ("cannot mix null and non-null dependency items", Item);
945 ("null output list must be the last clause in a "
946 & "dependency relation", Item);
948 -- Catch a useless dependence of the form:
953 ("useless dependence, null depends on itself", Item);
961 Non_Null_Seen := True;
964 SPARK_Msg_N ("cannot mix null and non-null items", Item);
968 Resolve_State (Item);
970 -- Find the entity of the item. If this is a renaming, climb
971 -- the renaming chain to reach the root object. Renamings of
972 -- non-entire objects do not yield an entity (Empty).
974 Item_Id := Entity_Of (Item);
976 if Present (Item_Id) then
980 if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
983 -- Current instances of concurrent types
985 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
990 Ekind (Item_Id) in E_Generic_In_Out_Parameter
991 | E_Generic_In_Parameter
999 Ekind (Item_Id) in E_Abstract_State | E_Variable
1001 -- A [generic] function is not allowed to have Output
1002 -- items in its dependency relations. Note that "null"
1003 -- and attribute 'Result are still valid items.
1005 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1006 and then not Is_Input
1009 ("output item is not applicable to function", Item);
1012 -- The item denotes a concurrent type. Note that single
1013 -- protected/task types are not considered here because
1014 -- they behave as objects in the context of pragma
1015 -- [Refined_]Depends.
1017 if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
1019 -- This use is legal as long as the concurrent type is
1020 -- the current instance of an enclosing type.
1022 if Is_CCT_Instance (Item_Id, Spec_Id) then
1024 -- The dependence of a task unit on itself is
1025 -- implicit and may or may not be explicitly
1026 -- specified (SPARK RM 6.1.4).
1028 if Ekind (Item_Id) = E_Task_Type then
1029 Current_Task_Instance_Seen;
1032 -- Otherwise this is not the current instance
1036 ("invalid use of subtype mark in dependency "
1037 & "relation", Item);
1040 -- The dependency of a task unit on itself is implicit
1041 -- and may or may not be explicitly specified
1042 -- (SPARK RM 6.1.4).
1044 elsif Is_Single_Task_Object (Item_Id)
1045 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1047 Current_Task_Instance_Seen;
1050 -- Ensure that the item fulfills its role as input and/or
1051 -- output as specified by pragma Global or the enclosing
1054 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1056 -- Detect multiple uses of the same state, variable or
1057 -- formal parameter. If this is not the case, add the
1058 -- item to the list of processed relations.
1060 if Contains (Seen, Item_Id) then
1062 ("duplicate use of item &", Item, Item_Id);
1064 Append_New_Elmt (Item_Id, Seen);
1067 -- Detect illegal use of an input related to a null
1068 -- output. Such input items cannot appear in other
1069 -- input lists (SPARK RM 6.1.5(13)).
1072 and then Null_Output_Seen
1073 and then Contains (All_Inputs_Seen, Item_Id)
1076 ("input of a null output list cannot appear in "
1077 & "multiple input lists", Item);
1080 -- Add an input or a self-referential output to the list
1081 -- of all processed inputs.
1083 if Is_Input or else Self_Ref then
1084 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1087 -- State related checks (SPARK RM 6.1.5(3))
1089 if Ekind (Item_Id) = E_Abstract_State then
1091 -- Package and subprogram bodies are instantiated
1092 -- individually in a separate compiler pass. Due to
1093 -- this mode of instantiation, the refinement of a
1094 -- state may no longer be visible when a subprogram
1095 -- body contract is instantiated. Since the generic
1096 -- template is legal, do not perform this check in
1097 -- the instance to circumvent this oddity.
1102 -- An abstract state with visible refinement cannot
1103 -- appear in pragma [Refined_]Depends as its place
1104 -- must be taken by some of its constituents
1105 -- (SPARK RM 6.1.4(7)).
1107 elsif Has_Visible_Refinement (Item_Id) then
1109 ("cannot mention state & in dependence relation",
1111 SPARK_Msg_N ("\use its constituents instead", Item);
1114 -- If the reference to the abstract state appears in
1115 -- an enclosing package body that will eventually
1116 -- refine the state, record the reference for future
1120 Record_Possible_Body_Reference
1121 (State_Id => Item_Id,
1126 -- When the item renames an entire object, replace the
1127 -- item with a reference to the object.
1129 if Entity (Item) /= Item_Id then
1131 New_Occurrence_Of (Item_Id, Sloc (Item)));
1135 -- Add the entity of the current item to the list of
1138 if Ekind (Item_Id) = E_Abstract_State then
1139 Append_New_Elmt (Item_Id, States_Seen);
1141 -- The variable may eventually become a constituent of a
1142 -- single protected/task type. Record the reference now
1143 -- and verify its legality when analyzing the contract of
1144 -- the variable (SPARK RM 9.3).
1146 elsif Ekind (Item_Id) = E_Variable then
1147 Record_Possible_Part_Of_Reference
1152 if Ekind (Item_Id) in E_Abstract_State
1155 and then Present (Encapsulating_State (Item_Id))
1157 Append_New_Elmt (Item_Id, Constits_Seen);
1160 -- All other input/output items are illegal
1161 -- (SPARK RM 6.1.5(1)).
1165 ("item must denote parameter, variable, state or "
1166 & "current instance of concurrent type", Item);
1169 -- All other input/output items are illegal
1170 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1174 ("item must denote parameter, variable, state or current "
1175 & "instance of concurrent type", Item);
1178 end Analyze_Input_Output;
1186 Non_Null_Output_Seen : Boolean := False;
1187 -- Flag used to check the legality of an output list
1189 -- Start of processing for Analyze_Dependency_Clause
1192 Inputs := Expression (Clause);
1195 -- An input list with a self-dependency appears as operator "+" where
1196 -- the actuals inputs are the right operand.
1198 if Nkind (Inputs) = N_Op_Plus then
1199 Inputs := Right_Opnd (Inputs);
1203 -- Process the output_list of a dependency_clause
1205 Output := First (Choices (Clause));
1206 while Present (Output) loop
1207 Analyze_Input_Output
1210 Self_Ref => Self_Ref,
1212 Seen => All_Outputs_Seen,
1213 Null_Seen => Null_Output_Seen,
1214 Non_Null_Seen => Non_Null_Output_Seen);
1219 -- Process the input_list of a dependency_clause
1221 Analyze_Input_List (Inputs);
1222 end Analyze_Dependency_Clause;
1224 ---------------------------
1225 -- Check_Function_Return --
1226 ---------------------------
1228 procedure Check_Function_Return is
1230 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1231 and then not Result_Seen
1234 ("result of & must appear in exactly one output list",
1237 end Check_Function_Return;
1243 procedure Check_Role
1245 Item_Id : Entity_Id;
1250 (Item_Is_Input : out Boolean;
1251 Item_Is_Output : out Boolean);
1252 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1253 -- Item_Is_Output are set depending on the role.
1255 procedure Role_Error
1256 (Item_Is_Input : Boolean;
1257 Item_Is_Output : Boolean);
1258 -- Emit an error message concerning the incorrect use of Item in
1259 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1260 -- denote whether the item is an input and/or an output.
1267 (Item_Is_Input : out Boolean;
1268 Item_Is_Output : out Boolean)
1270 -- A constant or IN parameter of access-to-variable type should be
1271 -- handled like a variable, as the underlying memory pointed-to
1272 -- can be modified. Use Adjusted_Kind to do this adjustment.
1274 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1277 if Ekind (Item_Id) in E_Constant
1278 | E_Generic_In_Parameter
1280 and then Is_Access_Variable (Etype (Item_Id))
1282 Adjusted_Kind := E_Variable;
1285 case Adjusted_Kind is
1289 when E_Abstract_State =>
1291 -- When pragma Global is present it determines the mode of
1292 -- the abstract state.
1295 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1296 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1298 -- Otherwise the state has a default IN OUT mode, because it
1299 -- behaves as a variable.
1302 Item_Is_Input := True;
1303 Item_Is_Output := True;
1306 -- Constants and IN parameters
1309 | E_Generic_In_Parameter
1313 -- When pragma Global is present it determines the mode
1314 -- of constant objects as inputs (and such objects cannot
1315 -- appear as outputs in the Global contract).
1318 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1320 Item_Is_Input := True;
1323 Item_Is_Output := False;
1325 -- Variables and IN OUT parameters, as well as constants and
1326 -- IN parameters of access type which are handled like
1329 when E_Generic_In_Out_Parameter
1330 | E_In_Out_Parameter
1333 -- When pragma Global is present it determines the mode of
1338 -- A variable has mode IN when its type is unconstrained
1339 -- or tagged because array bounds, discriminants or tags
1343 Appears_In (Subp_Inputs, Item_Id)
1344 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1346 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1348 -- Otherwise the variable has a default IN OUT mode
1351 Item_Is_Input := True;
1352 Item_Is_Output := True;
1355 when E_Out_Parameter =>
1357 -- An OUT parameter of the related subprogram; it cannot
1358 -- appear in Global.
1360 if Scope (Item_Id) = Spec_Id then
1362 -- The parameter has mode IN if its type is unconstrained
1363 -- or tagged because array bounds, discriminants or tags
1367 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1369 Item_Is_Output := True;
1371 -- An OUT parameter of an enclosing subprogram; it can
1372 -- appear in Global and behaves as a read-write variable.
1375 -- When pragma Global is present it determines the mode
1380 -- A variable has mode IN when its type is
1381 -- unconstrained or tagged because array
1382 -- bounds, discriminants or tags can be read.
1385 Appears_In (Subp_Inputs, Item_Id)
1386 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1388 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1390 -- Otherwise the variable has a default IN OUT mode
1393 Item_Is_Input := True;
1394 Item_Is_Output := True;
1400 when E_Protected_Type =>
1403 -- A variable has mode IN when its type is unconstrained
1404 -- or tagged because array bounds, discriminants or tags
1408 Appears_In (Subp_Inputs, Item_Id)
1409 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1411 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1414 -- A protected type acts as a formal parameter of mode IN
1415 -- when it applies to a protected function.
1417 if Ekind (Spec_Id) = E_Function then
1418 Item_Is_Input := True;
1419 Item_Is_Output := False;
1421 -- Otherwise the protected type acts as a formal of mode
1425 Item_Is_Input := True;
1426 Item_Is_Output := True;
1434 -- When pragma Global is present it determines the mode of
1439 Appears_In (Subp_Inputs, Item_Id)
1440 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1442 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1444 -- Otherwise task types act as IN OUT parameters
1447 Item_Is_Input := True;
1448 Item_Is_Output := True;
1452 raise Program_Error;
1460 procedure Role_Error
1461 (Item_Is_Input : Boolean;
1462 Item_Is_Output : Boolean)
1464 Error_Msg : Name_Id;
1469 -- When the item is not part of the input and the output set of
1470 -- the related subprogram, then it appears as extra in pragma
1471 -- [Refined_]Depends.
1473 if not Item_Is_Input and then not Item_Is_Output then
1474 Add_Item_To_Name_Buffer (Item_Id);
1475 Add_Str_To_Name_Buffer
1476 (" & cannot appear in dependence relation");
1478 Error_Msg := Name_Find;
1479 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1481 Error_Msg_Name_1 := Chars (Spec_Id);
1483 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1484 & "set of subprogram %"), Item, Item_Id);
1486 -- The mode of the item and its role in pragma [Refined_]Depends
1487 -- are in conflict. Construct a detailed message explaining the
1488 -- illegality (SPARK RM 6.1.5(5-6)).
1491 if Item_Is_Input then
1492 Add_Str_To_Name_Buffer ("read-only");
1494 Add_Str_To_Name_Buffer ("write-only");
1497 Add_Char_To_Name_Buffer (' ');
1498 Add_Item_To_Name_Buffer (Item_Id);
1499 Add_Str_To_Name_Buffer (" & cannot appear as ");
1501 if Item_Is_Input then
1502 Add_Str_To_Name_Buffer ("output");
1504 Add_Str_To_Name_Buffer ("input");
1507 Add_Str_To_Name_Buffer (" in dependence relation");
1508 Error_Msg := Name_Find;
1509 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1515 Item_Is_Input : Boolean;
1516 Item_Is_Output : Boolean;
1518 -- Start of processing for Check_Role
1521 Find_Role (Item_Is_Input, Item_Is_Output);
1526 if not Item_Is_Input then
1527 Role_Error (Item_Is_Input, Item_Is_Output);
1530 -- Self-referential item
1533 if not Item_Is_Input or else not Item_Is_Output then
1534 Role_Error (Item_Is_Input, Item_Is_Output);
1539 elsif not Item_Is_Output then
1540 Role_Error (Item_Is_Input, Item_Is_Output);
1548 procedure Check_Usage
1549 (Subp_Items : Elist_Id;
1550 Used_Items : Elist_Id;
1553 procedure Usage_Error (Item_Id : Entity_Id);
1554 -- Emit an error concerning the illegal usage of an item
1560 procedure Usage_Error (Item_Id : Entity_Id) is
1561 Error_Msg : Name_Id;
1568 -- Unconstrained and tagged items are not part of the explicit
1569 -- input set of the related subprogram, they do not have to be
1570 -- present in a dependence relation and should not be flagged
1571 -- (SPARK RM 6.1.5(5)).
1573 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1576 Add_Item_To_Name_Buffer (Item_Id);
1577 Add_Str_To_Name_Buffer
1578 (" & is missing from input dependence list");
1580 Error_Msg := Name_Find;
1581 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1583 ("\add `null ='> &` dependency to ignore this input",
1587 -- Output case (SPARK RM 6.1.5(10))
1592 Add_Item_To_Name_Buffer (Item_Id);
1593 Add_Str_To_Name_Buffer
1594 (" & is missing from output dependence list");
1596 Error_Msg := Name_Find;
1597 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1605 Item_Id : Entity_Id;
1607 -- Start of processing for Check_Usage
1610 if No (Subp_Items) then
1614 -- Each input or output of the subprogram must appear in a dependency
1617 Elmt := First_Elmt (Subp_Items);
1618 while Present (Elmt) loop
1619 Item := Node (Elmt);
1621 if Nkind (Item) = N_Defining_Identifier then
1624 Item_Id := Entity_Of (Item);
1627 -- The item does not appear in a dependency
1629 if Present (Item_Id)
1630 and then not Contains (Used_Items, Item_Id)
1632 if Is_Formal (Item_Id) then
1633 Usage_Error (Item_Id);
1635 -- The current instance of a protected type behaves as a formal
1636 -- parameter (SPARK RM 6.1.4).
1638 elsif Ekind (Item_Id) = E_Protected_Type
1639 or else Is_Single_Protected_Object (Item_Id)
1641 Usage_Error (Item_Id);
1643 -- The current instance of a task type behaves as a formal
1644 -- parameter (SPARK RM 6.1.4).
1646 elsif Ekind (Item_Id) = E_Task_Type
1647 or else Is_Single_Task_Object (Item_Id)
1649 -- The dependence of a task unit on itself is implicit and
1650 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1651 -- Emit an error if only one input/output is present.
1653 if Task_Input_Seen /= Task_Output_Seen then
1654 Usage_Error (Item_Id);
1657 -- States and global objects are not used properly only when
1658 -- the subprogram is subject to pragma Global.
1660 elsif Global_Seen then
1661 Usage_Error (Item_Id);
1669 ----------------------
1670 -- Normalize_Clause --
1671 ----------------------
1673 procedure Normalize_Clause (Clause : Node_Id) is
1674 procedure Create_Or_Modify_Clause
1680 Multiple : Boolean);
1681 -- Create a brand new clause to represent the self-reference or
1682 -- modify the input and/or output lists of an existing clause. Output
1683 -- denotes a self-referencial output. Outputs is the output list of a
1684 -- clause. Inputs is the input list of a clause. After denotes the
1685 -- clause after which the new clause is to be inserted. Flag In_Place
1686 -- should be set when normalizing the last output of an output list.
1687 -- Flag Multiple should be set when Output comes from a list with
1690 -----------------------------
1691 -- Create_Or_Modify_Clause --
1692 -----------------------------
1694 procedure Create_Or_Modify_Clause
1702 procedure Propagate_Output
1705 -- Handle the various cases of output propagation to the input
1706 -- list. Output denotes a self-referencial output item. Inputs
1707 -- is the input list of a clause.
1709 ----------------------
1710 -- Propagate_Output --
1711 ----------------------
1713 procedure Propagate_Output
1717 function In_Input_List
1719 Inputs : List_Id) return Boolean;
1720 -- Determine whether a particulat item appears in the input
1721 -- list of a clause.
1727 function In_Input_List
1729 Inputs : List_Id) return Boolean
1734 Elmt := First (Inputs);
1735 while Present (Elmt) loop
1736 if Entity_Of (Elmt) = Item then
1748 Output_Id : constant Entity_Id := Entity_Of (Output);
1751 -- Start of processing for Propagate_Output
1754 -- The clause is of the form:
1756 -- (Output =>+ null)
1758 -- Remove null input and replace it with a copy of the output:
1760 -- (Output => Output)
1762 if Nkind (Inputs) = N_Null then
1763 Rewrite (Inputs, New_Copy_Tree (Output));
1765 -- The clause is of the form:
1767 -- (Output =>+ (Input1, ..., InputN))
1769 -- Determine whether the output is not already mentioned in the
1770 -- input list and if not, add it to the list of inputs:
1772 -- (Output => (Output, Input1, ..., InputN))
1774 elsif Nkind (Inputs) = N_Aggregate then
1775 Grouped := Expressions (Inputs);
1777 if not In_Input_List
1781 Prepend_To (Grouped, New_Copy_Tree (Output));
1784 -- The clause is of the form:
1786 -- (Output =>+ Input)
1788 -- If the input does not mention the output, group the two
1791 -- (Output => (Output, Input))
1793 elsif Entity_Of (Inputs) /= Output_Id then
1795 Make_Aggregate (Loc,
1796 Expressions => New_List (
1797 New_Copy_Tree (Output),
1798 New_Copy_Tree (Inputs))));
1800 end Propagate_Output;
1804 Loc : constant Source_Ptr := Sloc (Clause);
1805 New_Clause : Node_Id;
1807 -- Start of processing for Create_Or_Modify_Clause
1810 -- A null output depending on itself does not require any
1813 if Nkind (Output) = N_Null then
1816 -- A function result cannot depend on itself because it cannot
1817 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1819 elsif Is_Attribute_Result (Output) then
1820 SPARK_Msg_N ("function result cannot depend on itself", Output);
1824 -- When performing the transformation in place, simply add the
1825 -- output to the list of inputs (if not already there). This
1826 -- case arises when dealing with the last output of an output
1827 -- list. Perform the normalization in place to avoid generating
1828 -- a malformed tree.
1831 Propagate_Output (Output, Inputs);
1833 -- A list with multiple outputs is slowly trimmed until only
1834 -- one element remains. When this happens, replace aggregate
1835 -- with the element itself.
1839 Rewrite (Outputs, Output);
1845 -- Unchain the output from its output list as it will appear in
1846 -- a new clause. Note that we cannot simply rewrite the output
1847 -- as null because this will violate the semantics of pragma
1852 -- Generate a new clause of the form:
1853 -- (Output => Inputs)
1856 Make_Component_Association (Loc,
1857 Choices => New_List (Output),
1858 Expression => New_Copy_Tree (Inputs));
1860 -- The new clause contains replicated content that has already
1861 -- been analyzed. There is not need to reanalyze or renormalize
1864 Set_Analyzed (New_Clause);
1867 (Output => First (Choices (New_Clause)),
1868 Inputs => Expression (New_Clause));
1870 Insert_After (After, New_Clause);
1872 end Create_Or_Modify_Clause;
1876 Outputs : constant Node_Id := First (Choices (Clause));
1878 Last_Output : Node_Id;
1879 Next_Output : Node_Id;
1882 -- Start of processing for Normalize_Clause
1885 -- A self-dependency appears as operator "+". Remove the "+" from the
1886 -- tree by moving the real inputs to their proper place.
1888 if Nkind (Expression (Clause)) = N_Op_Plus then
1889 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1890 Inputs := Expression (Clause);
1892 -- Multiple outputs appear as an aggregate
1894 if Nkind (Outputs) = N_Aggregate then
1895 Last_Output := Last (Expressions (Outputs));
1897 Output := First (Expressions (Outputs));
1898 while Present (Output) loop
1900 -- Normalization may remove an output from its list,
1901 -- preserve the subsequent output now.
1903 Next_Output := Next (Output);
1905 Create_Or_Modify_Clause
1910 In_Place => Output = Last_Output,
1913 Output := Next_Output;
1919 Create_Or_Modify_Clause
1928 end Normalize_Clause;
1932 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1933 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1937 Last_Clause : Node_Id;
1938 Restore_Scope : Boolean := False;
1940 -- Start of processing for Analyze_Depends_In_Decl_Part
1943 -- Do not analyze the pragma multiple times
1945 if Is_Analyzed_Pragma (N) then
1949 -- Empty dependency list
1951 if Nkind (Deps) = N_Null then
1953 -- Gather all states, objects and formal parameters that the
1954 -- subprogram may depend on. These items are obtained from the
1955 -- parameter profile or pragma [Refined_]Global (if available).
1957 Collect_Subprogram_Inputs_Outputs
1958 (Subp_Id => Subp_Id,
1959 Subp_Inputs => Subp_Inputs,
1960 Subp_Outputs => Subp_Outputs,
1961 Global_Seen => Global_Seen);
1963 -- Verify that every input or output of the subprogram appear in a
1966 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1967 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1968 Check_Function_Return;
1970 -- Dependency clauses appear as component associations of an aggregate
1972 elsif Nkind (Deps) = N_Aggregate then
1974 -- Do not attempt to perform analysis of a syntactically illegal
1975 -- clause as this will lead to misleading errors.
1977 if Has_Extra_Parentheses (Deps) then
1981 if Present (Component_Associations (Deps)) then
1982 Last_Clause := Last (Component_Associations (Deps));
1984 -- Gather all states, objects and formal parameters that the
1985 -- subprogram may depend on. These items are obtained from the
1986 -- parameter profile or pragma [Refined_]Global (if available).
1988 Collect_Subprogram_Inputs_Outputs
1989 (Subp_Id => Subp_Id,
1990 Subp_Inputs => Subp_Inputs,
1991 Subp_Outputs => Subp_Outputs,
1992 Global_Seen => Global_Seen);
1994 -- When pragma [Refined_]Depends appears on a single concurrent
1995 -- type, it is relocated to the anonymous object.
1997 if Is_Single_Concurrent_Object (Spec_Id) then
2000 -- Ensure that the formal parameters are visible when analyzing
2001 -- all clauses. This falls out of the general rule of aspects
2002 -- pertaining to subprogram declarations.
2004 elsif not In_Open_Scopes (Spec_Id) then
2005 Restore_Scope := True;
2006 Push_Scope (Spec_Id);
2008 if Ekind (Spec_Id) = E_Task_Type then
2010 -- Task discriminants cannot appear in the [Refined_]Depends
2011 -- contract, but must be present for the analysis so that we
2012 -- can reject them with an informative error message.
2014 if Has_Discriminants (Spec_Id) then
2015 Install_Discriminants (Spec_Id);
2018 elsif Is_Generic_Subprogram (Spec_Id) then
2019 Install_Generic_Formals (Spec_Id);
2022 Install_Formals (Spec_Id);
2026 Clause := First (Component_Associations (Deps));
2027 while Present (Clause) loop
2028 Errors := Serious_Errors_Detected;
2030 -- The normalization mechanism may create extra clauses that
2031 -- contain replicated input and output names. There is no need
2032 -- to reanalyze them.
2034 if not Analyzed (Clause) then
2035 Set_Analyzed (Clause);
2037 Analyze_Dependency_Clause
2039 Is_Last => Clause = Last_Clause);
2042 -- Do not normalize a clause if errors were detected (count
2043 -- of Serious_Errors has increased) because the inputs and/or
2044 -- outputs may denote illegal items.
2046 if Serious_Errors_Detected = Errors then
2047 Normalize_Clause (Clause);
2053 if Restore_Scope then
2057 -- Verify that every input or output of the subprogram appear in a
2060 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2061 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2062 Check_Function_Return;
2064 -- The dependency list is malformed. This is a syntax error, always
2068 Error_Msg_N ("malformed dependency relation", Deps);
2072 -- The top level dependency relation is malformed. This is a syntax
2073 -- error, always report.
2076 Error_Msg_N ("malformed dependency relation", Deps);
2080 -- Ensure that a state and a corresponding constituent do not appear
2081 -- together in pragma [Refined_]Depends.
2083 Check_State_And_Constituent_Use
2084 (States => States_Seen,
2085 Constits => Constits_Seen,
2089 Set_Is_Analyzed_Pragma (N);
2090 end Analyze_Depends_In_Decl_Part;
2092 --------------------------------------------
2093 -- Analyze_External_Property_In_Decl_Part --
2094 --------------------------------------------
2096 procedure Analyze_External_Property_In_Decl_Part
2098 Expr_Val : out Boolean)
2100 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2101 Arg1 : constant Node_Id :=
2102 First (Pragma_Argument_Associations (N));
2103 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2104 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2108 -- Do not analyze the pragma multiple times, but set the output
2109 -- parameter to the argument specified by the pragma.
2111 if Is_Analyzed_Pragma (N) then
2115 Error_Msg_Name_1 := Pragma_Name (N);
2117 -- An external property pragma must apply to an effectively volatile
2118 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2119 -- The check is performed at the end of the declarative region due to a
2120 -- possible out-of-order arrangement of pragmas:
2123 -- pragma Async_Readers (Obj);
2124 -- pragma Volatile (Obj);
2126 if Prag_Id /= Pragma_No_Caching
2127 and then not Is_Effectively_Volatile (Obj_Id)
2129 if Ekind (Obj_Id) = E_Variable
2130 and then No_Caching_Enabled (Obj_Id)
2133 ("illegal combination of external property % and property "
2134 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2137 ("external property % must apply to a volatile type or object",
2141 -- Pragma No_Caching should only apply to volatile variables of
2142 -- a non-effectively volatile type (SPARK RM 7.1.2).
2144 elsif Prag_Id = Pragma_No_Caching then
2145 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2146 SPARK_Msg_N ("property % must not apply to an object of "
2147 & "an effectively volatile type", N);
2148 elsif not Is_Volatile (Obj_Id) then
2149 SPARK_Msg_N ("property % must apply to a volatile object", N);
2153 Set_Is_Analyzed_Pragma (N);
2157 -- Ensure that the Boolean expression (if present) is static. A missing
2158 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2162 if Present (Arg1) then
2163 Expr := Get_Pragma_Arg (Arg1);
2165 if Is_OK_Static_Expression (Expr) then
2166 Expr_Val := Is_True (Expr_Value (Expr));
2170 end Analyze_External_Property_In_Decl_Part;
2172 ---------------------------------
2173 -- Analyze_Global_In_Decl_Part --
2174 ---------------------------------
2176 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2177 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2178 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2179 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2181 Constits_Seen : Elist_Id := No_Elist;
2182 -- A list containing the entities of all constituents processed so far.
2183 -- It aids in detecting illegal usage of a state and a corresponding
2184 -- constituent in pragma [Refinde_]Global.
2186 Seen : Elist_Id := No_Elist;
2187 -- A list containing the entities of all the items processed so far. It
2188 -- plays a role in detecting distinct entities.
2190 States_Seen : Elist_Id := No_Elist;
2191 -- A list containing the entities of all states processed so far. It
2192 -- helps in detecting illegal usage of a state and a corresponding
2193 -- constituent in pragma [Refined_]Global.
2195 In_Out_Seen : Boolean := False;
2196 Input_Seen : Boolean := False;
2197 Output_Seen : Boolean := False;
2198 Proof_Seen : Boolean := False;
2199 -- Flags used to verify the consistency of modes
2201 procedure Analyze_Global_List
2203 Global_Mode : Name_Id := Name_Input);
2204 -- Verify the legality of a single global list declaration. Global_Mode
2205 -- denotes the current mode in effect.
2207 -------------------------
2208 -- Analyze_Global_List --
2209 -------------------------
2211 procedure Analyze_Global_List
2213 Global_Mode : Name_Id := Name_Input)
2215 procedure Analyze_Global_Item
2217 Global_Mode : Name_Id);
2218 -- Verify the legality of a single global item declaration denoted by
2219 -- Item. Global_Mode denotes the current mode in effect.
2221 procedure Check_Duplicate_Mode
2223 Status : in out Boolean);
2224 -- Flag Status denotes whether a particular mode has been seen while
2225 -- processing a global list. This routine verifies that Mode is not a
2226 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2228 procedure Check_Mode_Restriction_In_Enclosing_Context
2230 Item_Id : Entity_Id);
2231 -- Verify that an item of mode In_Out or Output does not appear as
2232 -- an input in the Global aspect of an enclosing subprogram or task
2233 -- unit. If this is the case, emit an error. Item and Item_Id are
2234 -- respectively the item and its entity.
2236 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2237 -- Mode denotes either In_Out or Output. Depending on the kind of the
2238 -- related subprogram, emit an error if those two modes apply to a
2239 -- function (SPARK RM 6.1.4(10)).
2241 -------------------------
2242 -- Analyze_Global_Item --
2243 -------------------------
2245 procedure Analyze_Global_Item
2247 Global_Mode : Name_Id)
2249 Item_Id : Entity_Id;
2252 -- Detect one of the following cases
2254 -- with Global => (null, Name)
2255 -- with Global => (Name_1, null, Name_2)
2256 -- with Global => (Name, null)
2258 if Nkind (Item) = N_Null then
2259 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2264 Resolve_State (Item);
2266 -- Find the entity of the item. If this is a renaming, climb the
2267 -- renaming chain to reach the root object. Renamings of non-
2268 -- entire objects do not yield an entity (Empty).
2270 Item_Id := Entity_Of (Item);
2272 if Present (Item_Id) then
2274 -- A global item may denote a formal parameter of an enclosing
2275 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2276 -- provide a better error diagnostic.
2278 if Is_Formal (Item_Id) then
2279 if Scope (Item_Id) = Spec_Id then
2281 (Fix_Msg (Spec_Id, "global item cannot reference "
2282 & "parameter of subprogram &"), Item, Spec_Id);
2286 -- A global item may denote a concurrent type as long as it is
2287 -- the current instance of an enclosing protected or task type
2288 -- (SPARK RM 6.1.4).
2290 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2291 if Is_CCT_Instance (Item_Id, Spec_Id) then
2293 -- Pragma [Refined_]Global associated with a protected
2294 -- subprogram cannot mention the current instance of a
2295 -- protected type because the instance behaves as a
2296 -- formal parameter.
2298 if Ekind (Item_Id) = E_Protected_Type then
2299 if Scope (Spec_Id) = Item_Id then
2300 Error_Msg_Name_1 := Chars (Item_Id);
2302 (Fix_Msg (Spec_Id, "global item of subprogram & "
2303 & "cannot reference current instance of "
2304 & "protected type %"), Item, Spec_Id);
2308 -- Pragma [Refined_]Global associated with a task type
2309 -- cannot mention the current instance of a task type
2310 -- because the instance behaves as a formal parameter.
2312 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2313 if Spec_Id = Item_Id then
2314 Error_Msg_Name_1 := Chars (Item_Id);
2316 (Fix_Msg (Spec_Id, "global item of subprogram & "
2317 & "cannot reference current instance of task "
2318 & "type %"), Item, Spec_Id);
2323 -- Otherwise the global item denotes a subtype mark that is
2324 -- not a current instance.
2328 ("invalid use of subtype mark in global list", Item);
2332 -- A global item may denote the anonymous object created for a
2333 -- single protected/task type as long as the current instance
2334 -- is the same single type (SPARK RM 6.1.4).
2336 elsif Is_Single_Concurrent_Object (Item_Id)
2337 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2339 -- Pragma [Refined_]Global associated with a protected
2340 -- subprogram cannot mention the current instance of a
2341 -- protected type because the instance behaves as a formal
2344 if Is_Single_Protected_Object (Item_Id) then
2345 if Scope (Spec_Id) = Etype (Item_Id) then
2346 Error_Msg_Name_1 := Chars (Item_Id);
2348 (Fix_Msg (Spec_Id, "global item of subprogram & "
2349 & "cannot reference current instance of protected "
2350 & "type %"), Item, Spec_Id);
2354 -- Pragma [Refined_]Global associated with a task type
2355 -- cannot mention the current instance of a task type
2356 -- because the instance behaves as a formal parameter.
2358 else pragma Assert (Is_Single_Task_Object (Item_Id));
2359 if Spec_Id = Item_Id then
2360 Error_Msg_Name_1 := Chars (Item_Id);
2362 (Fix_Msg (Spec_Id, "global item of subprogram & "
2363 & "cannot reference current instance of task "
2364 & "type %"), Item, Spec_Id);
2369 -- A formal object may act as a global item inside a generic
2371 elsif Is_Formal_Object (Item_Id) then
2374 -- The only legal references are those to abstract states,
2375 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2377 elsif Ekind (Item_Id) not in E_Abstract_State
2383 ("global item must denote object, state or current "
2384 & "instance of concurrent type", Item);
2386 if Is_Named_Number (Item_Id) then
2388 ("\named number & is not an object", Item, Item_Id);
2394 -- State related checks
2396 if Ekind (Item_Id) = E_Abstract_State then
2398 -- Package and subprogram bodies are instantiated
2399 -- individually in a separate compiler pass. Due to this
2400 -- mode of instantiation, the refinement of a state may
2401 -- no longer be visible when a subprogram body contract
2402 -- is instantiated. Since the generic template is legal,
2403 -- do not perform this check in the instance to circumvent
2409 -- An abstract state with visible refinement cannot appear
2410 -- in pragma [Refined_]Global as its place must be taken by
2411 -- some of its constituents (SPARK RM 6.1.4(7)).
2413 elsif Has_Visible_Refinement (Item_Id) then
2415 ("cannot mention state & in global refinement",
2417 SPARK_Msg_N ("\use its constituents instead", Item);
2420 -- An external state cannot appear as a global item of a
2421 -- nonvolatile function (SPARK RM 7.1.3(8)).
2423 elsif Is_External_State (Item_Id)
2424 and then Ekind (Spec_Id) in E_Function | E_Generic_Function
2425 and then not Is_Volatile_Function (Spec_Id)
2428 ("external state & cannot act as global item of "
2429 & "nonvolatile function", Item, Item_Id);
2432 -- If the reference to the abstract state appears in an
2433 -- enclosing package body that will eventually refine the
2434 -- state, record the reference for future checks.
2437 Record_Possible_Body_Reference
2438 (State_Id => Item_Id,
2442 -- Constant related checks
2444 elsif Ekind (Item_Id) = E_Constant
2445 and then not Is_Access_Type (Etype (Item_Id))
2448 -- Unless it is of an access type, a constant is a read-only
2449 -- item, therefore it cannot act as an output.
2451 if Global_Mode in Name_In_Out | Name_Output then
2453 ("constant & cannot act as output", Item, Item_Id);
2457 -- Loop parameter related checks
2459 elsif Ekind (Item_Id) = E_Loop_Parameter then
2461 -- A loop parameter is a read-only item, therefore it cannot
2462 -- act as an output.
2464 if Global_Mode in Name_In_Out | Name_Output then
2466 ("loop parameter & cannot act as output",
2471 -- Variable related checks. These are only relevant when
2472 -- SPARK_Mode is on as they are not standard Ada legality
2475 elsif SPARK_Mode = On
2476 and then Ekind (Item_Id) = E_Variable
2477 and then Is_Effectively_Volatile_For_Reading (Item_Id)
2479 -- The current instance of a protected unit is not an
2480 -- effectively volatile object, unless the protected unit
2481 -- is already volatile for another reason (SPARK RM 7.1.2).
2483 if Is_Single_Protected_Object (Item_Id)
2484 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2485 and then not Is_Effectively_Volatile_For_Reading
2486 (Item_Id, Ignore_Protected => True)
2490 -- An effectively volatile object for reading cannot appear
2491 -- as a global item of a nonvolatile function (SPARK RM
2494 elsif Ekind (Spec_Id) in E_Function | E_Generic_Function
2495 and then not Is_Volatile_Function (Spec_Id)
2498 ("volatile object & cannot act as global item of a "
2499 & "function", Item, Item_Id);
2502 -- An effectively volatile object with external property
2503 -- Effective_Reads set to True must have mode Output or
2504 -- In_Out (SPARK RM 7.1.3(10)).
2506 elsif Effective_Reads_Enabled (Item_Id)
2507 and then Global_Mode = Name_Input
2510 ("volatile object & with property Effective_Reads must "
2511 & "have mode In_Out or Output", Item, Item_Id);
2516 -- When the item renames an entire object, replace the item
2517 -- with a reference to the object.
2519 if Entity (Item) /= Item_Id then
2520 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2524 -- Some form of illegal construct masquerading as a name
2525 -- (SPARK RM 6.1.4(4)).
2529 ("global item must denote object, state or current instance "
2530 & "of concurrent type", Item);
2534 -- Verify that an output does not appear as an input in an
2535 -- enclosing subprogram.
2537 if Global_Mode in Name_In_Out | Name_Output then
2538 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2541 -- The same entity might be referenced through various way.
2542 -- Check the entity of the item rather than the item itself
2543 -- (SPARK RM 6.1.4(10)).
2545 if Contains (Seen, Item_Id) then
2546 SPARK_Msg_N ("duplicate global item", Item);
2548 -- Add the entity of the current item to the list of processed
2552 Append_New_Elmt (Item_Id, Seen);
2554 if Ekind (Item_Id) = E_Abstract_State then
2555 Append_New_Elmt (Item_Id, States_Seen);
2557 -- The variable may eventually become a constituent of a single
2558 -- protected/task type. Record the reference now and verify its
2559 -- legality when analyzing the contract of the variable
2562 elsif Ekind (Item_Id) = E_Variable then
2563 Record_Possible_Part_Of_Reference
2568 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2569 and then Present (Encapsulating_State (Item_Id))
2571 Append_New_Elmt (Item_Id, Constits_Seen);
2574 end Analyze_Global_Item;
2576 --------------------------
2577 -- Check_Duplicate_Mode --
2578 --------------------------
2580 procedure Check_Duplicate_Mode
2582 Status : in out Boolean)
2586 SPARK_Msg_N ("duplicate global mode", Mode);
2590 end Check_Duplicate_Mode;
2592 -------------------------------------------------
2593 -- Check_Mode_Restriction_In_Enclosing_Context --
2594 -------------------------------------------------
2596 procedure Check_Mode_Restriction_In_Enclosing_Context
2598 Item_Id : Entity_Id)
2600 Context : Entity_Id;
2602 Inputs : Elist_Id := No_Elist;
2603 Outputs : Elist_Id := No_Elist;
2606 -- Traverse the scope stack looking for enclosing subprograms or
2607 -- tasks subject to pragma [Refined_]Global.
2609 Context := Scope (Subp_Id);
2610 while Present (Context) and then Context /= Standard_Standard loop
2612 -- For a single task type, retrieve the corresponding object to
2613 -- which pragma [Refined_]Global is attached.
2615 if Ekind (Context) = E_Task_Type
2616 and then Is_Single_Concurrent_Type (Context)
2618 Context := Anonymous_Object (Context);
2621 if (Is_Subprogram (Context)
2622 or else Ekind (Context) = E_Task_Type
2623 or else Is_Single_Task_Object (Context))
2625 (Present (Get_Pragma (Context, Pragma_Global))
2627 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2629 Collect_Subprogram_Inputs_Outputs
2630 (Subp_Id => Context,
2631 Subp_Inputs => Inputs,
2632 Subp_Outputs => Outputs,
2633 Global_Seen => Dummy);
2635 -- The item is classified as In_Out or Output but appears as
2636 -- an Input in an enclosing subprogram or task unit (SPARK
2639 if Appears_In (Inputs, Item_Id)
2640 and then not Appears_In (Outputs, Item_Id)
2643 ("global item & cannot have mode In_Out or Output",
2646 if Is_Subprogram (Context) then
2648 (Fix_Msg (Subp_Id, "\item already appears as input "
2649 & "of subprogram &"), Item, Context);
2652 (Fix_Msg (Subp_Id, "\item already appears as input "
2653 & "of task &"), Item, Context);
2656 -- Stop the traversal once an error has been detected
2662 Context := Scope (Context);
2664 end Check_Mode_Restriction_In_Enclosing_Context;
2666 ----------------------------------------
2667 -- Check_Mode_Restriction_In_Function --
2668 ----------------------------------------
2670 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2672 if Ekind (Spec_Id) in E_Function | E_Generic_Function then
2674 ("global mode & is not applicable to functions", Mode);
2676 end Check_Mode_Restriction_In_Function;
2684 -- Start of processing for Analyze_Global_List
2687 if Nkind (List) = N_Null then
2688 Set_Analyzed (List);
2690 -- Single global item declaration
2692 elsif Nkind (List) in N_Expanded_Name
2694 | N_Selected_Component
2696 Analyze_Global_Item (List, Global_Mode);
2698 -- Simple global list or moded global list declaration
2700 elsif Nkind (List) = N_Aggregate then
2701 Set_Analyzed (List);
2703 -- The declaration of a simple global list appear as a collection
2706 if Present (Expressions (List)) then
2707 if Present (Component_Associations (List)) then
2709 ("cannot mix moded and non-moded global lists", List);
2712 Item := First (Expressions (List));
2713 while Present (Item) loop
2714 Analyze_Global_Item (Item, Global_Mode);
2718 -- The declaration of a moded global list appears as a collection
2719 -- of component associations where individual choices denote
2722 elsif Present (Component_Associations (List)) then
2723 if Present (Expressions (List)) then
2725 ("cannot mix moded and non-moded global lists", List);
2728 Assoc := First (Component_Associations (List));
2729 while Present (Assoc) loop
2730 Mode := First (Choices (Assoc));
2732 if Nkind (Mode) = N_Identifier then
2733 if Chars (Mode) = Name_In_Out then
2734 Check_Duplicate_Mode (Mode, In_Out_Seen);
2735 Check_Mode_Restriction_In_Function (Mode);
2737 elsif Chars (Mode) = Name_Input then
2738 Check_Duplicate_Mode (Mode, Input_Seen);
2740 elsif Chars (Mode) = Name_Output then
2741 Check_Duplicate_Mode (Mode, Output_Seen);
2742 Check_Mode_Restriction_In_Function (Mode);
2744 elsif Chars (Mode) = Name_Proof_In then
2745 Check_Duplicate_Mode (Mode, Proof_Seen);
2748 SPARK_Msg_N ("invalid mode selector", Mode);
2752 SPARK_Msg_N ("invalid mode selector", Mode);
2755 -- Items in a moded list appear as a collection of
2756 -- expressions. Reuse the existing machinery to analyze
2760 (List => Expression (Assoc),
2761 Global_Mode => Chars (Mode));
2769 raise Program_Error;
2772 -- Any other attempt to declare a global item is illegal. This is a
2773 -- syntax error, always report.
2776 Error_Msg_N ("malformed global list", List);
2778 end Analyze_Global_List;
2782 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2784 Restore_Scope : Boolean := False;
2786 -- Start of processing for Analyze_Global_In_Decl_Part
2789 -- Do not analyze the pragma multiple times
2791 if Is_Analyzed_Pragma (N) then
2795 -- There is nothing to be done for a null global list
2797 if Nkind (Items) = N_Null then
2798 Set_Analyzed (Items);
2800 -- Analyze the various forms of global lists and items. Note that some
2801 -- of these may be malformed in which case the analysis emits error
2805 -- When pragma [Refined_]Global appears on a single concurrent type,
2806 -- it is relocated to the anonymous object.
2808 if Is_Single_Concurrent_Object (Spec_Id) then
2811 -- Ensure that the formal parameters are visible when processing an
2812 -- item. This falls out of the general rule of aspects pertaining to
2813 -- subprogram declarations.
2815 elsif not In_Open_Scopes (Spec_Id) then
2816 Restore_Scope := True;
2817 Push_Scope (Spec_Id);
2819 if Ekind (Spec_Id) = E_Task_Type then
2821 -- Task discriminants cannot appear in the [Refined_]Global
2822 -- contract, but must be present for the analysis so that we
2823 -- can reject them with an informative error message.
2825 if Has_Discriminants (Spec_Id) then
2826 Install_Discriminants (Spec_Id);
2829 elsif Is_Generic_Subprogram (Spec_Id) then
2830 Install_Generic_Formals (Spec_Id);
2833 Install_Formals (Spec_Id);
2837 Analyze_Global_List (Items);
2839 if Restore_Scope then
2844 -- Ensure that a state and a corresponding constituent do not appear
2845 -- together in pragma [Refined_]Global.
2847 Check_State_And_Constituent_Use
2848 (States => States_Seen,
2849 Constits => Constits_Seen,
2852 Set_Is_Analyzed_Pragma (N);
2853 end Analyze_Global_In_Decl_Part;
2855 --------------------------------------------
2856 -- Analyze_Initial_Condition_In_Decl_Part --
2857 --------------------------------------------
2859 -- WARNING: This routine manages Ghost regions. Return statements must be
2860 -- replaced by gotos which jump to the end of the routine and restore the
2863 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2864 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2865 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2866 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2868 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2869 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2870 -- Save the Ghost-related attributes to restore on exit
2873 -- Do not analyze the pragma multiple times
2875 if Is_Analyzed_Pragma (N) then
2879 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2880 -- analysis of the pragma, the Ghost mode at point of declaration and
2881 -- point of analysis may not necessarily be the same. Use the mode in
2882 -- effect at the point of declaration.
2886 -- The expression is preanalyzed because it has not been moved to its
2887 -- final place yet. A direct analysis may generate side effects and this
2888 -- is not desired at this point.
2890 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2891 Set_Is_Analyzed_Pragma (N);
2893 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2894 end Analyze_Initial_Condition_In_Decl_Part;
2896 --------------------------------------
2897 -- Analyze_Initializes_In_Decl_Part --
2898 --------------------------------------
2900 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2901 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2902 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2904 Constits_Seen : Elist_Id := No_Elist;
2905 -- A list containing the entities of all constituents processed so far.
2906 -- It aids in detecting illegal usage of a state and a corresponding
2907 -- constituent in pragma Initializes.
2909 Items_Seen : Elist_Id := No_Elist;
2910 -- A list of all initialization items processed so far. This list is
2911 -- used to detect duplicate items.
2913 States_And_Objs : Elist_Id := No_Elist;
2914 -- A list of all abstract states and objects declared in the visible
2915 -- declarations of the related package. This list is used to detect the
2916 -- legality of initialization items.
2918 States_Seen : Elist_Id := No_Elist;
2919 -- A list containing the entities of all states processed so far. It
2920 -- helps in detecting illegal usage of a state and a corresponding
2921 -- constituent in pragma Initializes.
2923 procedure Analyze_Initialization_Item (Item : Node_Id);
2924 -- Verify the legality of a single initialization item
2926 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2927 -- Verify the legality of a single initialization item followed by a
2928 -- list of input items.
2930 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2931 -- Inspect the visible declarations of the related package and gather
2932 -- the entities of all abstract states and objects in States_And_Objs.
2934 ---------------------------------
2935 -- Analyze_Initialization_Item --
2936 ---------------------------------
2938 procedure Analyze_Initialization_Item (Item : Node_Id) is
2939 Item_Id : Entity_Id;
2943 Resolve_State (Item);
2945 if Is_Entity_Name (Item) then
2946 Item_Id := Entity_Of (Item);
2948 if Present (Item_Id)
2949 and then Ekind (Item_Id) in
2950 E_Abstract_State | E_Constant | E_Variable
2952 -- When the initialization item is undefined, it appears as
2953 -- Any_Id. Do not continue with the analysis of the item.
2955 if Item_Id = Any_Id then
2958 -- The state or variable must be declared in the visible
2959 -- declarations of the package (SPARK RM 7.1.5(7)).
2961 elsif not Contains (States_And_Objs, Item_Id) then
2962 Error_Msg_Name_1 := Chars (Pack_Id);
2964 ("initialization item & must appear in the visible "
2965 & "declarations of package %", Item, Item_Id);
2967 -- Detect a duplicate use of the same initialization item
2968 -- (SPARK RM 7.1.5(5)).
2970 elsif Contains (Items_Seen, Item_Id) then
2971 SPARK_Msg_N ("duplicate initialization item", Item);
2973 -- The item is legal, add it to the list of processed states
2977 Append_New_Elmt (Item_Id, Items_Seen);
2979 if Ekind (Item_Id) = E_Abstract_State then
2980 Append_New_Elmt (Item_Id, States_Seen);
2983 if Present (Encapsulating_State (Item_Id)) then
2984 Append_New_Elmt (Item_Id, Constits_Seen);
2988 -- The item references something that is not a state or object
2989 -- (SPARK RM 7.1.5(3)).
2993 ("initialization item must denote object or state", Item);
2996 -- Some form of illegal construct masquerading as a name
2997 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3001 ("initialization item must denote object or state", Item);
3003 end Analyze_Initialization_Item;
3005 ---------------------------------------------
3006 -- Analyze_Initialization_Item_With_Inputs --
3007 ---------------------------------------------
3009 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
3010 Inputs_Seen : Elist_Id := No_Elist;
3011 -- A list of all inputs processed so far. This list is used to detect
3012 -- duplicate uses of an input.
3014 Non_Null_Seen : Boolean := False;
3015 Null_Seen : Boolean := False;
3016 -- Flags used to check the legality of an input list
3018 procedure Analyze_Input_Item (Input : Node_Id);
3019 -- Verify the legality of a single input item
3021 ------------------------
3022 -- Analyze_Input_Item --
3023 ------------------------
3025 procedure Analyze_Input_Item (Input : Node_Id) is
3026 Input_Id : Entity_Id;
3031 if Nkind (Input) = N_Null then
3034 ("multiple null initializations not allowed", Item);
3036 elsif Non_Null_Seen then
3038 ("cannot mix null and non-null initialization item", Item);
3046 Non_Null_Seen := True;
3050 ("cannot mix null and non-null initialization item", Item);
3054 Resolve_State (Input);
3056 if Is_Entity_Name (Input) then
3057 Input_Id := Entity_Of (Input);
3059 if Present (Input_Id)
3060 and then Ekind (Input_Id) in E_Abstract_State
3062 | E_Generic_In_Out_Parameter
3063 | E_Generic_In_Parameter
3065 | E_In_Out_Parameter
3071 -- The input cannot denote states or objects declared
3072 -- within the related package (SPARK RM 7.1.5(4)).
3074 if Within_Scope (Input_Id, Current_Scope) then
3076 -- Do not consider generic formal parameters or their
3077 -- respective mappings to generic formals. Even though
3078 -- the formals appear within the scope of the package,
3079 -- it is allowed for an initialization item to depend
3080 -- on an input item.
3082 if Ekind (Input_Id) in E_Generic_In_Out_Parameter
3083 | E_Generic_In_Parameter
3087 elsif Ekind (Input_Id) in E_Constant | E_Variable
3088 and then Present (Corresponding_Generic_Association
3089 (Declaration_Node (Input_Id)))
3094 Error_Msg_Name_1 := Chars (Pack_Id);
3096 ("input item & cannot denote a visible object or "
3097 & "state of package %", Input, Input_Id);
3102 -- Detect a duplicate use of the same input item
3103 -- (SPARK RM 7.1.5(5)).
3105 if Contains (Inputs_Seen, Input_Id) then
3106 SPARK_Msg_N ("duplicate input item", Input);
3110 -- At this point it is known that the input is legal. Add
3111 -- it to the list of processed inputs.
3113 Append_New_Elmt (Input_Id, Inputs_Seen);
3115 if Ekind (Input_Id) = E_Abstract_State then
3116 Append_New_Elmt (Input_Id, States_Seen);
3119 if Ekind (Input_Id) in E_Abstract_State
3122 and then Present (Encapsulating_State (Input_Id))
3124 Append_New_Elmt (Input_Id, Constits_Seen);
3127 -- The input references something that is not a state or an
3128 -- object (SPARK RM 7.1.5(3)).
3132 ("input item must denote object or state", Input);
3135 -- Some form of illegal construct masquerading as a name
3136 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3140 ("input item must denote object or state", Input);
3143 end Analyze_Input_Item;
3147 Inputs : constant Node_Id := Expression (Item);
3151 Name_Seen : Boolean := False;
3152 -- A flag used to detect multiple item names
3154 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3157 -- Inspect the name of an item with inputs
3159 Elmt := First (Choices (Item));
3160 while Present (Elmt) loop
3162 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3165 Analyze_Initialization_Item (Elmt);
3171 -- Multiple input items appear as an aggregate
3173 if Nkind (Inputs) = N_Aggregate then
3174 if Present (Expressions (Inputs)) then
3175 Input := First (Expressions (Inputs));
3176 while Present (Input) loop
3177 Analyze_Input_Item (Input);
3182 if Present (Component_Associations (Inputs)) then
3184 ("inputs must appear in named association form", Inputs);
3187 -- Single input item
3190 Analyze_Input_Item (Inputs);
3192 end Analyze_Initialization_Item_With_Inputs;
3194 --------------------------------
3195 -- Collect_States_And_Objects --
3196 --------------------------------
3198 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3199 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3200 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3202 State_Elmt : Elmt_Id;
3205 -- Collect the abstract states defined in the package (if any)
3207 if Has_Non_Null_Abstract_State (Pack_Id) then
3208 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3209 while Present (State_Elmt) loop
3210 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3211 Next_Elmt (State_Elmt);
3215 -- Collect all objects that appear in the visible declarations of the
3218 if Present (Visible_Declarations (Pack_Spec)) then
3219 Decl := First (Visible_Declarations (Pack_Spec));
3220 while Present (Decl) loop
3221 if Comes_From_Source (Decl)
3222 and then Nkind (Decl) in N_Object_Declaration
3223 | N_Object_Renaming_Declaration
3225 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3227 elsif Nkind (Decl) = N_Package_Declaration then
3228 Collect_States_And_Objects (Decl);
3230 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3232 (Anonymous_Object (Defining_Entity (Decl)),
3239 end Collect_States_And_Objects;
3243 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3246 -- Start of processing for Analyze_Initializes_In_Decl_Part
3249 -- Do not analyze the pragma multiple times
3251 if Is_Analyzed_Pragma (N) then
3255 -- Nothing to do when the initialization list is empty
3257 if Nkind (Inits) = N_Null then
3261 -- Single and multiple initialization clauses appear as an aggregate. If
3262 -- this is not the case, then either the parser or the analysis of the
3263 -- pragma failed to produce an aggregate.
3265 pragma Assert (Nkind (Inits) = N_Aggregate);
3267 -- Initialize the various lists used during analysis
3269 Collect_States_And_Objects (Pack_Decl);
3271 if Present (Expressions (Inits)) then
3272 Init := First (Expressions (Inits));
3273 while Present (Init) loop
3274 Analyze_Initialization_Item (Init);
3279 if Present (Component_Associations (Inits)) then
3280 Init := First (Component_Associations (Inits));
3281 while Present (Init) loop
3282 Analyze_Initialization_Item_With_Inputs (Init);
3287 -- Ensure that a state and a corresponding constituent do not appear
3288 -- together in pragma Initializes.
3290 Check_State_And_Constituent_Use
3291 (States => States_Seen,
3292 Constits => Constits_Seen,
3295 Set_Is_Analyzed_Pragma (N);
3296 end Analyze_Initializes_In_Decl_Part;
3298 ---------------------
3299 -- Analyze_Part_Of --
3300 ---------------------
3302 procedure Analyze_Part_Of
3304 Item_Id : Entity_Id;
3306 Encap_Id : out Entity_Id;
3307 Legal : out Boolean)
3309 procedure Check_Part_Of_Abstract_State;
3310 pragma Inline (Check_Part_Of_Abstract_State);
3311 -- Verify the legality of indicator Part_Of when the encapsulator is an
3314 procedure Check_Part_Of_Concurrent_Type;
3315 pragma Inline (Check_Part_Of_Concurrent_Type);
3316 -- Verify the legality of indicator Part_Of when the encapsulator is a
3317 -- single concurrent type.
3319 ----------------------------------
3320 -- Check_Part_Of_Abstract_State --
3321 ----------------------------------
3323 procedure Check_Part_Of_Abstract_State is
3324 Pack_Id : Entity_Id;
3325 Placement : State_Space_Kind;
3326 Parent_Unit : Entity_Id;
3329 -- Determine where the object, package instantiation or state lives
3330 -- with respect to the enclosing packages or package bodies.
3332 Find_Placement_In_State_Space
3333 (Item_Id => Item_Id,
3334 Placement => Placement,
3335 Pack_Id => Pack_Id);
3337 -- The item appears in a non-package construct with a declarative
3338 -- part (subprogram, block, etc). As such, the item is not allowed
3339 -- to be a part of an encapsulating state because the item is not
3342 if Placement = Not_In_Package then
3344 ("indicator Part_Of cannot appear in this context "
3345 & "(SPARK RM 7.2.6(5))", Indic);
3347 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3349 ("\& is not part of the hidden state of package %",
3353 -- The item appears in the visible state space of some package. In
3354 -- general this scenario does not warrant Part_Of except when the
3355 -- package is a nongeneric private child unit and the encapsulating
3356 -- state is declared in a parent unit or a public descendant of that
3359 elsif Placement = Visible_State_Space then
3360 if Is_Child_Unit (Pack_Id)
3361 and then not Is_Generic_Unit (Pack_Id)
3362 and then Is_Private_Descendant (Pack_Id)
3364 -- A variable or state abstraction which is part of the visible
3365 -- state of a nongeneric private child unit or its public
3366 -- descendants must have its Part_Of indicator specified. The
3367 -- Part_Of indicator must denote a state declared by either the
3368 -- parent unit of the private unit or by a public descendant of
3369 -- that parent unit.
3371 -- Find the nearest private ancestor (which can be the current
3374 Parent_Unit := Pack_Id;
3375 while Present (Parent_Unit) loop
3378 (Parent (Unit_Declaration_Node (Parent_Unit)));
3379 Parent_Unit := Scope (Parent_Unit);
3382 Parent_Unit := Scope (Parent_Unit);
3384 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3386 ("indicator Part_Of must denote abstract state of & or of "
3387 & "its public descendant (SPARK RM 7.2.6(3))",
3388 Indic, Parent_Unit);
3391 elsif Scope (Encap_Id) = Parent_Unit
3393 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3394 and then not Is_Private_Descendant (Scope (Encap_Id)))
3400 ("indicator Part_Of must denote abstract state of & or of "
3401 & "its public descendant (SPARK RM 7.2.6(3))",
3402 Indic, Parent_Unit);
3406 -- Indicator Part_Of is not needed when the related package is
3407 -- not a nongeneric private child unit or a public descendant
3412 ("indicator Part_Of cannot appear in this context "
3413 & "(SPARK RM 7.2.6(5))", Indic);
3415 Error_Msg_Name_1 := Chars (Pack_Id);
3417 ("\& is declared in the visible part of package %",
3422 -- When the item appears in the private state space of a package, the
3423 -- encapsulating state must be declared in the same package.
3425 elsif Placement = Private_State_Space then
3426 if Scope (Encap_Id) /= Pack_Id then
3428 ("indicator Part_Of must denote an abstract state of "
3429 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3431 Error_Msg_Name_1 := Chars (Pack_Id);
3433 ("\& is declared in the private part of package %",
3438 -- Items declared in the body state space of a package do not need
3439 -- Part_Of indicators as the refinement has already been seen.
3443 ("indicator Part_Of cannot appear in this context "
3444 & "(SPARK RM 7.2.6(5))", Indic);
3446 if Scope (Encap_Id) = Pack_Id then
3447 Error_Msg_Name_1 := Chars (Pack_Id);
3449 ("\& is declared in the body of package %", Indic, Item_Id);
3455 -- At this point it is known that the Part_Of indicator is legal
3458 end Check_Part_Of_Abstract_State;
3460 -----------------------------------
3461 -- Check_Part_Of_Concurrent_Type --
3462 -----------------------------------
3464 procedure Check_Part_Of_Concurrent_Type is
3465 function In_Proper_Order
3467 Second : Node_Id) return Boolean;
3468 pragma Inline (In_Proper_Order);
3469 -- Determine whether node First precedes node Second
3471 procedure Placement_Error;
3472 pragma Inline (Placement_Error);
3473 -- Emit an error concerning the illegal placement of the item with
3474 -- respect to the single concurrent type.
3476 ---------------------
3477 -- In_Proper_Order --
3478 ---------------------
3480 function In_Proper_Order
3482 Second : Node_Id) return Boolean
3487 if List_Containing (First) = List_Containing (Second) then
3489 while Present (N) loop
3499 end In_Proper_Order;
3501 ---------------------
3502 -- Placement_Error --
3503 ---------------------
3505 procedure Placement_Error is
3508 ("indicator Part_Of must denote a previously declared single "
3509 & "protected type or single task type", Encap);
3510 end Placement_Error;
3514 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3515 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3516 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3518 Item_Context : Node_Id;
3519 Item_Decl : Node_Id;
3520 Prv_Decls : List_Id;
3521 Vis_Decls : List_Id;
3523 -- Start of processing for Check_Part_Of_Concurrent_Type
3526 -- Only abstract states and variables can act as constituents of an
3527 -- encapsulating single concurrent type.
3529 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
3532 -- The constituent is a constant
3534 elsif Ekind (Item_Id) = E_Constant then
3535 Error_Msg_Name_1 := Chars (Encap_Id);
3537 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3538 & "single protected type %"), Indic, Item_Id);
3541 -- The constituent is a package instantiation
3544 Error_Msg_Name_1 := Chars (Encap_Id);
3546 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3547 & "constituent of single protected type %"), Indic, Item_Id);
3551 -- When the item denotes an abstract state of a nested package, use
3552 -- the declaration of the package to detect proper placement.
3557 -- with Abstract_State => (State with Part_Of => T)
3559 if Ekind (Item_Id) = E_Abstract_State then
3560 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3562 Item_Decl := Declaration_Node (Item_Id);
3565 Item_Context := Parent (Item_Decl);
3567 -- The item and the single concurrent type must appear in the same
3568 -- declarative region, with the item following the declaration of
3569 -- the single concurrent type (SPARK RM 9(3)).
3571 if Item_Context = Encap_Context then
3572 if Nkind (Item_Context) in N_Package_Specification
3573 | N_Protected_Definition
3576 Prv_Decls := Private_Declarations (Item_Context);
3577 Vis_Decls := Visible_Declarations (Item_Context);
3579 -- The placement is OK when the single concurrent type appears
3580 -- within the visible declarations and the item in the private
3586 -- Constit : ... with Part_Of => PO;
3589 if List_Containing (Encap_Decl) = Vis_Decls
3590 and then List_Containing (Item_Decl) = Prv_Decls
3594 -- The placement is illegal when the item appears within the
3595 -- visible declarations and the single concurrent type is in
3596 -- the private declarations.
3599 -- Constit : ... with Part_Of => PO;
3604 elsif List_Containing (Item_Decl) = Vis_Decls
3605 and then List_Containing (Encap_Decl) = Prv_Decls
3610 -- Otherwise both the item and the single concurrent type are
3611 -- in the same list. Ensure that the declaration of the single
3612 -- concurrent type precedes that of the item.
3614 elsif not In_Proper_Order
3615 (First => Encap_Decl,
3616 Second => Item_Decl)
3622 -- Otherwise both the item and the single concurrent type are
3623 -- in the same list. Ensure that the declaration of the single
3624 -- concurrent type precedes that of the item.
3626 elsif not In_Proper_Order
3627 (First => Encap_Decl,
3628 Second => Item_Decl)
3634 -- Otherwise the item and the single concurrent type reside within
3635 -- unrelated regions.
3638 Error_Msg_Name_1 := Chars (Encap_Id);
3640 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3641 & "immediately within the same region as single protected "
3642 & "type %"), Indic, Item_Id);
3646 -- At this point it is known that the Part_Of indicator is legal
3649 end Check_Part_Of_Concurrent_Type;
3651 -- Start of processing for Analyze_Part_Of
3654 -- Assume that the indicator is illegal
3660 N_Expanded_Name | N_Identifier | N_Selected_Component
3663 Resolve_State (Encap);
3665 Encap_Id := Entity (Encap);
3667 -- The encapsulator is an abstract state
3669 if Ekind (Encap_Id) = E_Abstract_State then
3672 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3674 elsif Is_Single_Concurrent_Object (Encap_Id) then
3677 -- Otherwise the encapsulator is not a legal choice
3681 ("indicator Part_Of must denote abstract state, single "
3682 & "protected type or single task type", Encap);
3686 -- This is a syntax error, always report
3690 ("indicator Part_Of must denote abstract state, single protected "
3691 & "type or single task type", Encap);
3695 -- Catch a case where indicator Part_Of denotes the abstract view of a
3696 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3698 if From_Limited_With (Encap_Id)
3699 and then Present (Non_Limited_View (Encap_Id))
3700 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3702 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3703 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3707 -- The encapsulator is an abstract state
3709 if Ekind (Encap_Id) = E_Abstract_State then
3710 Check_Part_Of_Abstract_State;
3712 -- The encapsulator is a single concurrent type
3715 Check_Part_Of_Concurrent_Type;
3717 end Analyze_Part_Of;
3719 ----------------------------------
3720 -- Analyze_Part_Of_In_Decl_Part --
3721 ----------------------------------
3723 procedure Analyze_Part_Of_In_Decl_Part
3725 Freeze_Id : Entity_Id := Empty)
3727 Encap : constant Node_Id :=
3728 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3729 Errors : constant Nat := Serious_Errors_Detected;
3730 Var_Decl : constant Node_Id := Find_Related_Context (N);
3731 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3732 Constits : Elist_Id;
3733 Encap_Id : Entity_Id;
3737 -- Detect any discrepancies between the placement of the variable with
3738 -- respect to general state space and the encapsulating state or single
3745 Encap_Id => Encap_Id,
3748 -- The Part_Of indicator turns the variable into a constituent of the
3749 -- encapsulating state or single concurrent type.
3752 pragma Assert (Present (Encap_Id));
3753 Constits := Part_Of_Constituents (Encap_Id);
3755 if No (Constits) then
3756 Constits := New_Elmt_List;
3757 Set_Part_Of_Constituents (Encap_Id, Constits);
3760 Append_Elmt (Var_Id, Constits);
3761 Set_Encapsulating_State (Var_Id, Encap_Id);
3763 -- A Part_Of constituent partially refines an abstract state. This
3764 -- property does not apply to protected or task units.
3766 if Ekind (Encap_Id) = E_Abstract_State then
3767 Set_Has_Partial_Visible_Refinement (Encap_Id);
3771 -- Emit a clarification message when the encapsulator is undefined,
3772 -- possibly due to contract freezing.
3774 if Errors /= Serious_Errors_Detected
3775 and then Present (Freeze_Id)
3776 and then Has_Undefined_Reference (Encap)
3778 Contract_Freeze_Error (Var_Id, Freeze_Id);
3780 end Analyze_Part_Of_In_Decl_Part;
3782 --------------------
3783 -- Analyze_Pragma --
3784 --------------------
3786 procedure Analyze_Pragma (N : Node_Id) is
3787 Loc : constant Source_Ptr := Sloc (N);
3789 Pname : Name_Id := Pragma_Name (N);
3790 -- Name of the source pragma, or name of the corresponding aspect for
3791 -- pragmas which originate in a source aspect. In the latter case, the
3792 -- name may be different from the pragma name.
3794 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3796 Pragma_Exit : exception;
3797 -- This exception is used to exit pragma processing completely. It
3798 -- is used when an error is detected, and no further processing is
3799 -- required. It is also used if an earlier error has left the tree in
3800 -- a state where the pragma should not be processed.
3803 -- Number of pragma argument associations
3810 -- First five pragma arguments (pragma argument association nodes, or
3811 -- Empty if the corresponding argument does not exist).
3813 type Name_List is array (Natural range <>) of Name_Id;
3814 type Args_List is array (Natural range <>) of Node_Id;
3815 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3817 -----------------------
3818 -- Local Subprograms --
3819 -----------------------
3821 procedure Ada_2005_Pragma;
3822 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3823 -- Ada 95 mode, these are implementation defined pragmas, so should be
3824 -- caught by the No_Implementation_Pragmas restriction.
3826 procedure Ada_2012_Pragma;
3827 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3828 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3829 -- should be caught by the No_Implementation_Pragmas restriction.
3831 procedure Analyze_Depends_Global
3832 (Spec_Id : out Entity_Id;
3833 Subp_Decl : out Node_Id;
3834 Legal : out Boolean);
3835 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3836 -- legality of the placement and related context of the pragma. Spec_Id
3837 -- is the entity of the related subprogram. Subp_Decl is the declaration
3838 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3840 procedure Analyze_If_Present (Id : Pragma_Id);
3841 -- Inspect the remainder of the list containing pragma N and look for
3842 -- a pragma that matches Id. If found, analyze the pragma.
3844 procedure Analyze_Pre_Post_Condition;
3845 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3847 procedure Analyze_Refined_Depends_Global_Post
3848 (Spec_Id : out Entity_Id;
3849 Body_Id : out Entity_Id;
3850 Legal : out Boolean);
3851 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3852 -- Refined_Global and Refined_Post. Verify the legality of the placement
3853 -- and related context of the pragma. Spec_Id is the entity of the
3854 -- related subprogram. Body_Id is the entity of the subprogram body.
3855 -- Flag Legal is set when the pragma is legal.
3857 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3858 -- Perform full analysis of pragma Unmodified and the write aspect of
3859 -- pragma Unused. Flag Is_Unused should be set when verifying the
3860 -- semantics of pragma Unused.
3862 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3863 -- Perform full analysis of pragma Unreferenced and the read aspect of
3864 -- pragma Unused. Flag Is_Unused should be set when verifying the
3865 -- semantics of pragma Unused.
3867 procedure Check_Ada_83_Warning;
3868 -- Issues a warning message for the current pragma if operating in Ada
3869 -- 83 mode (used for language pragmas that are not a standard part of
3870 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3873 procedure Check_Arg_Count (Required : Nat);
3874 -- Check argument count for pragma is equal to given parameter. If not,
3875 -- then issue an error message and raise Pragma_Exit.
3877 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3878 -- Arg which can either be a pragma argument association, in which case
3879 -- the check is applied to the expression of the association or an
3880 -- expression directly.
3882 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3883 -- Check that an argument has the right form for an EXTERNAL_NAME
3884 -- parameter of an extended import/export pragma. The rule is that the
3885 -- name must be an identifier or string literal (in Ada 83 mode) or a
3886 -- static string expression (in Ada 95 mode).
3888 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3889 -- Check the specified argument Arg to make sure that it is an
3890 -- identifier. If not give error and raise Pragma_Exit.
3892 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3893 -- Check the specified argument Arg to make sure that it is an integer
3894 -- literal. If not give error and raise Pragma_Exit.
3896 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3897 -- Check the specified argument Arg to make sure that it has the proper
3898 -- syntactic form for a local name and meets the semantic requirements
3899 -- for a local name. The local name is analyzed as part of the
3900 -- processing for this call. In addition, the local name is required
3901 -- to represent an entity at the library level.
3903 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3904 -- Check the specified argument Arg to make sure that it has the proper
3905 -- syntactic form for a local name and meets the semantic requirements
3906 -- for a local name. The local name is analyzed as part of the
3907 -- processing for this call.
3909 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3910 -- Check the specified argument Arg to make sure that it is a valid
3911 -- locking policy name. If not give error and raise Pragma_Exit.
3913 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3914 -- Check the specified argument Arg to make sure that it is a valid
3915 -- elaboration policy name. If not give error and raise Pragma_Exit.
3917 procedure Check_Arg_Is_One_Of
3920 procedure Check_Arg_Is_One_Of
3922 N1, N2, N3 : Name_Id);
3923 procedure Check_Arg_Is_One_Of
3925 N1, N2, N3, N4 : Name_Id);
3926 procedure Check_Arg_Is_One_Of
3928 N1, N2, N3, N4, N5 : Name_Id);
3929 -- Check the specified argument Arg to make sure that it is an
3930 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3931 -- present). If not then give error and raise Pragma_Exit.
3933 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3934 -- Check the specified argument Arg to make sure that it is a valid
3935 -- queuing policy name. If not give error and raise Pragma_Exit.
3937 procedure Check_Arg_Is_OK_Static_Expression
3939 Typ : Entity_Id := Empty);
3940 -- Check the specified argument Arg to make sure that it is a static
3941 -- expression of the given type (i.e. it will be analyzed and resolved
3942 -- using this type, which can be any valid argument to Resolve, e.g.
3943 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3944 -- Typ is left Empty, then any static expression is allowed. Includes
3945 -- checking that the argument does not raise Constraint_Error.
3947 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3948 -- Check the specified argument Arg to make sure that it is a valid task
3949 -- dispatching policy name. If not give error and raise Pragma_Exit.
3951 procedure Check_Arg_Order (Names : Name_List);
3952 -- Checks for an instance of two arguments with identifiers for the
3953 -- current pragma which are not in the sequence indicated by Names,
3954 -- and if so, generates a fatal message about bad order of arguments.
3956 procedure Check_At_Least_N_Arguments (N : Nat);
3957 -- Check there are at least N arguments present
3959 procedure Check_At_Most_N_Arguments (N : Nat);
3960 -- Check there are no more than N arguments present
3962 procedure Check_Component
3965 In_Variant_Part : Boolean := False);
3966 -- Examine an Unchecked_Union component for correct use of per-object
3967 -- constrained subtypes, and for restrictions on finalizable components.
3968 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3969 -- should be set when Comp comes from a record variant.
3971 procedure Check_Duplicate_Pragma (E : Entity_Id);
3972 -- Check if a rep item of the same name as the current pragma is already
3973 -- chained as a rep pragma to the given entity. If so give a message
3974 -- about the duplicate, and then raise Pragma_Exit so does not return.
3975 -- Note that if E is a type, then this routine avoids flagging a pragma
3976 -- which applies to a parent type from which E is derived.
3978 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3979 -- Nam is an N_String_Literal node containing the external name set by
3980 -- an Import or Export pragma (or extended Import or Export pragma).
3981 -- This procedure checks for possible duplications if this is the export
3982 -- case, and if found, issues an appropriate error message.
3984 procedure Check_Expr_Is_OK_Static_Expression
3986 Typ : Entity_Id := Empty);
3987 -- Check the specified expression Expr to make sure that it is a static
3988 -- expression of the given type (i.e. it will be analyzed and resolved
3989 -- using this type, which can be any valid argument to Resolve, e.g.
3990 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3991 -- Typ is left Empty, then any static expression is allowed. Includes
3992 -- checking that the expression does not raise Constraint_Error.
3994 procedure Check_First_Subtype (Arg : Node_Id);
3995 -- Checks that Arg, whose expression is an entity name, references a
3998 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3999 -- Checks that the given argument has an identifier, and if so, requires
4000 -- it to match the given identifier name. If there is no identifier, or
4001 -- a non-matching identifier, then an error message is given and
4002 -- Pragma_Exit is raised.
4004 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
4005 -- Checks that the given argument has an identifier, and if so, requires
4006 -- it to match one of the given identifier names. If there is no
4007 -- identifier, or a non-matching identifier, then an error message is
4008 -- given and Pragma_Exit is raised.
4010 procedure Check_In_Main_Program;
4011 -- Common checks for pragmas that appear within a main program
4012 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4014 procedure Check_Interrupt_Or_Attach_Handler;
4015 -- Common processing for first argument of pragma Interrupt_Handler or
4016 -- pragma Attach_Handler.
4018 procedure Check_Loop_Pragma_Placement;
4019 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4020 -- appear immediately within a construct restricted to loops, and that
4021 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4023 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4024 -- Check that pragma appears in a declarative part, or in a package
4025 -- specification, i.e. that it does not occur in a statement sequence
4028 procedure Check_No_Identifier (Arg : Node_Id);
4029 -- Checks that the given argument does not have an identifier. If
4030 -- an identifier is present, then an error message is issued, and
4031 -- Pragma_Exit is raised.
4033 procedure Check_No_Identifiers;
4034 -- Checks that none of the arguments to the pragma has an identifier.
4035 -- If any argument has an identifier, then an error message is issued,
4036 -- and Pragma_Exit is raised.
4038 procedure Check_No_Link_Name;
4039 -- Checks that no link name is specified
4041 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4042 -- Checks if the given argument has an identifier, and if so, requires
4043 -- it to match the given identifier name. If there is a non-matching
4044 -- identifier, then an error message is given and Pragma_Exit is raised.
4046 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4047 -- Checks if the given argument has an identifier, and if so, requires
4048 -- it to match the given identifier name. If there is a non-matching
4049 -- identifier, then an error message is given and Pragma_Exit is raised.
4050 -- In this version of the procedure, the identifier name is given as
4051 -- a string with lower case letters.
4053 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4054 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4055 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4056 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4057 -- is an OK static boolean expression. Emit an error if this is not the
4060 procedure Check_Static_Constraint (Constr : Node_Id);
4061 -- Constr is a constraint from an N_Subtype_Indication node from a
4062 -- component constraint in an Unchecked_Union type. This routine checks
4063 -- that the constraint is static as required by the restrictions for
4066 procedure Check_Valid_Configuration_Pragma;
4067 -- Legality checks for placement of a configuration pragma
4069 procedure Check_Valid_Library_Unit_Pragma;
4070 -- Legality checks for library unit pragmas. A special case arises for
4071 -- pragmas in generic instances that come from copies of the original
4072 -- library unit pragmas in the generic templates. In the case of other
4073 -- than library level instantiations these can appear in contexts which
4074 -- would normally be invalid (they only apply to the original template
4075 -- and to library level instantiations), and they are simply ignored,
4076 -- which is implemented by rewriting them as null statements and raising
4077 -- exception to terminate analysis.
4079 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4080 -- Check an Unchecked_Union variant for lack of nested variants and
4081 -- presence of at least one component. UU_Typ is the related Unchecked_
4084 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4085 -- Subsidiary routine to the processing of pragmas Abstract_State,
4086 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4087 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4088 -- argument Arg into an aggregate if not one already. N_Null is never
4089 -- transformed. Arg may denote an aspect specification or a pragma
4090 -- argument association.
4092 procedure Error_Pragma (Msg : String);
4093 pragma No_Return (Error_Pragma);
4094 -- Outputs error message for current pragma. The message contains a %
4095 -- that will be replaced with the pragma name, and the flag is placed
4096 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4097 -- calls Fix_Error (see spec of that procedure for details).
4099 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4100 pragma No_Return (Error_Pragma_Arg);
4101 -- Outputs error message for current pragma. The message may contain
4102 -- a % that will be replaced with the pragma name. The parameter Arg
4103 -- may either be a pragma argument association, in which case the flag
4104 -- is placed on the expression of this association, or an expression,
4105 -- in which case the flag is placed directly on the expression. The
4106 -- message is placed using Error_Msg_N, so the message may also contain
4107 -- an & insertion character which will reference the given Arg value.
4108 -- After placing the message, Pragma_Exit is raised. Note: this routine
4109 -- calls Fix_Error (see spec of that procedure for details).
4111 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4112 pragma No_Return (Error_Pragma_Arg);
4113 -- Similar to above form of Error_Pragma_Arg except that two messages
4114 -- are provided, the second is a continuation comment starting with \.
4116 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4117 pragma No_Return (Error_Pragma_Arg_Ident);
4118 -- Outputs error message for current pragma. The message may contain a %
4119 -- that will be replaced with the pragma name. The parameter Arg must be
4120 -- a pragma argument association with a non-empty identifier (i.e. its
4121 -- Chars field must be set), and the error message is placed on the
4122 -- identifier. The message is placed using Error_Msg_N so the message
4123 -- may also contain an & insertion character which will reference
4124 -- the identifier. After placing the message, Pragma_Exit is raised.
4125 -- Note: this routine calls Fix_Error (see spec of that procedure for
4128 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4129 pragma No_Return (Error_Pragma_Ref);
4130 -- Outputs error message for current pragma. The message may contain
4131 -- a % that will be replaced with the pragma name. The parameter Ref
4132 -- must be an entity whose name can be referenced by & and sloc by #.
4133 -- After placing the message, Pragma_Exit is raised. Note: this routine
4134 -- calls Fix_Error (see spec of that procedure for details).
4136 function Find_Lib_Unit_Name return Entity_Id;
4137 -- Used for a library unit pragma to find the entity to which the
4138 -- library unit pragma applies, returns the entity found.
4140 procedure Find_Program_Unit_Name (Id : Node_Id);
4141 -- If the pragma is a compilation unit pragma, the id must denote the
4142 -- compilation unit in the same compilation, and the pragma must appear
4143 -- in the list of preceding or trailing pragmas. If it is a program
4144 -- unit pragma that is not a compilation unit pragma, then the
4145 -- identifier must be visible.
4147 function Find_Unique_Parameterless_Procedure
4149 Arg : Node_Id) return Entity_Id;
4150 -- Used for a procedure pragma to find the unique parameterless
4151 -- procedure identified by Name, returns it if it exists, otherwise
4152 -- errors out and uses Arg as the pragma argument for the message.
4154 function Fix_Error (Msg : String) return String;
4155 -- This is called prior to issuing an error message. Msg is the normal
4156 -- error message issued in the pragma case. This routine checks for the
4157 -- case of a pragma coming from an aspect in the source, and returns a
4158 -- message suitable for the aspect case as follows:
4160 -- Each substring "pragma" is replaced by "aspect"
4162 -- If "argument of" is at the start of the error message text, it is
4163 -- replaced by "entity for".
4165 -- If "argument" is at the start of the error message text, it is
4166 -- replaced by "entity".
4168 -- So for example, "argument of pragma X must be discrete type"
4169 -- returns "entity for aspect X must be a discrete type".
4171 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4172 -- be different from the pragma name). If the current pragma results
4173 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4174 -- original pragma name.
4176 procedure Gather_Associations
4178 Args : out Args_List);
4179 -- This procedure is used to gather the arguments for a pragma that
4180 -- permits arbitrary ordering of parameters using the normal rules
4181 -- for named and positional parameters. The Names argument is a list
4182 -- of Name_Id values that corresponds to the allowed pragma argument
4183 -- association identifiers in order. The result returned in Args is
4184 -- a list of corresponding expressions that are the pragma arguments.
4185 -- Note that this is a list of expressions, not of pragma argument
4186 -- associations (Gather_Associations has completely checked all the
4187 -- optional identifiers when it returns). An entry in Args is Empty
4188 -- on return if the corresponding argument is not present.
4190 procedure GNAT_Pragma;
4191 -- Called for all GNAT defined pragmas to check the relevant restriction
4192 -- (No_Implementation_Pragmas).
4194 function Is_Before_First_Decl
4195 (Pragma_Node : Node_Id;
4196 Decls : List_Id) return Boolean;
4197 -- Return True if Pragma_Node is before the first declarative item in
4198 -- Decls where Decls is the list of declarative items.
4200 function Is_Configuration_Pragma return Boolean;
4201 -- Determines if the placement of the current pragma is appropriate
4202 -- for a configuration pragma.
4204 function Is_In_Context_Clause return Boolean;
4205 -- Returns True if pragma appears within the context clause of a unit,
4206 -- and False for any other placement (does not generate any messages).
4208 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4209 -- Analyzes the argument, and determines if it is a static string
4210 -- expression, returns True if so, False if non-static or not String.
4211 -- A special case is that a string literal returns True in Ada 83 mode
4212 -- (which has no such thing as static string expressions). Note that
4213 -- the call analyzes its argument, so this cannot be used for the case
4214 -- where an identifier might not be declared.
4216 procedure Pragma_Misplaced;
4217 pragma No_Return (Pragma_Misplaced);
4218 -- Issue fatal error message for misplaced pragma
4220 procedure Process_Atomic_Independent_Shared_Volatile;
4221 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4222 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4223 -- and treated as being identical in effect to pragma Atomic.
4225 procedure Process_Compile_Time_Warning_Or_Error;
4226 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4228 procedure Process_Convention
4229 (C : out Convention_Id;
4230 Ent : out Entity_Id);
4231 -- Common processing for Convention, Interface, Import and Export.
4232 -- Checks first two arguments of pragma, and sets the appropriate
4233 -- convention value in the specified entity or entities. On return
4234 -- C is the convention, Ent is the referenced entity.
4236 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4237 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4238 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4240 procedure Process_Extended_Import_Export_Object_Pragma
4241 (Arg_Internal : Node_Id;
4242 Arg_External : Node_Id;
4243 Arg_Size : Node_Id);
4244 -- Common processing for the pragmas Import/Export_Object. The three
4245 -- arguments correspond to the three named parameters of the pragmas. An
4246 -- argument is empty if the corresponding parameter is not present in
4249 procedure Process_Extended_Import_Export_Internal_Arg
4250 (Arg_Internal : Node_Id := Empty);
4251 -- Common processing for all extended Import and Export pragmas. The
4252 -- argument is the pragma parameter for the Internal argument. If
4253 -- Arg_Internal is empty or inappropriate, an error message is posted.
4254 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4255 -- set to identify the referenced entity.
4257 procedure Process_Extended_Import_Export_Subprogram_Pragma
4258 (Arg_Internal : Node_Id;
4259 Arg_External : Node_Id;
4260 Arg_Parameter_Types : Node_Id;
4261 Arg_Result_Type : Node_Id := Empty;
4262 Arg_Mechanism : Node_Id;
4263 Arg_Result_Mechanism : Node_Id := Empty);
4264 -- Common processing for all extended Import and Export pragmas applying
4265 -- to subprograms. The caller omits any arguments that do not apply to
4266 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4267 -- only in the Import_Function and Export_Function cases). The argument
4268 -- names correspond to the allowed pragma association identifiers.
4270 procedure Process_Generic_List;
4271 -- Common processing for Share_Generic and Inline_Generic
4273 procedure Process_Import_Or_Interface;
4274 -- Common processing for Import or Interface
4276 procedure Process_Import_Predefined_Type;
4277 -- Processing for completing a type with pragma Import. This is used
4278 -- to declare types that match predefined C types, especially for cases
4279 -- without corresponding Ada predefined type.
4281 type Inline_Status is (Suppressed, Disabled, Enabled);
4282 -- Inline status of a subprogram, indicated as follows:
4283 -- Suppressed: inlining is suppressed for the subprogram
4284 -- Disabled: no inlining is requested for the subprogram
4285 -- Enabled: inlining is requested/required for the subprogram
4287 procedure Process_Inline (Status : Inline_Status);
4288 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4289 -- indicates the inline status specified by the pragma.
4291 procedure Process_Interface_Name
4292 (Subprogram_Def : Entity_Id;
4296 -- Given the last two arguments of pragma Import, pragma Export, or
4297 -- pragma Interface_Name, performs validity checks and sets the
4298 -- Interface_Name field of the given subprogram entity to the
4299 -- appropriate external or link name, depending on the arguments given.
4300 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4301 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4302 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4303 -- nor Link_Arg is present, the interface name is set to the default
4304 -- from the subprogram name. In addition, the pragma itself is passed
4305 -- to analyze any expressions in the case the pragma came from an aspect
4308 procedure Process_Interrupt_Or_Attach_Handler;
4309 -- Common processing for Interrupt and Attach_Handler pragmas
4311 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4312 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4313 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4314 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4315 -- is not set in the Restrictions case.
4317 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4318 -- Common processing for Suppress and Unsuppress. The boolean parameter
4319 -- Suppress_Case is True for the Suppress case, and False for the
4322 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4323 -- Subsidiary to the analysis of pragmas Independent[_Components].
4324 -- Record such a pragma N applied to entity E for future checks.
4326 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4327 -- This procedure sets the Is_Exported flag for the given entity,
4328 -- checking that the entity was not previously imported. Arg is
4329 -- the argument that specified the entity. A check is also made
4330 -- for exporting inappropriate entities.
4332 procedure Set_Extended_Import_Export_External_Name
4333 (Internal_Ent : Entity_Id;
4334 Arg_External : Node_Id);
4335 -- Common processing for all extended import export pragmas. The first
4336 -- argument, Internal_Ent, is the internal entity, which has already
4337 -- been checked for validity by the caller. Arg_External is from the
4338 -- Import or Export pragma, and may be null if no External parameter
4339 -- was present. If Arg_External is present and is a non-null string
4340 -- (a null string is treated as the default), then the Interface_Name
4341 -- field of Internal_Ent is set appropriately.
4343 procedure Set_Imported (E : Entity_Id);
4344 -- This procedure sets the Is_Imported flag for the given entity,
4345 -- checking that it is not previously exported or imported.
4347 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4348 -- Mech is a parameter passing mechanism (see Import_Function syntax
4349 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4350 -- has the right form, and if not issues an error message. If the
4351 -- argument has the right form then the Mechanism field of Ent is
4352 -- set appropriately.
4354 procedure Set_Rational_Profile;
4355 -- Activate the set of configuration pragmas and permissions that make
4356 -- up the Rational profile.
4358 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4359 -- Activate the set of configuration pragmas and restrictions that make
4360 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4361 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4362 -- pragma node, which is used for error messages on any constructs
4363 -- violating the profile.
4365 ---------------------
4366 -- Ada_2005_Pragma --
4367 ---------------------
4369 procedure Ada_2005_Pragma is
4371 if Ada_Version <= Ada_95 then
4372 Check_Restriction (No_Implementation_Pragmas, N);
4374 end Ada_2005_Pragma;
4376 ---------------------
4377 -- Ada_2012_Pragma --
4378 ---------------------
4380 procedure Ada_2012_Pragma is
4382 if Ada_Version <= Ada_2005 then
4383 Check_Restriction (No_Implementation_Pragmas, N);
4385 end Ada_2012_Pragma;
4387 ----------------------------
4388 -- Analyze_Depends_Global --
4389 ----------------------------
4391 procedure Analyze_Depends_Global
4392 (Spec_Id : out Entity_Id;
4393 Subp_Decl : out Node_Id;
4394 Legal : out Boolean)
4397 -- Assume that the pragma is illegal
4404 Check_Arg_Count (1);
4406 -- Ensure the proper placement of the pragma. Depends/Global must be
4407 -- associated with a subprogram declaration or a body that acts as a
4410 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4414 if Nkind (Subp_Decl) = N_Entry_Declaration then
4417 -- Generic subprogram
4419 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4422 -- Object declaration of a single concurrent type
4424 elsif Nkind (Subp_Decl) = N_Object_Declaration
4425 and then Is_Single_Concurrent_Object
4426 (Unique_Defining_Entity (Subp_Decl))
4432 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4435 -- Subprogram body acts as spec
4437 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4438 and then No (Corresponding_Spec (Subp_Decl))
4442 -- Subprogram body stub acts as spec
4444 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4445 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4449 -- Subprogram declaration
4451 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4453 -- Pragmas Global and Depends are forbidden on null procedures
4454 -- (SPARK RM 6.1.2(2)).
4456 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4457 and then Null_Present (Specification (Subp_Decl))
4459 Error_Msg_N (Fix_Error
4460 ("pragma % cannot apply to null procedure"), N);
4466 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4474 -- If we get here, then the pragma is legal
4477 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4479 -- When the related context is an entry, the entry must belong to a
4480 -- protected unit (SPARK RM 6.1.4(6)).
4482 if Is_Entry_Declaration (Spec_Id)
4483 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4488 -- When the related context is an anonymous object created for a
4489 -- simple concurrent type, the type must be a task
4490 -- (SPARK RM 6.1.4(6)).
4492 elsif Is_Single_Concurrent_Object (Spec_Id)
4493 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4499 -- A pragma that applies to a Ghost entity becomes Ghost for the
4500 -- purposes of legality checks and removal of ignored Ghost code.
4502 Mark_Ghost_Pragma (N, Spec_Id);
4503 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4504 end Analyze_Depends_Global;
4506 ------------------------
4507 -- Analyze_If_Present --
4508 ------------------------
4510 procedure Analyze_If_Present (Id : Pragma_Id) is
4514 pragma Assert (Is_List_Member (N));
4516 -- Inspect the declarations or statements following pragma N looking
4517 -- for another pragma whose Id matches the caller's request. If it is
4518 -- available, analyze it.
4521 while Present (Stmt) loop
4522 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4523 Analyze_Pragma (Stmt);
4526 -- The first source declaration or statement immediately following
4527 -- N ends the region where a pragma may appear.
4529 elsif Comes_From_Source (Stmt) then
4535 end Analyze_If_Present;
4537 --------------------------------
4538 -- Analyze_Pre_Post_Condition --
4539 --------------------------------
4541 procedure Analyze_Pre_Post_Condition is
4542 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4543 Subp_Decl : Node_Id;
4544 Subp_Id : Entity_Id;
4546 Duplicates_OK : Boolean := False;
4547 -- Flag set when a pre/postcondition allows multiple pragmas of the
4550 In_Body_OK : Boolean := False;
4551 -- Flag set when a pre/postcondition is allowed to appear on a body
4552 -- even though the subprogram may have a spec.
4554 Is_Pre_Post : Boolean := False;
4555 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4558 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4559 -- Implement rules in AI12-0131: an overriding operation can have
4560 -- a class-wide precondition only if one of its ancestors has an
4561 -- explicit class-wide precondition.
4563 -----------------------------
4564 -- Inherits_Class_Wide_Pre --
4565 -----------------------------
4567 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4568 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4571 Prev : Entity_Id := Overridden_Operation (E);
4574 -- Check ancestors on the overriding operation to examine the
4575 -- preconditions that may apply to them.
4577 while Present (Prev) loop
4578 Cont := Contract (Prev);
4579 if Present (Cont) then
4580 Prag := Pre_Post_Conditions (Cont);
4581 while Present (Prag) loop
4582 if Pragma_Name (Prag) = Name_Precondition
4583 and then Class_Present (Prag)
4588 Prag := Next_Pragma (Prag);
4592 -- For a type derived from a generic formal type, the operation
4593 -- inheriting the condition is a renaming, not an overriding of
4594 -- the operation of the formal. Ditto for an inherited
4595 -- operation which has no explicit contracts.
4597 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4598 or else not Comes_From_Source (Prev)
4600 Prev := Alias (Prev);
4602 Prev := Overridden_Operation (Prev);
4606 -- If the controlling type of the subprogram has progenitors, an
4607 -- interface operation implemented by the current operation may
4608 -- have a class-wide precondition.
4610 if Has_Interfaces (Typ) then
4615 Prim_Elmt : Elmt_Id;
4616 Prim_List : Elist_Id;
4619 Collect_Interfaces (Typ, Ints);
4620 Elmt := First_Elmt (Ints);
4622 -- Iterate over the primitive operations of each interface
4624 while Present (Elmt) loop
4625 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4626 Prim_Elmt := First_Elmt (Prim_List);
4627 while Present (Prim_Elmt) loop
4628 Prim := Node (Prim_Elmt);
4629 if Chars (Prim) = Chars (E)
4630 and then Present (Contract (Prim))
4631 and then Class_Present
4632 (Pre_Post_Conditions (Contract (Prim)))
4637 Next_Elmt (Prim_Elmt);
4646 end Inherits_Class_Wide_Pre;
4648 -- Start of processing for Analyze_Pre_Post_Condition
4651 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4652 -- offer uniformity among the various kinds of pre/postconditions by
4653 -- rewriting the pragma identifier. This allows the retrieval of the
4654 -- original pragma name by routine Original_Aspect_Pragma_Name.
4656 if Comes_From_Source (N) then
4657 if Pname in Name_Pre | Name_Pre_Class then
4658 Is_Pre_Post := True;
4659 Set_Class_Present (N, Pname = Name_Pre_Class);
4660 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4662 elsif Pname in Name_Post | Name_Post_Class then
4663 Is_Pre_Post := True;
4664 Set_Class_Present (N, Pname = Name_Post_Class);
4665 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4669 -- Determine the semantics with respect to duplicates and placement
4670 -- in a body. Pragmas Precondition and Postcondition were introduced
4671 -- before aspects and are not subject to the same aspect-like rules.
4673 if Pname in Name_Precondition | Name_Postcondition then
4674 Duplicates_OK := True;
4680 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4681 -- argument without an identifier.
4684 Check_Arg_Count (1);
4685 Check_No_Identifiers;
4687 -- Pragmas Precondition and Postcondition have complex argument
4691 Check_At_Least_N_Arguments (1);
4692 Check_At_Most_N_Arguments (2);
4693 Check_Optional_Identifier (Arg1, Name_Check);
4695 if Present (Arg2) then
4696 Check_Optional_Identifier (Arg2, Name_Message);
4697 Preanalyze_Spec_Expression
4698 (Get_Pragma_Arg (Arg2), Standard_String);
4702 -- For a pragma PPC in the extended main source unit, record enabled
4704 -- ??? nothing checks that the pragma is in the main source unit
4706 if Is_Checked (N) and then not Split_PPC (N) then
4707 Set_SCO_Pragma_Enabled (Loc);
4710 -- Ensure the proper placement of the pragma
4713 Find_Related_Declaration_Or_Body
4714 (N, Do_Checks => not Duplicates_OK);
4716 -- When a pre/postcondition pragma applies to an abstract subprogram,
4717 -- its original form must be an aspect with 'Class.
4719 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4720 if not From_Aspect_Specification (N) then
4722 ("pragma % cannot be applied to abstract subprogram");
4724 elsif not Class_Present (N) then
4726 ("aspect % requires ''Class for abstract subprogram");
4729 -- Entry declaration
4731 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4734 -- Generic subprogram declaration
4736 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4741 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4742 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4746 -- Subprogram body stub
4748 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4749 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4753 -- Subprogram declaration
4755 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4757 -- AI05-0230: When a pre/postcondition pragma applies to a null
4758 -- procedure, its original form must be an aspect with 'Class.
4760 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4761 and then Null_Present (Specification (Subp_Decl))
4762 and then From_Aspect_Specification (N)
4763 and then not Class_Present (N)
4765 Error_Pragma ("aspect % requires ''Class for null procedure");
4768 -- Implement the legality checks mandated by AI12-0131:
4769 -- Pre'Class shall not be specified for an overriding primitive
4770 -- subprogram of a tagged type T unless the Pre'Class aspect is
4771 -- specified for the corresponding primitive subprogram of some
4775 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4778 if Class_Present (N)
4779 and then Pragma_Name (N) = Name_Precondition
4780 and then Present (Overridden_Operation (E))
4781 and then not Inherits_Class_Wide_Pre (E)
4784 ("illegal class-wide precondition on overriding operation",
4785 Corresponding_Aspect (N));
4789 -- A renaming declaration may inherit a generated pragma, its
4790 -- placement comes from expansion, not from source.
4792 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4793 and then not Comes_From_Source (N)
4797 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4799 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4800 and then Ada_Version >= Ada_2020
4804 -- An access-to-subprogram type can have pre/postconditions, but
4805 -- these are transferred to the generated subprogram wrapper and
4808 -- Otherwise the placement of the pragma is illegal
4815 Subp_Id := Defining_Entity (Subp_Decl);
4817 -- A pragma that applies to a Ghost entity becomes Ghost for the
4818 -- purposes of legality checks and removal of ignored Ghost code.
4820 Mark_Ghost_Pragma (N, Subp_Id);
4822 -- Chain the pragma on the contract for further processing by
4823 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4825 Add_Contract_Item (N, Subp_Id);
4827 -- Fully analyze the pragma when it appears inside an entry or
4828 -- subprogram body because it cannot benefit from forward references.
4830 if Nkind (Subp_Decl) in N_Entry_Body
4832 | N_Subprogram_Body_Stub
4834 -- The legality checks of pragmas Precondition and Postcondition
4835 -- are affected by the SPARK mode in effect and the volatility of
4836 -- the context. Analyze all pragmas in a specific order.
4838 Analyze_If_Present (Pragma_SPARK_Mode);
4839 Analyze_If_Present (Pragma_Volatile_Function);
4840 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4842 end Analyze_Pre_Post_Condition;
4844 -----------------------------------------
4845 -- Analyze_Refined_Depends_Global_Post --
4846 -----------------------------------------
4848 procedure Analyze_Refined_Depends_Global_Post
4849 (Spec_Id : out Entity_Id;
4850 Body_Id : out Entity_Id;
4851 Legal : out Boolean)
4853 Body_Decl : Node_Id;
4854 Spec_Decl : Node_Id;
4857 -- Assume that the pragma is illegal
4864 Check_Arg_Count (1);
4865 Check_No_Identifiers;
4867 -- Verify the placement of the pragma and check for duplicates. The
4868 -- pragma must apply to a subprogram body [stub].
4870 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4872 if Nkind (Body_Decl) not in
4873 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
4874 N_Task_Body | N_Task_Body_Stub
4880 Body_Id := Defining_Entity (Body_Decl);
4881 Spec_Id := Unique_Defining_Entity (Body_Decl);
4883 -- The pragma must apply to the second declaration of a subprogram.
4884 -- In other words, the body [stub] cannot acts as a spec.
4886 if No (Spec_Id) then
4887 Error_Pragma ("pragma % cannot apply to a stand alone body");
4890 -- Catch the case where the subprogram body is a subunit and acts as
4891 -- the third declaration of the subprogram.
4893 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4894 Error_Pragma ("pragma % cannot apply to a subunit");
4898 -- A refined pragma can only apply to the body [stub] of a subprogram
4899 -- declared in the visible part of a package. Retrieve the context of
4900 -- the subprogram declaration.
4902 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4904 -- When dealing with protected entries or protected subprograms, use
4905 -- the enclosing protected type as the proper context.
4907 if Ekind (Spec_Id) in E_Entry
4911 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4913 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4916 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4918 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4919 & "subprogram declared in a package specification"));
4923 -- If we get here, then the pragma is legal
4927 -- A pragma that applies to a Ghost entity becomes Ghost for the
4928 -- purposes of legality checks and removal of ignored Ghost code.
4930 Mark_Ghost_Pragma (N, Spec_Id);
4932 if Pname in Name_Refined_Depends | Name_Refined_Global then
4933 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4935 end Analyze_Refined_Depends_Global_Post;
4937 ----------------------------------
4938 -- Analyze_Unmodified_Or_Unused --
4939 ----------------------------------
4941 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4946 Ghost_Error_Posted : Boolean := False;
4947 -- Flag set when an error concerning the illegal mix of Ghost and
4948 -- non-Ghost variables is emitted.
4950 Ghost_Id : Entity_Id := Empty;
4951 -- The entity of the first Ghost variable encountered while
4952 -- processing the arguments of the pragma.
4956 Check_At_Least_N_Arguments (1);
4958 -- Loop through arguments
4961 while Present (Arg) loop
4962 Check_No_Identifier (Arg);
4964 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4965 -- in fact generate reference, so that the entity will have a
4966 -- reference, which will inhibit any warnings about it not
4967 -- being referenced, and also properly show up in the ali file
4968 -- as a reference. But this reference is recorded before the
4969 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4970 -- generated for this reference.
4972 Check_Arg_Is_Local_Name (Arg);
4973 Arg_Expr := Get_Pragma_Arg (Arg);
4975 if Is_Entity_Name (Arg_Expr) then
4976 Arg_Id := Entity (Arg_Expr);
4978 -- Skip processing the argument if already flagged
4980 if Is_Assignable (Arg_Id)
4981 and then not Has_Pragma_Unmodified (Arg_Id)
4982 and then not Has_Pragma_Unused (Arg_Id)
4984 Set_Has_Pragma_Unmodified (Arg_Id);
4987 Set_Has_Pragma_Unused (Arg_Id);
4990 -- A pragma that applies to a Ghost entity becomes Ghost for
4991 -- the purposes of legality checks and removal of ignored
4994 Mark_Ghost_Pragma (N, Arg_Id);
4996 -- Capture the entity of the first Ghost variable being
4997 -- processed for error detection purposes.
4999 if Is_Ghost_Entity (Arg_Id) then
5000 if No (Ghost_Id) then
5004 -- Otherwise the variable is non-Ghost. It is illegal to mix
5005 -- references to Ghost and non-Ghost entities
5008 elsif Present (Ghost_Id)
5009 and then not Ghost_Error_Posted
5011 Ghost_Error_Posted := True;
5013 Error_Msg_Name_1 := Pname;
5015 ("pragma % cannot mention ghost and non-ghost "
5018 Error_Msg_Sloc := Sloc (Ghost_Id);
5019 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5021 Error_Msg_Sloc := Sloc (Arg_Id);
5022 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5025 -- Warn if already flagged as Unused or Unmodified
5027 elsif Has_Pragma_Unmodified (Arg_Id) then
5028 if Has_Pragma_Unused (Arg_Id) then
5030 ("??pragma Unused already given for &!", Arg_Expr,
5034 ("??pragma Unmodified already given for &!", Arg_Expr,
5038 -- Otherwise the pragma referenced an illegal entity
5042 ("pragma% can only be applied to a variable", Arg_Expr);
5048 end Analyze_Unmodified_Or_Unused;
5050 ------------------------------------
5051 -- Analyze_Unreferenced_Or_Unused --
5052 ------------------------------------
5054 procedure Analyze_Unreferenced_Or_Unused
5055 (Is_Unused : Boolean := False)
5062 Ghost_Error_Posted : Boolean := False;
5063 -- Flag set when an error concerning the illegal mix of Ghost and
5064 -- non-Ghost names is emitted.
5066 Ghost_Id : Entity_Id := Empty;
5067 -- The entity of the first Ghost name encountered while processing
5068 -- the arguments of the pragma.
5072 Check_At_Least_N_Arguments (1);
5074 -- Check case of appearing within context clause
5076 if not Is_Unused and then Is_In_Context_Clause then
5078 -- The arguments must all be units mentioned in a with clause in
5079 -- the same context clause. Note that Par.Prag already checked
5080 -- that the arguments are either identifiers or selected
5084 while Present (Arg) loop
5085 Citem := First (List_Containing (N));
5086 while Citem /= N loop
5087 Arg_Expr := Get_Pragma_Arg (Arg);
5089 if Nkind (Citem) = N_With_Clause
5090 and then Same_Name (Name (Citem), Arg_Expr)
5092 Set_Has_Pragma_Unreferenced
5095 (Library_Unit (Citem))));
5096 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5105 ("argument of pragma% is not withed unit", Arg);
5111 -- Case of not in list of context items
5115 while Present (Arg) loop
5116 Check_No_Identifier (Arg);
5118 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5119 -- in fact generate reference, so that the entity will have a
5120 -- reference, which will inhibit any warnings about it not
5121 -- being referenced, and also properly show up in the ali file
5122 -- as a reference. But this reference is recorded before the
5123 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5124 -- generated for this reference.
5126 Check_Arg_Is_Local_Name (Arg);
5127 Arg_Expr := Get_Pragma_Arg (Arg);
5129 if Is_Entity_Name (Arg_Expr) then
5130 Arg_Id := Entity (Arg_Expr);
5132 -- Warn if already flagged as Unused or Unreferenced and
5133 -- skip processing the argument.
5135 if Has_Pragma_Unreferenced (Arg_Id) then
5136 if Has_Pragma_Unused (Arg_Id) then
5138 ("??pragma Unused already given for &!", Arg_Expr,
5142 ("??pragma Unreferenced already given for &!",
5146 -- Apply Unreferenced to the entity
5149 -- If the entity is overloaded, the pragma applies to the
5150 -- most recent overloading, as documented. In this case,
5151 -- name resolution does not generate a reference, so it
5152 -- must be done here explicitly.
5154 if Is_Overloaded (Arg_Expr) then
5155 Generate_Reference (Arg_Id, N);
5158 Set_Has_Pragma_Unreferenced (Arg_Id);
5161 Set_Has_Pragma_Unused (Arg_Id);
5164 -- A pragma that applies to a Ghost entity becomes Ghost
5165 -- for the purposes of legality checks and removal of
5166 -- ignored Ghost code.
5168 Mark_Ghost_Pragma (N, Arg_Id);
5170 -- Capture the entity of the first Ghost name being
5171 -- processed for error detection purposes.
5173 if Is_Ghost_Entity (Arg_Id) then
5174 if No (Ghost_Id) then
5178 -- Otherwise the name is non-Ghost. It is illegal to mix
5179 -- references to Ghost and non-Ghost entities
5182 elsif Present (Ghost_Id)
5183 and then not Ghost_Error_Posted
5185 Ghost_Error_Posted := True;
5187 Error_Msg_Name_1 := Pname;
5189 ("pragma % cannot mention ghost and non-ghost "
5192 Error_Msg_Sloc := Sloc (Ghost_Id);
5194 ("\& # declared as ghost", N, Ghost_Id);
5196 Error_Msg_Sloc := Sloc (Arg_Id);
5198 ("\& # declared as non-ghost", N, Arg_Id);
5206 end Analyze_Unreferenced_Or_Unused;
5208 --------------------------
5209 -- Check_Ada_83_Warning --
5210 --------------------------
5212 procedure Check_Ada_83_Warning is
5214 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5215 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5217 end Check_Ada_83_Warning;
5219 ---------------------
5220 -- Check_Arg_Count --
5221 ---------------------
5223 procedure Check_Arg_Count (Required : Nat) is
5225 if Arg_Count /= Required then
5226 Error_Pragma ("wrong number of arguments for pragma%");
5228 end Check_Arg_Count;
5230 --------------------------------
5231 -- Check_Arg_Is_External_Name --
5232 --------------------------------
5234 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5235 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5238 if Nkind (Argx) = N_Identifier then
5242 Analyze_And_Resolve (Argx, Standard_String);
5244 if Is_OK_Static_Expression (Argx) then
5247 elsif Etype (Argx) = Any_Type then
5250 -- An interesting special case, if we have a string literal and
5251 -- we are in Ada 83 mode, then we allow it even though it will
5252 -- not be flagged as static. This allows expected Ada 83 mode
5253 -- use of external names which are string literals, even though
5254 -- technically these are not static in Ada 83.
5256 elsif Ada_Version = Ada_83
5257 and then Nkind (Argx) = N_String_Literal
5261 -- Here we have a real error (non-static expression)
5264 Error_Msg_Name_1 := Pname;
5265 Flag_Non_Static_Expr
5266 (Fix_Error ("argument for pragma% must be a identifier or "
5267 & "static string expression!"), Argx);
5272 end Check_Arg_Is_External_Name;
5274 -----------------------------
5275 -- Check_Arg_Is_Identifier --
5276 -----------------------------
5278 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5279 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5281 if Nkind (Argx) /= N_Identifier then
5282 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5284 end Check_Arg_Is_Identifier;
5286 ----------------------------------
5287 -- Check_Arg_Is_Integer_Literal --
5288 ----------------------------------
5290 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5291 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5293 if Nkind (Argx) /= N_Integer_Literal then
5295 ("argument for pragma% must be integer literal", Argx);
5297 end Check_Arg_Is_Integer_Literal;
5299 -------------------------------------------
5300 -- Check_Arg_Is_Library_Level_Local_Name --
5301 -------------------------------------------
5305 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5306 -- | library_unit_NAME
5308 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5310 Check_Arg_Is_Local_Name (Arg);
5312 -- If it came from an aspect, we want to give the error just as if it
5313 -- came from source.
5315 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5316 and then (Comes_From_Source (N)
5317 or else Present (Corresponding_Aspect (Parent (Arg))))
5320 ("argument for pragma% must be library level entity", Arg);
5322 end Check_Arg_Is_Library_Level_Local_Name;
5324 -----------------------------
5325 -- Check_Arg_Is_Local_Name --
5326 -----------------------------
5330 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5331 -- | library_unit_NAME
5333 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5334 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5337 -- If this pragma came from an aspect specification, we don't want to
5338 -- check for this error, because that would cause spurious errors, in
5339 -- case a type is frozen in a scope more nested than the type. The
5340 -- aspect itself of course can't be anywhere but on the declaration
5343 if Nkind (Arg) = N_Pragma_Argument_Association then
5344 if From_Aspect_Specification (Parent (Arg)) then
5348 -- Arg is the Expression of an N_Pragma_Argument_Association
5351 if From_Aspect_Specification (Parent (Parent (Arg))) then
5358 if Nkind (Argx) not in N_Direct_Name
5359 and then (Nkind (Argx) /= N_Attribute_Reference
5360 or else Present (Expressions (Argx))
5361 or else Nkind (Prefix (Argx)) /= N_Identifier)
5362 and then (not Is_Entity_Name (Argx)
5363 or else not Is_Compilation_Unit (Entity (Argx)))
5365 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5368 -- No further check required if not an entity name
5370 if not Is_Entity_Name (Argx) then
5376 Ent : constant Entity_Id := Entity (Argx);
5377 Scop : constant Entity_Id := Scope (Ent);
5380 -- Case of a pragma applied to a compilation unit: pragma must
5381 -- occur immediately after the program unit in the compilation.
5383 if Is_Compilation_Unit (Ent) then
5385 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5388 -- Case of pragma placed immediately after spec
5390 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5393 -- Case of pragma placed immediately after body
5395 elsif Nkind (Decl) = N_Subprogram_Declaration
5396 and then Present (Corresponding_Body (Decl))
5400 (Parent (Unit_Declaration_Node
5401 (Corresponding_Body (Decl))));
5403 -- All other cases are illegal
5410 -- Special restricted placement rule from 10.2.1(11.8/2)
5412 elsif Is_Generic_Formal (Ent)
5413 and then Prag_Id = Pragma_Preelaborable_Initialization
5415 OK := List_Containing (N) =
5416 Generic_Formal_Declarations
5417 (Unit_Declaration_Node (Scop));
5419 -- If this is an aspect applied to a subprogram body, the
5420 -- pragma is inserted in its declarative part.
5422 elsif From_Aspect_Specification (N)
5423 and then Ent = Current_Scope
5425 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5429 -- If the aspect is a predicate (possibly others ???) and the
5430 -- context is a record type, this is a discriminant expression
5431 -- within a type declaration, that freezes the predicated
5434 elsif From_Aspect_Specification (N)
5435 and then Prag_Id = Pragma_Predicate
5436 and then Ekind (Current_Scope) = E_Record_Type
5437 and then Scop = Scope (Current_Scope)
5441 -- Default case, just check that the pragma occurs in the scope
5442 -- of the entity denoted by the name.
5445 OK := Current_Scope = Scop;
5450 ("pragma% argument must be in same declarative part", Arg);
5454 end Check_Arg_Is_Local_Name;
5456 ---------------------------------
5457 -- Check_Arg_Is_Locking_Policy --
5458 ---------------------------------
5460 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5461 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5464 Check_Arg_Is_Identifier (Argx);
5466 if not Is_Locking_Policy_Name (Chars (Argx)) then
5467 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5469 end Check_Arg_Is_Locking_Policy;
5471 -----------------------------------------------
5472 -- Check_Arg_Is_Partition_Elaboration_Policy --
5473 -----------------------------------------------
5475 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5476 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5479 Check_Arg_Is_Identifier (Argx);
5481 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5483 ("& is not a valid partition elaboration policy name", Argx);
5485 end Check_Arg_Is_Partition_Elaboration_Policy;
5487 -------------------------
5488 -- Check_Arg_Is_One_Of --
5489 -------------------------
5491 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5492 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5495 Check_Arg_Is_Identifier (Argx);
5497 if Chars (Argx) not in N1 | N2 then
5498 Error_Msg_Name_2 := N1;
5499 Error_Msg_Name_3 := N2;
5500 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5502 end Check_Arg_Is_One_Of;
5504 procedure Check_Arg_Is_One_Of
5506 N1, N2, N3 : Name_Id)
5508 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5511 Check_Arg_Is_Identifier (Argx);
5513 if Chars (Argx) not in N1 | N2 | N3 then
5514 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5516 end Check_Arg_Is_One_Of;
5518 procedure Check_Arg_Is_One_Of
5520 N1, N2, N3, N4 : Name_Id)
5522 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5525 Check_Arg_Is_Identifier (Argx);
5527 if Chars (Argx) not in N1 | N2 | N3 | N4 then
5528 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5530 end Check_Arg_Is_One_Of;
5532 procedure Check_Arg_Is_One_Of
5534 N1, N2, N3, N4, N5 : Name_Id)
5536 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5539 Check_Arg_Is_Identifier (Argx);
5541 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
5542 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5544 end Check_Arg_Is_One_Of;
5546 ---------------------------------
5547 -- Check_Arg_Is_Queuing_Policy --
5548 ---------------------------------
5550 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5551 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5554 Check_Arg_Is_Identifier (Argx);
5556 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5557 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5559 end Check_Arg_Is_Queuing_Policy;
5561 ---------------------------------------
5562 -- Check_Arg_Is_OK_Static_Expression --
5563 ---------------------------------------
5565 procedure Check_Arg_Is_OK_Static_Expression
5567 Typ : Entity_Id := Empty)
5570 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5571 end Check_Arg_Is_OK_Static_Expression;
5573 ------------------------------------------
5574 -- Check_Arg_Is_Task_Dispatching_Policy --
5575 ------------------------------------------
5577 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5578 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5581 Check_Arg_Is_Identifier (Argx);
5583 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5585 ("& is not an allowed task dispatching policy name", Argx);
5587 end Check_Arg_Is_Task_Dispatching_Policy;
5589 ---------------------
5590 -- Check_Arg_Order --
5591 ---------------------
5593 procedure Check_Arg_Order (Names : Name_List) is
5596 Highest_So_Far : Natural := 0;
5597 -- Highest index in Names seen do far
5601 for J in 1 .. Arg_Count loop
5602 if Chars (Arg) /= No_Name then
5603 for K in Names'Range loop
5604 if Chars (Arg) = Names (K) then
5605 if K < Highest_So_Far then
5606 Error_Msg_Name_1 := Pname;
5608 ("parameters out of order for pragma%", Arg);
5609 Error_Msg_Name_1 := Names (K);
5610 Error_Msg_Name_2 := Names (Highest_So_Far);
5611 Error_Msg_N ("\% must appear before %", Arg);
5615 Highest_So_Far := K;
5623 end Check_Arg_Order;
5625 --------------------------------
5626 -- Check_At_Least_N_Arguments --
5627 --------------------------------
5629 procedure Check_At_Least_N_Arguments (N : Nat) is
5631 if Arg_Count < N then
5632 Error_Pragma ("too few arguments for pragma%");
5634 end Check_At_Least_N_Arguments;
5636 -------------------------------
5637 -- Check_At_Most_N_Arguments --
5638 -------------------------------
5640 procedure Check_At_Most_N_Arguments (N : Nat) is
5643 if Arg_Count > N then
5645 for J in 1 .. N loop
5647 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5650 end Check_At_Most_N_Arguments;
5652 ---------------------
5653 -- Check_Component --
5654 ---------------------
5656 procedure Check_Component
5659 In_Variant_Part : Boolean := False)
5661 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5662 Sindic : constant Node_Id :=
5663 Subtype_Indication (Component_Definition (Comp));
5664 Typ : constant Entity_Id := Etype (Comp_Id);
5667 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5668 -- object constraint, then the component type shall be an Unchecked_
5671 if Nkind (Sindic) = N_Subtype_Indication
5672 and then Has_Per_Object_Constraint (Comp_Id)
5673 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5676 ("component subtype subject to per-object constraint "
5677 & "must be an Unchecked_Union", Comp);
5679 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5680 -- the body of a generic unit, or within the body of any of its
5681 -- descendant library units, no part of the type of a component
5682 -- declared in a variant_part of the unchecked union type shall be of
5683 -- a formal private type or formal private extension declared within
5684 -- the formal part of the generic unit.
5686 elsif Ada_Version >= Ada_2012
5687 and then In_Generic_Body (UU_Typ)
5688 and then In_Variant_Part
5689 and then Is_Private_Type (Typ)
5690 and then Is_Generic_Type (Typ)
5693 ("component of unchecked union cannot be of generic type", Comp);
5695 elsif Needs_Finalization (Typ) then
5697 ("component of unchecked union cannot be controlled", Comp);
5699 elsif Has_Task (Typ) then
5701 ("component of unchecked union cannot have tasks", Comp);
5703 end Check_Component;
5705 ----------------------------
5706 -- Check_Duplicate_Pragma --
5707 ----------------------------
5709 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5710 Id : Entity_Id := E;
5714 -- Nothing to do if this pragma comes from an aspect specification,
5715 -- since we could not be duplicating a pragma, and we dealt with the
5716 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5718 if From_Aspect_Specification (N) then
5722 -- Otherwise current pragma may duplicate previous pragma or a
5723 -- previously given aspect specification or attribute definition
5724 -- clause for the same pragma.
5726 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5730 -- If the entity is a type, then we have to make sure that the
5731 -- ostensible duplicate is not for a parent type from which this
5735 if Nkind (P) = N_Pragma then
5737 Args : constant List_Id :=
5738 Pragma_Argument_Associations (P);
5741 and then Is_Entity_Name (Expression (First (Args)))
5742 and then Is_Type (Entity (Expression (First (Args))))
5743 and then Entity (Expression (First (Args))) /= E
5749 elsif Nkind (P) = N_Aspect_Specification
5750 and then Is_Type (Entity (P))
5751 and then Entity (P) /= E
5757 -- Here we have a definite duplicate
5759 Error_Msg_Name_1 := Pragma_Name (N);
5760 Error_Msg_Sloc := Sloc (P);
5762 -- For a single protected or a single task object, the error is
5763 -- issued on the original entity.
5765 if Ekind (Id) in E_Task_Type | E_Protected_Type then
5766 Id := Defining_Identifier (Original_Node (Parent (Id)));
5769 if Nkind (P) = N_Aspect_Specification
5770 or else From_Aspect_Specification (P)
5772 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5774 -- If -gnatwr is set, warn in case of a duplicate pragma
5775 -- [No_]Inline which is suspicious but not an error, generate
5776 -- an error for other pragmas.
5778 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
5779 if Warn_On_Redundant_Constructs then
5781 ("?r?pragma% for & duplicates pragma#", N, Id);
5784 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5790 end Check_Duplicate_Pragma;
5792 ----------------------------------
5793 -- Check_Duplicated_Export_Name --
5794 ----------------------------------
5796 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5797 String_Val : constant String_Id := Strval (Nam);
5800 -- We are only interested in the export case, and in the case of
5801 -- generics, it is the instance, not the template, that is the
5802 -- problem (the template will generate a warning in any case).
5804 if not Inside_A_Generic
5805 and then (Prag_Id = Pragma_Export
5807 Prag_Id = Pragma_Export_Procedure
5809 Prag_Id = Pragma_Export_Valued_Procedure
5811 Prag_Id = Pragma_Export_Function)
5813 for J in Externals.First .. Externals.Last loop
5814 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5815 Error_Msg_Sloc := Sloc (Externals.Table (J));
5816 Error_Msg_N ("external name duplicates name given#", Nam);
5821 Externals.Append (Nam);
5823 end Check_Duplicated_Export_Name;
5825 ----------------------------------------
5826 -- Check_Expr_Is_OK_Static_Expression --
5827 ----------------------------------------
5829 procedure Check_Expr_Is_OK_Static_Expression
5831 Typ : Entity_Id := Empty)
5834 if Present (Typ) then
5835 Analyze_And_Resolve (Expr, Typ);
5837 Analyze_And_Resolve (Expr);
5840 -- An expression cannot be considered static if its resolution failed
5841 -- or if it's erroneous. Stop the analysis of the related pragma.
5843 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5846 elsif Is_OK_Static_Expression (Expr) then
5849 -- An interesting special case, if we have a string literal and we
5850 -- are in Ada 83 mode, then we allow it even though it will not be
5851 -- flagged as static. This allows the use of Ada 95 pragmas like
5852 -- Import in Ada 83 mode. They will of course be flagged with
5853 -- warnings as usual, but will not cause errors.
5855 elsif Ada_Version = Ada_83
5856 and then Nkind (Expr) = N_String_Literal
5860 -- Finally, we have a real error
5863 Error_Msg_Name_1 := Pname;
5864 Flag_Non_Static_Expr
5865 (Fix_Error ("argument for pragma% must be a static expression!"),
5869 end Check_Expr_Is_OK_Static_Expression;
5871 -------------------------
5872 -- Check_First_Subtype --
5873 -------------------------
5875 procedure Check_First_Subtype (Arg : Node_Id) is
5876 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5877 Ent : constant Entity_Id := Entity (Argx);
5880 if Is_First_Subtype (Ent) then
5883 elsif Is_Type (Ent) then
5885 ("pragma% cannot apply to subtype", Argx);
5887 elsif Is_Object (Ent) then
5889 ("pragma% cannot apply to object, requires a type", Argx);
5893 ("pragma% cannot apply to&, requires a type", Argx);
5895 end Check_First_Subtype;
5897 ----------------------
5898 -- Check_Identifier --
5899 ----------------------
5901 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5904 and then Nkind (Arg) = N_Pragma_Argument_Association
5906 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5907 Error_Msg_Name_1 := Pname;
5908 Error_Msg_Name_2 := Id;
5909 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5913 end Check_Identifier;
5915 --------------------------------
5916 -- Check_Identifier_Is_One_Of --
5917 --------------------------------
5919 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5922 and then Nkind (Arg) = N_Pragma_Argument_Association
5924 if Chars (Arg) = No_Name then
5925 Error_Msg_Name_1 := Pname;
5926 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5929 elsif Chars (Arg) /= N1
5930 and then Chars (Arg) /= N2
5932 Error_Msg_Name_1 := Pname;
5933 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5937 end Check_Identifier_Is_One_Of;
5939 ---------------------------
5940 -- Check_In_Main_Program --
5941 ---------------------------
5943 procedure Check_In_Main_Program is
5944 P : constant Node_Id := Parent (N);
5947 -- Must be in subprogram body
5949 if Nkind (P) /= N_Subprogram_Body then
5950 Error_Pragma ("% pragma allowed only in subprogram");
5952 -- Otherwise warn if obviously not main program
5954 elsif Present (Parameter_Specifications (Specification (P)))
5955 or else not Is_Compilation_Unit (Defining_Entity (P))
5957 Error_Msg_Name_1 := Pname;
5959 ("??pragma% is only effective in main program", N);
5961 end Check_In_Main_Program;
5963 ---------------------------------------
5964 -- Check_Interrupt_Or_Attach_Handler --
5965 ---------------------------------------
5967 procedure Check_Interrupt_Or_Attach_Handler is
5968 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5969 Handler_Proc, Proc_Scope : Entity_Id;
5974 if Prag_Id = Pragma_Interrupt_Handler then
5975 Check_Restriction (No_Dynamic_Attachment, N);
5978 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5979 Proc_Scope := Scope (Handler_Proc);
5981 if Ekind (Proc_Scope) /= E_Protected_Type then
5983 ("argument of pragma% must be protected procedure", Arg1);
5986 -- For pragma case (as opposed to access case), check placement.
5987 -- We don't need to do that for aspects, because we have the
5988 -- check that they aspect applies an appropriate procedure.
5990 if not From_Aspect_Specification (N)
5991 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5993 Error_Pragma ("pragma% must be in protected definition");
5996 if not Is_Library_Level_Entity (Proc_Scope) then
5998 ("argument for pragma% must be library level entity", Arg1);
6001 -- AI05-0033: A pragma cannot appear within a generic body, because
6002 -- instance can be in a nested scope. The check that protected type
6003 -- is itself a library-level declaration is done elsewhere.
6005 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6006 -- handle code prior to AI-0033. Analysis tools typically are not
6007 -- interested in this pragma in any case, so no need to worry too
6008 -- much about its placement.
6010 if Inside_A_Generic then
6011 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6012 and then In_Package_Body (Scope (Current_Scope))
6013 and then not Relaxed_RM_Semantics
6015 Error_Pragma ("pragma% cannot be used inside a generic");
6018 end Check_Interrupt_Or_Attach_Handler;
6020 ---------------------------------
6021 -- Check_Loop_Pragma_Placement --
6022 ---------------------------------
6024 procedure Check_Loop_Pragma_Placement is
6025 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6026 -- Verify whether the current pragma is properly grouped with other
6027 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6028 -- related loop where the pragma appears.
6030 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6031 -- Determine whether an arbitrary statement Stmt denotes pragma
6032 -- Loop_Invariant or Loop_Variant.
6034 procedure Placement_Error (Constr : Node_Id);
6035 pragma No_Return (Placement_Error);
6036 -- Node Constr denotes the last loop restricted construct before we
6037 -- encountered an illegal relation between enclosing constructs. Emit
6038 -- an error depending on what Constr was.
6040 --------------------------------
6041 -- Check_Loop_Pragma_Grouping --
6042 --------------------------------
6044 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6045 Stop_Search : exception;
6046 -- This exception is used to terminate the recursive descent of
6047 -- routine Check_Grouping.
6049 procedure Check_Grouping (L : List_Id);
6050 -- Find the first group of pragmas in list L and if successful,
6051 -- ensure that the current pragma is part of that group. The
6052 -- routine raises Stop_Search once such a check is performed to
6053 -- halt the recursive descent.
6055 procedure Grouping_Error (Prag : Node_Id);
6056 pragma No_Return (Grouping_Error);
6057 -- Emit an error concerning the current pragma indicating that it
6058 -- should be placed after pragma Prag.
6060 --------------------
6061 -- Check_Grouping --
6062 --------------------
6064 procedure Check_Grouping (L : List_Id) is
6067 Prag : Node_Id := Empty; -- init to avoid warning
6070 -- Inspect the list of declarations or statements looking for
6071 -- the first grouping of pragmas:
6074 -- pragma Loop_Invariant ...;
6075 -- pragma Loop_Variant ...;
6077 -- pragma Loop_Variant ...; -- current pragma
6079 -- If the current pragma is not in the grouping, then it must
6080 -- either appear in a different declarative or statement list
6081 -- or the construct at (1) is separating the pragma from the
6085 while Present (Stmt) loop
6087 -- First pragma of the first topmost grouping has been found
6089 if Is_Loop_Pragma (Stmt) then
6091 -- The group and the current pragma are not in the same
6092 -- declarative or statement list.
6094 if not In_Same_List (Stmt, N) then
6095 Grouping_Error (Stmt);
6097 -- Try to reach the current pragma from the first pragma
6098 -- of the grouping while skipping other members:
6100 -- pragma Loop_Invariant ...; -- first pragma
6101 -- pragma Loop_Variant ...; -- member
6103 -- pragma Loop_Variant ...; -- current pragma
6106 while Present (Stmt) loop
6107 -- The current pragma is either the first pragma
6108 -- of the group or is a member of the group.
6109 -- Stop the search as the placement is legal.
6114 -- Skip group members, but keep track of the
6115 -- last pragma in the group.
6117 elsif Is_Loop_Pragma (Stmt) then
6120 -- Skip declarations and statements generated by
6121 -- the compiler during expansion. Note that some
6122 -- source statements (e.g. pragma Assert) may have
6123 -- been transformed so that they do not appear as
6124 -- coming from source anymore, so we instead look
6125 -- at their Original_Node.
6127 elsif not Comes_From_Source (Original_Node (Stmt))
6131 -- A non-pragma is separating the group from the
6132 -- current pragma, the placement is illegal.
6135 Grouping_Error (Prag);
6141 -- If the traversal did not reach the current pragma,
6142 -- then the list must be malformed.
6144 raise Program_Error;
6147 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6148 -- inside a loop or a block housed inside a loop. Inspect
6149 -- the declarations and statements of the block as they may
6150 -- contain the first grouping. This case follows the one for
6151 -- loop pragmas, as block statements which originate in a
6152 -- loop pragma (and so Is_Loop_Pragma will return True on
6153 -- that block statement) should be treated in the previous
6156 elsif Nkind (Stmt) = N_Block_Statement then
6157 HSS := Handled_Statement_Sequence (Stmt);
6159 Check_Grouping (Declarations (Stmt));
6161 if Present (HSS) then
6162 Check_Grouping (Statements (HSS));
6170 --------------------
6171 -- Grouping_Error --
6172 --------------------
6174 procedure Grouping_Error (Prag : Node_Id) is
6176 Error_Msg_Sloc := Sloc (Prag);
6177 Error_Pragma ("pragma% must appear next to pragma#");
6180 -- Start of processing for Check_Loop_Pragma_Grouping
6183 -- Inspect the statements of the loop or nested blocks housed
6184 -- within to determine whether the current pragma is part of the
6185 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6187 Check_Grouping (Statements (Loop_Stmt));
6190 when Stop_Search => null;
6191 end Check_Loop_Pragma_Grouping;
6193 --------------------
6194 -- Is_Loop_Pragma --
6195 --------------------
6197 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6198 Original_Stmt : constant Node_Id := Original_Node (Stmt);
6201 -- Inspect the original node as Loop_Invariant and Loop_Variant
6202 -- pragmas are rewritten to null when assertions are disabled.
6204 return Nkind (Original_Stmt) = N_Pragma
6205 and then Pragma_Name_Unmapped (Original_Stmt)
6206 in Name_Loop_Invariant | Name_Loop_Variant;
6209 ---------------------
6210 -- Placement_Error --
6211 ---------------------
6213 procedure Placement_Error (Constr : Node_Id) is
6214 LA : constant String := " with Loop_Entry";
6217 if Prag_Id = Pragma_Assert then
6218 Error_Msg_String (1 .. LA'Length) := LA;
6219 Error_Msg_Strlen := LA'Length;
6221 Error_Msg_Strlen := 0;
6224 if Nkind (Constr) = N_Pragma then
6226 ("pragma %~ must appear immediately within the statements "
6230 ("block containing pragma %~ must appear immediately within "
6231 & "the statements of a loop", Constr);
6233 end Placement_Error;
6235 -- Local declarations
6240 -- Start of processing for Check_Loop_Pragma_Placement
6243 -- Check that pragma appears immediately within a loop statement,
6244 -- ignoring intervening block statements.
6248 while Present (Stmt) loop
6250 -- The pragma or previous block must appear immediately within the
6251 -- current block's declarative or statement part.
6253 if Nkind (Stmt) = N_Block_Statement then
6254 if (No (Declarations (Stmt))
6255 or else List_Containing (Prev) /= Declarations (Stmt))
6257 List_Containing (Prev) /=
6258 Statements (Handled_Statement_Sequence (Stmt))
6260 Placement_Error (Prev);
6263 -- Keep inspecting the parents because we are now within a
6264 -- chain of nested blocks.
6268 Stmt := Parent (Stmt);
6271 -- The pragma or previous block must appear immediately within the
6272 -- statements of the loop.
6274 elsif Nkind (Stmt) = N_Loop_Statement then
6275 if List_Containing (Prev) /= Statements (Stmt) then
6276 Placement_Error (Prev);
6279 -- Stop the traversal because we reached the innermost loop
6280 -- regardless of whether we encountered an error or not.
6284 -- Ignore a handled statement sequence. Note that this node may
6285 -- be related to a subprogram body in which case we will emit an
6286 -- error on the next iteration of the search.
6288 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6289 Stmt := Parent (Stmt);
6291 -- Any other statement breaks the chain from the pragma to the
6295 Placement_Error (Prev);
6300 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6301 -- grouped together with other such pragmas.
6303 if Is_Loop_Pragma (N) then
6305 -- The previous check should have located the related loop
6307 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6308 Check_Loop_Pragma_Grouping (Stmt);
6310 end Check_Loop_Pragma_Placement;
6312 -------------------------------------------
6313 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6314 -------------------------------------------
6316 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6325 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6328 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6331 -- Note: the following tests seem a little peculiar, because
6332 -- they test for bodies, but if we were in the statement part
6333 -- of the body, we would already have hit the handled statement
6334 -- sequence, so the only way we get here is by being in the
6335 -- declarative part of the body.
6338 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6346 Error_Pragma ("pragma% is not in declarative part or package spec");
6347 end Check_Is_In_Decl_Part_Or_Package_Spec;
6349 -------------------------
6350 -- Check_No_Identifier --
6351 -------------------------
6353 procedure Check_No_Identifier (Arg : Node_Id) is
6355 if Nkind (Arg) = N_Pragma_Argument_Association
6356 and then Chars (Arg) /= No_Name
6358 Error_Pragma_Arg_Ident
6359 ("pragma% does not permit identifier& here", Arg);
6361 end Check_No_Identifier;
6363 --------------------------
6364 -- Check_No_Identifiers --
6365 --------------------------
6367 procedure Check_No_Identifiers is
6371 for J in 1 .. Arg_Count loop
6372 Check_No_Identifier (Arg_Node);
6375 end Check_No_Identifiers;
6377 ------------------------
6378 -- Check_No_Link_Name --
6379 ------------------------
6381 procedure Check_No_Link_Name is
6383 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6387 if Present (Arg4) then
6389 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6391 end Check_No_Link_Name;
6393 -------------------------------
6394 -- Check_Optional_Identifier --
6395 -------------------------------
6397 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6400 and then Nkind (Arg) = N_Pragma_Argument_Association
6401 and then Chars (Arg) /= No_Name
6403 if Chars (Arg) /= Id then
6404 Error_Msg_Name_1 := Pname;
6405 Error_Msg_Name_2 := Id;
6406 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6410 end Check_Optional_Identifier;
6412 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6414 Check_Optional_Identifier (Arg, Name_Find (Id));
6415 end Check_Optional_Identifier;
6417 -------------------------------------
6418 -- Check_Static_Boolean_Expression --
6419 -------------------------------------
6421 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6423 if Present (Expr) then
6424 Analyze_And_Resolve (Expr, Standard_Boolean);
6426 if not Is_OK_Static_Expression (Expr) then
6428 ("expression of pragma % must be static", Expr);
6431 end Check_Static_Boolean_Expression;
6433 -----------------------------
6434 -- Check_Static_Constraint --
6435 -----------------------------
6437 -- Note: for convenience in writing this procedure, in addition to
6438 -- the officially (i.e. by spec) allowed argument which is always a
6439 -- constraint, it also allows ranges and discriminant associations.
6440 -- Above is not clear ???
6442 procedure Check_Static_Constraint (Constr : Node_Id) is
6444 procedure Require_Static (E : Node_Id);
6445 -- Require given expression to be static expression
6447 --------------------
6448 -- Require_Static --
6449 --------------------
6451 procedure Require_Static (E : Node_Id) is
6453 if not Is_OK_Static_Expression (E) then
6454 Flag_Non_Static_Expr
6455 ("non-static constraint not allowed in Unchecked_Union!", E);
6460 -- Start of processing for Check_Static_Constraint
6463 case Nkind (Constr) is
6464 when N_Discriminant_Association =>
6465 Require_Static (Expression (Constr));
6468 Require_Static (Low_Bound (Constr));
6469 Require_Static (High_Bound (Constr));
6471 when N_Attribute_Reference =>
6472 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6473 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6475 when N_Range_Constraint =>
6476 Check_Static_Constraint (Range_Expression (Constr));
6478 when N_Index_Or_Discriminant_Constraint =>
6482 IDC := First (Constraints (Constr));
6483 while Present (IDC) loop
6484 Check_Static_Constraint (IDC);
6492 end Check_Static_Constraint;
6494 --------------------------------------
6495 -- Check_Valid_Configuration_Pragma --
6496 --------------------------------------
6498 -- A configuration pragma must appear in the context clause of a
6499 -- compilation unit, and only other pragmas may precede it. Note that
6500 -- the test also allows use in a configuration pragma file.
6502 procedure Check_Valid_Configuration_Pragma is
6504 if not Is_Configuration_Pragma then
6505 Error_Pragma ("incorrect placement for configuration pragma%");
6507 end Check_Valid_Configuration_Pragma;
6509 -------------------------------------
6510 -- Check_Valid_Library_Unit_Pragma --
6511 -------------------------------------
6513 procedure Check_Valid_Library_Unit_Pragma is
6515 Parent_Node : Node_Id;
6516 Unit_Name : Entity_Id;
6517 Unit_Kind : Node_Kind;
6518 Unit_Node : Node_Id;
6519 Sindex : Source_File_Index;
6522 if not Is_List_Member (N) then
6526 Plist := List_Containing (N);
6527 Parent_Node := Parent (Plist);
6529 if Parent_Node = Empty then
6532 -- Case of pragma appearing after a compilation unit. In this case
6533 -- it must have an argument with the corresponding name and must
6534 -- be part of the following pragmas of its parent.
6536 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6537 if Plist /= Pragmas_After (Parent_Node) then
6540 elsif Arg_Count = 0 then
6542 ("argument required if outside compilation unit");
6545 Check_No_Identifiers;
6546 Check_Arg_Count (1);
6547 Unit_Node := Unit (Parent (Parent_Node));
6548 Unit_Kind := Nkind (Unit_Node);
6550 Analyze (Get_Pragma_Arg (Arg1));
6552 if Unit_Kind = N_Generic_Subprogram_Declaration
6553 or else Unit_Kind = N_Subprogram_Declaration
6555 Unit_Name := Defining_Entity (Unit_Node);
6557 elsif Unit_Kind in N_Generic_Instantiation then
6558 Unit_Name := Defining_Entity (Unit_Node);
6561 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6564 if Chars (Unit_Name) /=
6565 Chars (Entity (Get_Pragma_Arg (Arg1)))
6568 ("pragma% argument is not current unit name", Arg1);
6571 if Ekind (Unit_Name) = E_Package
6572 and then Present (Renamed_Entity (Unit_Name))
6574 Error_Pragma ("pragma% not allowed for renamed package");
6578 -- Pragma appears other than after a compilation unit
6581 -- Here we check for the generic instantiation case and also
6582 -- for the case of processing a generic formal package. We
6583 -- detect these cases by noting that the Sloc on the node
6584 -- does not belong to the current compilation unit.
6586 Sindex := Source_Index (Current_Sem_Unit);
6588 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6589 Rewrite (N, Make_Null_Statement (Loc));
6592 -- If before first declaration, the pragma applies to the
6593 -- enclosing unit, and the name if present must be this name.
6595 elsif Is_Before_First_Decl (N, Plist) then
6596 Unit_Node := Unit_Declaration_Node (Current_Scope);
6597 Unit_Kind := Nkind (Unit_Node);
6599 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6602 elsif Unit_Kind = N_Subprogram_Body
6603 and then not Acts_As_Spec (Unit_Node)
6607 elsif Nkind (Parent_Node) = N_Package_Body then
6610 elsif Nkind (Parent_Node) = N_Package_Specification
6611 and then Plist = Private_Declarations (Parent_Node)
6615 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6616 or else Nkind (Parent_Node) =
6617 N_Generic_Subprogram_Declaration)
6618 and then Plist = Generic_Formal_Declarations (Parent_Node)
6622 elsif Arg_Count > 0 then
6623 Analyze (Get_Pragma_Arg (Arg1));
6625 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6627 ("name in pragma% must be enclosing unit", Arg1);
6630 -- It is legal to have no argument in this context
6636 -- Error if not before first declaration. This is because a
6637 -- library unit pragma argument must be the name of a library
6638 -- unit (RM 10.1.5(7)), but the only names permitted in this
6639 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6640 -- generic subprogram declarations or generic instantiations.
6644 ("pragma% misplaced, must be before first declaration");
6648 end Check_Valid_Library_Unit_Pragma;
6654 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6655 Clist : constant Node_Id := Component_List (Variant);
6659 Comp := First_Non_Pragma (Component_Items (Clist));
6660 while Present (Comp) loop
6661 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6662 Next_Non_Pragma (Comp);
6666 ---------------------------
6667 -- Ensure_Aggregate_Form --
6668 ---------------------------
6670 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6671 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6672 Expr : constant Node_Id := Expression (Arg);
6673 Loc : constant Source_Ptr := Sloc (Expr);
6674 Comps : List_Id := No_List;
6675 Exprs : List_Id := No_List;
6676 Nam : Name_Id := No_Name;
6677 Nam_Loc : Source_Ptr;
6680 -- The pragma argument is in positional form:
6682 -- pragma Depends (Nam => ...)
6686 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6687 -- argument association.
6689 if Nkind (Arg) = N_Pragma_Argument_Association then
6691 Nam_Loc := Sloc (Arg);
6693 -- Remove the pragma argument name as this will be captured in the
6696 Set_Chars (Arg, No_Name);
6699 -- The argument is already in aggregate form, but the presence of a
6700 -- name causes this to be interpreted as named association which in
6701 -- turn must be converted into an aggregate.
6703 -- pragma Global (In_Out => (A, B, C))
6707 -- pragma Global ((In_Out => (A, B, C)))
6709 -- aggregate aggregate
6711 if Nkind (Expr) = N_Aggregate then
6712 if Nam = No_Name then
6716 -- Do not transform a null argument into an aggregate as N_Null has
6717 -- special meaning in formal verification pragmas.
6719 elsif Nkind (Expr) = N_Null then
6723 -- Everything comes from source if the original comes from source
6725 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6727 -- Positional argument is transformed into an aggregate with an
6728 -- Expressions list.
6730 if Nam = No_Name then
6731 Exprs := New_List (Relocate_Node (Expr));
6733 -- An associative argument is transformed into an aggregate with
6734 -- Component_Associations.
6738 Make_Component_Association (Loc,
6739 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6740 Expression => Relocate_Node (Expr)));
6743 Set_Expression (Arg,
6744 Make_Aggregate (Loc,
6745 Component_Associations => Comps,
6746 Expressions => Exprs));
6748 -- Restore Comes_From_Source default
6750 Set_Comes_From_Source_Default (CFSD);
6751 end Ensure_Aggregate_Form;
6757 procedure Error_Pragma (Msg : String) is
6759 Error_Msg_Name_1 := Pname;
6760 Error_Msg_N (Fix_Error (Msg), N);
6764 ----------------------
6765 -- Error_Pragma_Arg --
6766 ----------------------
6768 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6770 Error_Msg_Name_1 := Pname;
6771 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6773 end Error_Pragma_Arg;
6775 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6777 Error_Msg_Name_1 := Pname;
6778 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6779 Error_Pragma_Arg (Msg2, Arg);
6780 end Error_Pragma_Arg;
6782 ----------------------------
6783 -- Error_Pragma_Arg_Ident --
6784 ----------------------------
6786 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6788 Error_Msg_Name_1 := Pname;
6789 Error_Msg_N (Fix_Error (Msg), Arg);
6791 end Error_Pragma_Arg_Ident;
6793 ----------------------
6794 -- Error_Pragma_Ref --
6795 ----------------------
6797 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6799 Error_Msg_Name_1 := Pname;
6800 Error_Msg_Sloc := Sloc (Ref);
6801 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6803 end Error_Pragma_Ref;
6805 ------------------------
6806 -- Find_Lib_Unit_Name --
6807 ------------------------
6809 function Find_Lib_Unit_Name return Entity_Id is
6811 -- Return inner compilation unit entity, for case of nested
6812 -- categorization pragmas. This happens in generic unit.
6814 if Nkind (Parent (N)) = N_Package_Specification
6815 and then Defining_Entity (Parent (N)) /= Current_Scope
6817 return Defining_Entity (Parent (N));
6819 return Current_Scope;
6821 end Find_Lib_Unit_Name;
6823 ----------------------------
6824 -- Find_Program_Unit_Name --
6825 ----------------------------
6827 procedure Find_Program_Unit_Name (Id : Node_Id) is
6828 Unit_Name : Entity_Id;
6829 Unit_Kind : Node_Kind;
6830 P : constant Node_Id := Parent (N);
6833 if Nkind (P) = N_Compilation_Unit then
6834 Unit_Kind := Nkind (Unit (P));
6836 if Unit_Kind in N_Subprogram_Declaration
6837 | N_Package_Declaration
6838 | N_Generic_Declaration
6840 Unit_Name := Defining_Entity (Unit (P));
6842 if Chars (Id) = Chars (Unit_Name) then
6843 Set_Entity (Id, Unit_Name);
6844 Set_Etype (Id, Etype (Unit_Name));
6846 Set_Etype (Id, Any_Type);
6848 ("cannot find program unit referenced by pragma%");
6852 Set_Etype (Id, Any_Type);
6853 Error_Pragma ("pragma% inapplicable to this unit");
6859 end Find_Program_Unit_Name;
6861 -----------------------------------------
6862 -- Find_Unique_Parameterless_Procedure --
6863 -----------------------------------------
6865 function Find_Unique_Parameterless_Procedure
6867 Arg : Node_Id) return Entity_Id
6869 Proc : Entity_Id := Empty;
6872 -- The body of this procedure needs some comments ???
6874 if not Is_Entity_Name (Name) then
6876 ("argument of pragma% must be entity name", Arg);
6878 elsif not Is_Overloaded (Name) then
6879 Proc := Entity (Name);
6881 if Ekind (Proc) /= E_Procedure
6882 or else Present (First_Formal (Proc))
6885 ("argument of pragma% must be parameterless procedure", Arg);
6890 Found : Boolean := False;
6892 Index : Interp_Index;
6895 Get_First_Interp (Name, Index, It);
6896 while Present (It.Nam) loop
6899 if Ekind (Proc) = E_Procedure
6900 and then No (First_Formal (Proc))
6904 Set_Entity (Name, Proc);
6905 Set_Is_Overloaded (Name, False);
6908 ("ambiguous handler name for pragma% ", Arg);
6912 Get_Next_Interp (Index, It);
6917 ("argument of pragma% must be parameterless procedure",
6920 Proc := Entity (Name);
6926 end Find_Unique_Parameterless_Procedure;
6932 function Fix_Error (Msg : String) return String is
6933 Res : String (Msg'Range) := Msg;
6934 Res_Last : Natural := Msg'Last;
6938 -- If we have a rewriting of another pragma, go to that pragma
6940 if Is_Rewrite_Substitution (N)
6941 and then Nkind (Original_Node (N)) = N_Pragma
6943 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6946 -- Case where pragma comes from an aspect specification
6948 if From_Aspect_Specification (N) then
6950 -- Change appearence of "pragma" in message to "aspect"
6953 while J <= Res_Last - 5 loop
6954 if Res (J .. J + 5) = "pragma" then
6955 Res (J .. J + 5) := "aspect";
6963 -- Change "argument of" at start of message to "entity for"
6966 and then Res (Res'First .. Res'First + 10) = "argument of"
6968 Res (Res'First .. Res'First + 9) := "entity for";
6969 Res (Res'First + 10 .. Res_Last - 1) :=
6970 Res (Res'First + 11 .. Res_Last);
6971 Res_Last := Res_Last - 1;
6974 -- Change "argument" at start of message to "entity"
6977 and then Res (Res'First .. Res'First + 7) = "argument"
6979 Res (Res'First .. Res'First + 5) := "entity";
6980 Res (Res'First + 6 .. Res_Last - 2) :=
6981 Res (Res'First + 8 .. Res_Last);
6982 Res_Last := Res_Last - 2;
6985 -- Get name from corresponding aspect
6987 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6990 -- Return possibly modified message
6992 return Res (Res'First .. Res_Last);
6995 -------------------------
6996 -- Gather_Associations --
6997 -------------------------
6999 procedure Gather_Associations
7001 Args : out Args_List)
7006 -- Initialize all parameters to Empty
7008 for J in Args'Range loop
7012 -- That's all we have to do if there are no argument associations
7014 if No (Pragma_Argument_Associations (N)) then
7018 -- Otherwise first deal with any positional parameters present
7020 Arg := First (Pragma_Argument_Associations (N));
7021 for Index in Args'Range loop
7022 exit when No (Arg) or else Chars (Arg) /= No_Name;
7023 Args (Index) := Get_Pragma_Arg (Arg);
7027 -- Positional parameters all processed, if any left, then we
7028 -- have too many positional parameters.
7030 if Present (Arg) and then Chars (Arg) = No_Name then
7032 ("too many positional associations for pragma%", Arg);
7035 -- Process named parameters if any are present
7037 while Present (Arg) loop
7038 if Chars (Arg) = No_Name then
7040 ("positional association cannot follow named association",
7044 for Index in Names'Range loop
7045 if Names (Index) = Chars (Arg) then
7046 if Present (Args (Index)) then
7048 ("duplicate argument association for pragma%", Arg);
7050 Args (Index) := Get_Pragma_Arg (Arg);
7055 if Index = Names'Last then
7056 Error_Msg_Name_1 := Pname;
7057 Error_Msg_N ("pragma% does not allow & argument", Arg);
7059 -- Check for possible misspelling
7061 for Index1 in Names'Range loop
7062 if Is_Bad_Spelling_Of
7063 (Chars (Arg), Names (Index1))
7065 Error_Msg_Name_1 := Names (Index1);
7066 Error_Msg_N -- CODEFIX
7067 ("\possible misspelling of%", Arg);
7079 end Gather_Associations;
7085 procedure GNAT_Pragma is
7087 -- We need to check the No_Implementation_Pragmas restriction for
7088 -- the case of a pragma from source. Note that the case of aspects
7089 -- generating corresponding pragmas marks these pragmas as not being
7090 -- from source, so this test also catches that case.
7092 if Comes_From_Source (N) then
7093 Check_Restriction (No_Implementation_Pragmas, N);
7097 --------------------------
7098 -- Is_Before_First_Decl --
7099 --------------------------
7101 function Is_Before_First_Decl
7102 (Pragma_Node : Node_Id;
7103 Decls : List_Id) return Boolean
7105 Item : Node_Id := First (Decls);
7108 -- Only other pragmas can come before this pragma, but they might
7109 -- have been rewritten so check the original node.
7112 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7115 elsif Item = Pragma_Node then
7121 end Is_Before_First_Decl;
7123 -----------------------------
7124 -- Is_Configuration_Pragma --
7125 -----------------------------
7127 -- A configuration pragma must appear in the context clause of a
7128 -- compilation unit, and only other pragmas may precede it. Note that
7129 -- the test below also permits use in a configuration pragma file.
7131 function Is_Configuration_Pragma return Boolean is
7132 Lis : constant List_Id := List_Containing (N);
7133 Par : constant Node_Id := Parent (N);
7137 -- If no parent, then we are in the configuration pragma file,
7138 -- so the placement is definitely appropriate.
7143 -- Otherwise we must be in the context clause of a compilation unit
7144 -- and the only thing allowed before us in the context list is more
7145 -- configuration pragmas.
7147 elsif Nkind (Par) = N_Compilation_Unit
7148 and then Context_Items (Par) = Lis
7155 elsif Nkind (Prg) /= N_Pragma then
7165 end Is_Configuration_Pragma;
7167 --------------------------
7168 -- Is_In_Context_Clause --
7169 --------------------------
7171 function Is_In_Context_Clause return Boolean is
7173 Parent_Node : Node_Id;
7176 if not Is_List_Member (N) then
7180 Plist := List_Containing (N);
7181 Parent_Node := Parent (Plist);
7183 if Parent_Node = Empty
7184 or else Nkind (Parent_Node) /= N_Compilation_Unit
7185 or else Context_Items (Parent_Node) /= Plist
7192 end Is_In_Context_Clause;
7194 ---------------------------------
7195 -- Is_Static_String_Expression --
7196 ---------------------------------
7198 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7199 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7200 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7203 Analyze_And_Resolve (Argx);
7205 -- Special case Ada 83, where the expression will never be static,
7206 -- but we will return true if we had a string literal to start with.
7208 if Ada_Version = Ada_83 then
7211 -- Normal case, true only if we end up with a string literal that
7212 -- is marked as being the result of evaluating a static expression.
7215 return Is_OK_Static_Expression (Argx)
7216 and then Nkind (Argx) = N_String_Literal;
7219 end Is_Static_String_Expression;
7221 ----------------------
7222 -- Pragma_Misplaced --
7223 ----------------------
7225 procedure Pragma_Misplaced is
7227 Error_Pragma ("incorrect placement of pragma%");
7228 end Pragma_Misplaced;
7230 ------------------------------------------------
7231 -- Process_Atomic_Independent_Shared_Volatile --
7232 ------------------------------------------------
7234 procedure Process_Atomic_Independent_Shared_Volatile is
7235 procedure Check_Full_Access_Only (Ent : Entity_Id);
7236 -- Apply legality checks to type or object Ent subject to the
7237 -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)).
7239 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7240 -- Appropriately set flags on the given entity, either an array or
7241 -- record component, or an object declaration) according to the
7244 procedure Mark_Type (Ent : Entity_Id);
7245 -- Appropriately set flags on the given entity, a type
7247 procedure Set_Atomic_VFA (Ent : Entity_Id);
7248 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7249 -- no explicit alignment was given, set alignment to unknown, since
7250 -- back end knows what the alignment requirements are for atomic and
7251 -- full access arrays. Note: this is necessary for derived types.
7253 -------------------------
7254 -- Check_Full_Access_Only --
7255 -------------------------
7257 procedure Check_Full_Access_Only (Ent : Entity_Id) is
7260 Full_Access_Subcomponent : exception;
7261 -- Exception raised if a full access subcomponent is found
7263 Generic_Type_Subcomponent : exception;
7264 -- Exception raised if a subcomponent with generic type is found
7266 procedure Check_Subcomponents (Typ : Entity_Id);
7267 -- Apply checks to subcomponents recursively
7269 -------------------------
7270 -- Check_Subcomponents --
7271 -------------------------
7273 procedure Check_Subcomponents (Typ : Entity_Id) is
7277 if Is_Array_Type (Typ) then
7278 Comp := Component_Type (Typ);
7280 if Has_Atomic_Components (Typ)
7281 or else Is_Full_Access (Comp)
7283 raise Full_Access_Subcomponent;
7285 elsif Is_Generic_Type (Comp) then
7286 raise Generic_Type_Subcomponent;
7289 -- Recurse on the component type
7291 Check_Subcomponents (Comp);
7293 elsif Is_Record_Type (Typ) then
7294 Comp := First_Component_Or_Discriminant (Typ);
7295 while Present (Comp) loop
7297 if Is_Full_Access (Comp)
7298 or else Is_Full_Access (Etype (Comp))
7300 raise Full_Access_Subcomponent;
7302 elsif Is_Generic_Type (Etype (Comp)) then
7303 raise Generic_Type_Subcomponent;
7306 -- Recurse on the component type
7308 Check_Subcomponents (Etype (Comp));
7310 Next_Component_Or_Discriminant (Comp);
7313 end Check_Subcomponents;
7315 -- Start of processing for Check_Full_Access_Only
7318 -- Fetch the type in case we are dealing with an object or
7321 if Is_Type (Ent) then
7324 pragma Assert (Is_Object (Ent)
7326 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7331 if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then
7333 ("cannot have Full_Access_Only without Volatile/Atomic "
7338 -- Check all the subcomponents of the type recursively, if any
7340 Check_Subcomponents (Typ);
7343 when Full_Access_Subcomponent =>
7345 ("cannot have Full_Access_Only with full access subcomponent "
7348 when Generic_Type_Subcomponent =>
7350 ("cannot have Full_Access_Only with subcomponent of generic "
7351 & "type (RM C.6(8.2))");
7353 end Check_Full_Access_Only;
7355 ------------------------------
7356 -- Mark_Component_Or_Object --
7357 ------------------------------
7359 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7361 if Prag_Id = Pragma_Atomic
7362 or else Prag_Id = Pragma_Shared
7363 or else Prag_Id = Pragma_Volatile_Full_Access
7365 if Prag_Id = Pragma_Volatile_Full_Access then
7366 Set_Is_Volatile_Full_Access (Ent);
7368 Set_Is_Atomic (Ent);
7371 -- If the object declaration has an explicit initialization, a
7372 -- temporary may have to be created to hold the expression, to
7373 -- ensure that access to the object remains atomic.
7375 if Nkind (Parent (Ent)) = N_Object_Declaration
7376 and then Present (Expression (Parent (Ent)))
7378 Set_Has_Delayed_Freeze (Ent);
7382 -- Atomic/Shared/Volatile_Full_Access imply Independent
7384 if Prag_Id /= Pragma_Volatile then
7385 Set_Is_Independent (Ent);
7387 if Prag_Id = Pragma_Independent then
7388 Record_Independence_Check (N, Ent);
7392 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7394 if Prag_Id /= Pragma_Independent then
7395 Set_Is_Volatile (Ent);
7396 Set_Treat_As_Volatile (Ent);
7398 end Mark_Component_Or_Object;
7404 procedure Mark_Type (Ent : Entity_Id) is
7406 -- Attribute belongs on the base type. If the view of the type is
7407 -- currently private, it also belongs on the underlying type.
7409 -- In Ada 2020, the pragma can apply to a formal type, for which
7410 -- there may be no underlying type.
7412 if Prag_Id = Pragma_Atomic
7413 or else Prag_Id = Pragma_Shared
7414 or else Prag_Id = Pragma_Volatile_Full_Access
7416 Set_Atomic_VFA (Ent);
7417 Set_Atomic_VFA (Base_Type (Ent));
7419 if not Is_Generic_Type (Ent) then
7420 Set_Atomic_VFA (Underlying_Type (Ent));
7424 -- Atomic/Shared/Volatile_Full_Access imply Independent
7426 if Prag_Id /= Pragma_Volatile then
7427 Set_Is_Independent (Ent);
7428 Set_Is_Independent (Base_Type (Ent));
7430 if not Is_Generic_Type (Ent) then
7431 Set_Is_Independent (Underlying_Type (Ent));
7433 if Prag_Id = Pragma_Independent then
7434 Record_Independence_Check (N, Base_Type (Ent));
7439 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7441 if Prag_Id /= Pragma_Independent then
7442 Set_Is_Volatile (Ent);
7443 Set_Is_Volatile (Base_Type (Ent));
7445 if not Is_Generic_Type (Ent) then
7446 Set_Is_Volatile (Underlying_Type (Ent));
7447 Set_Treat_As_Volatile (Underlying_Type (Ent));
7450 Set_Treat_As_Volatile (Ent);
7453 -- Apply Volatile to the composite type's individual components,
7456 if Prag_Id = Pragma_Volatile
7457 and then Is_Record_Type (Etype (Ent))
7462 Comp := First_Component (Ent);
7463 while Present (Comp) loop
7464 Mark_Component_Or_Object (Comp);
7466 Next_Component (Comp);
7472 --------------------
7473 -- Set_Atomic_VFA --
7474 --------------------
7476 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7478 if Prag_Id = Pragma_Volatile_Full_Access then
7479 Set_Is_Volatile_Full_Access (Ent);
7481 Set_Is_Atomic (Ent);
7484 if not Has_Alignment_Clause (Ent) then
7485 Set_Alignment (Ent, Uint_0);
7495 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7498 Check_Ada_83_Warning;
7499 Check_No_Identifiers;
7500 Check_Arg_Count (1);
7501 Check_Arg_Is_Local_Name (Arg1);
7502 E_Arg := Get_Pragma_Arg (Arg1);
7504 if Etype (E_Arg) = Any_Type then
7508 E := Entity (E_Arg);
7509 Decl := Declaration_Node (E);
7511 -- A pragma that applies to a Ghost entity becomes Ghost for the
7512 -- purposes of legality checks and removal of ignored Ghost code.
7514 Mark_Ghost_Pragma (N, E);
7516 -- Check duplicate before we chain ourselves
7518 Check_Duplicate_Pragma (E);
7520 -- Check the constraints of Full_Access_Only in Ada 2020. Note that
7521 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
7522 -- aspect subsumes the Volatile aspect and 2) nesting is supported
7523 -- for this aspect and the outermost enclosing VFA object prevails.
7525 -- Note also that we used to forbid specifying both Atomic and VFA on
7526 -- the same type or object, but the restriction has been lifted in
7527 -- light of the semantics of Full_Access_Only and Atomic in Ada 2020.
7529 if Prag_Id = Pragma_Volatile_Full_Access
7530 and then From_Aspect_Specification (N)
7532 Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only
7534 Check_Full_Access_Only (E);
7537 -- The following check is only relevant when SPARK_Mode is on as
7538 -- this is not a standard Ada legality rule. Pragma Volatile can
7539 -- only apply to a full type declaration or an object declaration
7540 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7541 -- untagged derived types that are rewritten as subtypes of their
7542 -- respective root types.
7545 and then Prag_Id = Pragma_Volatile
7546 and then Nkind (Original_Node (Decl)) not in
7547 N_Full_Type_Declaration |
7548 N_Formal_Type_Declaration |
7549 N_Object_Declaration |
7550 N_Single_Protected_Declaration |
7551 N_Single_Task_Declaration
7554 ("argument of pragma % must denote a full type or object "
7555 & "declaration", Arg1);
7558 -- Deal with the case where the pragma/attribute is applied to a type
7561 if Rep_Item_Too_Early (E, N)
7562 or else Rep_Item_Too_Late (E, N)
7566 Check_First_Subtype (Arg1);
7571 -- Deal with the case where the pragma/attribute applies to a
7572 -- component or object declaration.
7574 elsif Nkind (Decl) = N_Object_Declaration
7575 or else (Nkind (Decl) = N_Component_Declaration
7576 and then Original_Record_Component (E) = E)
7578 if Rep_Item_Too_Late (E, N) then
7582 Mark_Component_Or_Object (E);
7584 -- In other cases give an error
7587 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7589 end Process_Atomic_Independent_Shared_Volatile;
7591 -------------------------------------------
7592 -- Process_Compile_Time_Warning_Or_Error --
7593 -------------------------------------------
7595 procedure Process_Compile_Time_Warning_Or_Error is
7596 P : Node_Id := Parent (N);
7597 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7600 Check_Arg_Count (2);
7601 Check_No_Identifiers;
7602 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7603 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7605 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7606 -- a Check pragma in GNATprove mode, handled as an assumption in
7607 -- GNATprove. This is correct as the compiler will issue an error
7608 -- if the condition cannot be statically evaluated to False.
7609 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7610 -- same information as the compiler (in particular regarding size of
7611 -- objects decided in gigi) so it makes no sense to issue a warning
7614 if GNATprove_Mode then
7615 if Prag_Id = Pragma_Compile_Time_Error then
7619 -- Implement Compile_Time_Error by generating
7620 -- a corresponding Check pragma:
7622 -- pragma Check (name, condition);
7624 -- where name is the identifier matching the pragma name. So
7625 -- rewrite pragma in this manner and analyze the result.
7627 New_Args := New_List
7628 (Make_Pragma_Argument_Association
7630 Expression => Make_Identifier (Loc, Pname)),
7631 Make_Pragma_Argument_Association
7633 Expression => Arg1x));
7635 -- Rewrite as Check pragma
7639 Chars => Name_Check,
7640 Pragma_Argument_Associations => New_Args));
7646 Rewrite (N, Make_Null_Statement (Loc));
7652 -- If the condition is known at compile time (now), validate it now.
7653 -- Otherwise, register the expression for validation after the back
7654 -- end has been called, because it might be known at compile time
7655 -- then. For example, if the expression is "Record_Type'Size /= 32"
7656 -- it might be known after the back end has determined the size of
7657 -- Record_Type. We do not defer validation if we're inside a generic
7658 -- unit, because we will have more information in the instances.
7660 if Compile_Time_Known_Value (Arg1x) then
7661 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7663 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7665 if Nkind (P) in N_Package_Body | N_Subprogram_Body then
7666 P := Corresponding_Spec (P);
7673 Defer_Compile_Time_Warning_Error_To_BE (N);
7676 end Process_Compile_Time_Warning_Or_Error;
7678 ------------------------
7679 -- Process_Convention --
7680 ------------------------
7682 procedure Process_Convention
7683 (C : out Convention_Id;
7684 Ent : out Entity_Id)
7688 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7689 -- Called if we have more than one Export/Import/Convention pragma.
7690 -- This is generally illegal, but we have a special case of allowing
7691 -- Import and Interface to coexist if they specify the convention in
7692 -- a consistent manner. We are allowed to do this, since Interface is
7693 -- an implementation defined pragma, and we choose to do it since we
7694 -- know Rational allows this combination. S is the entity id of the
7695 -- subprogram in question. This procedure also sets the special flag
7696 -- Import_Interface_Present in both pragmas in the case where we do
7697 -- have matching Import and Interface pragmas.
7699 procedure Set_Convention_From_Pragma (E : Entity_Id);
7700 -- Set convention in entity E, and also flag that the entity has a
7701 -- convention pragma. If entity is for a private or incomplete type,
7702 -- also set convention and flag on underlying type. This procedure
7703 -- also deals with the special case of C_Pass_By_Copy convention,
7704 -- and error checks for inappropriate convention specification.
7706 -------------------------------
7707 -- Diagnose_Multiple_Pragmas --
7708 -------------------------------
7710 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7711 Pdec : constant Node_Id := Declaration_Node (S);
7715 function Same_Convention (Decl : Node_Id) return Boolean;
7716 -- Decl is a pragma node. This function returns True if this
7717 -- pragma has a first argument that is an identifier with a
7718 -- Chars field corresponding to the Convention_Id C.
7720 function Same_Name (Decl : Node_Id) return Boolean;
7721 -- Decl is a pragma node. This function returns True if this
7722 -- pragma has a second argument that is an identifier with a
7723 -- Chars field that matches the Chars of the current subprogram.
7725 ---------------------
7726 -- Same_Convention --
7727 ---------------------
7729 function Same_Convention (Decl : Node_Id) return Boolean is
7730 Arg1 : constant Node_Id :=
7731 First (Pragma_Argument_Associations (Decl));
7734 if Present (Arg1) then
7736 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7738 if Nkind (Arg) = N_Identifier
7739 and then Is_Convention_Name (Chars (Arg))
7740 and then Get_Convention_Id (Chars (Arg)) = C
7748 end Same_Convention;
7754 function Same_Name (Decl : Node_Id) return Boolean is
7755 Arg1 : constant Node_Id :=
7756 First (Pragma_Argument_Associations (Decl));
7764 Arg2 := Next (Arg1);
7771 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7773 if Nkind (Arg) = N_Identifier
7774 and then Chars (Arg) = Chars (S)
7783 -- Start of processing for Diagnose_Multiple_Pragmas
7788 -- Definitely give message if we have Convention/Export here
7790 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7793 -- If we have an Import or Export, scan back from pragma to
7794 -- find any previous pragma applying to the same procedure.
7795 -- The scan will be terminated by the start of the list, or
7796 -- hitting the subprogram declaration. This won't allow one
7797 -- pragma to appear in the public part and one in the private
7798 -- part, but that seems very unlikely in practice.
7802 while Present (Decl) and then Decl /= Pdec loop
7804 -- Look for pragma with same name as us
7806 if Nkind (Decl) = N_Pragma
7807 and then Same_Name (Decl)
7809 -- Give error if same as our pragma or Export/Convention
7811 if Pragma_Name_Unmapped (Decl)
7814 | Pragma_Name_Unmapped (N)
7818 -- Case of Import/Interface or the other way round
7820 elsif Pragma_Name_Unmapped (Decl)
7821 in Name_Interface | Name_Import
7823 -- Here we know that we have Import and Interface. It
7824 -- doesn't matter which way round they are. See if
7825 -- they specify the same convention. If so, all OK,
7826 -- and set special flags to stop other messages
7828 if Same_Convention (Decl) then
7829 Set_Import_Interface_Present (N);
7830 Set_Import_Interface_Present (Decl);
7833 -- If different conventions, special message
7836 Error_Msg_Sloc := Sloc (Decl);
7838 ("convention differs from that given#", Arg1);
7848 -- Give message if needed if we fall through those tests
7849 -- except on Relaxed_RM_Semantics where we let go: either this
7850 -- is a case accepted/ignored by other Ada compilers (e.g.
7851 -- a mix of Convention and Import), or another error will be
7852 -- generated later (e.g. using both Import and Export).
7854 if Err and not Relaxed_RM_Semantics then
7856 ("at most one Convention/Export/Import pragma is allowed",
7859 end Diagnose_Multiple_Pragmas;
7861 --------------------------------
7862 -- Set_Convention_From_Pragma --
7863 --------------------------------
7865 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7867 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7868 -- for an overridden dispatching operation. Technically this is
7869 -- an amendment and should only be done in Ada 2005 mode. However,
7870 -- this is clearly a mistake, since the problem that is addressed
7871 -- by this AI is that there is a clear gap in the RM.
7873 if Is_Dispatching_Operation (E)
7874 and then Present (Overridden_Operation (E))
7875 and then C /= Convention (Overridden_Operation (E))
7878 ("cannot change convention for overridden dispatching "
7879 & "operation", Arg1);
7881 -- Special check for convention Stdcall: a dispatching call is not
7882 -- allowed. A dispatching subprogram cannot be used to interface
7883 -- to the Win32 API, so this check actually does not impose any
7884 -- effective restriction.
7886 elsif Is_Dispatching_Operation (E)
7887 and then C = Convention_Stdcall
7889 -- Note: make this unconditional so that if there is more
7890 -- than one call to which the pragma applies, we get a
7891 -- message for each call. Also don't use Error_Pragma,
7892 -- so that we get multiple messages.
7894 Error_Msg_Sloc := Sloc (E);
7896 ("dispatching subprogram# cannot use Stdcall convention!",
7897 Get_Pragma_Arg (Arg1));
7900 -- Set the convention
7902 Set_Convention (E, C);
7903 Set_Has_Convention_Pragma (E);
7905 -- For the case of a record base type, also set the convention of
7906 -- any anonymous access types declared in the record which do not
7907 -- currently have a specified convention.
7908 -- Similarly for an array base type and anonymous access types
7911 if Is_Base_Type (E) then
7912 if Is_Record_Type (E) then
7917 Comp := First_Component (E);
7918 while Present (Comp) loop
7919 if Present (Etype (Comp))
7921 Ekind (Etype (Comp)) in
7922 E_Anonymous_Access_Type |
7923 E_Anonymous_Access_Subprogram_Type
7924 and then not Has_Convention_Pragma (Comp)
7926 Set_Convention (Comp, C);
7929 Next_Component (Comp);
7933 elsif Is_Array_Type (E)
7934 and then Ekind (Component_Type (E)) in
7935 E_Anonymous_Access_Type |
7936 E_Anonymous_Access_Subprogram_Type
7938 Set_Convention (Designated_Type (Component_Type (E)), C);
7942 -- Deal with incomplete/private type case, where underlying type
7943 -- is available, so set convention of that underlying type.
7945 if Is_Incomplete_Or_Private_Type (E)
7946 and then Present (Underlying_Type (E))
7948 Set_Convention (Underlying_Type (E), C);
7949 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7952 -- A class-wide type should inherit the convention of the specific
7953 -- root type (although this isn't specified clearly by the RM).
7955 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7956 Set_Convention (Class_Wide_Type (E), C);
7959 -- If the entity is a record type, then check for special case of
7960 -- C_Pass_By_Copy, which is treated the same as C except that the
7961 -- special record flag is set. This convention is only permitted
7962 -- on record types (see AI95-00131).
7964 if Cname = Name_C_Pass_By_Copy then
7965 if Is_Record_Type (E) then
7966 Set_C_Pass_By_Copy (Base_Type (E));
7967 elsif Is_Incomplete_Or_Private_Type (E)
7968 and then Is_Record_Type (Underlying_Type (E))
7970 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7973 ("C_Pass_By_Copy convention allowed only for record type",
7978 -- If the entity is a derived boolean type, check for the special
7979 -- case of convention C, C++, or Fortran, where we consider any
7980 -- nonzero value to represent true.
7982 if Is_Discrete_Type (E)
7983 and then Root_Type (Etype (E)) = Standard_Boolean
7989 C = Convention_Fortran)
7991 Set_Nonzero_Is_True (Base_Type (E));
7993 end Set_Convention_From_Pragma;
7997 Comp_Unit : Unit_Number_Type;
8003 -- Start of processing for Process_Convention
8006 Check_At_Least_N_Arguments (2);
8007 Check_Optional_Identifier (Arg1, Name_Convention);
8008 Check_Arg_Is_Identifier (Arg1);
8009 Cname := Chars (Get_Pragma_Arg (Arg1));
8011 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8012 -- tested again below to set the critical flag).
8014 if Cname = Name_C_Pass_By_Copy then
8017 -- Otherwise we must have something in the standard convention list
8019 elsif Is_Convention_Name (Cname) then
8020 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8022 -- Otherwise warn on unrecognized convention
8025 if Warn_On_Export_Import then
8027 ("??unrecognized convention name, C assumed",
8028 Get_Pragma_Arg (Arg1));
8034 Check_Optional_Identifier (Arg2, Name_Entity);
8035 Check_Arg_Is_Local_Name (Arg2);
8037 Id := Get_Pragma_Arg (Arg2);
8040 if not Is_Entity_Name (Id) then
8041 Error_Pragma_Arg ("entity name required", Arg2);
8046 -- Set entity to return
8050 -- Ada_Pass_By_Copy special checking
8052 if C = Convention_Ada_Pass_By_Copy then
8053 if not Is_First_Subtype (E) then
8055 ("convention `Ada_Pass_By_Copy` only allowed for types",
8059 if Is_By_Reference_Type (E) then
8061 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8065 -- Ada_Pass_By_Reference special checking
8067 elsif C = Convention_Ada_Pass_By_Reference then
8068 if not Is_First_Subtype (E) then
8070 ("convention `Ada_Pass_By_Reference` only allowed for types",
8074 if Is_By_Copy_Type (E) then
8076 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8081 -- Go to renamed subprogram if present, since convention applies to
8082 -- the actual renamed entity, not to the renaming entity. If the
8083 -- subprogram is inherited, go to parent subprogram.
8085 if Is_Subprogram (E)
8086 and then Present (Alias (E))
8088 if Nkind (Parent (Declaration_Node (E))) =
8089 N_Subprogram_Renaming_Declaration
8091 if Scope (E) /= Scope (Alias (E)) then
8093 ("cannot apply pragma% to non-local entity&#", E);
8098 elsif Nkind (Parent (E)) in
8099 N_Full_Type_Declaration | N_Private_Extension_Declaration
8100 and then Scope (E) = Scope (Alias (E))
8104 -- Return the parent subprogram the entity was inherited from
8110 -- Check that we are not applying this to a specless body. Relax this
8111 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8113 if Is_Subprogram (E)
8114 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8115 and then not Relaxed_RM_Semantics
8118 ("pragma% requires separate spec and must come before body");
8121 -- Check that we are not applying this to a named constant
8123 if Is_Named_Number (E) then
8124 Error_Msg_Name_1 := Pname;
8126 ("cannot apply pragma% to named constant!",
8127 Get_Pragma_Arg (Arg2));
8129 ("\supply appropriate type for&!", Arg2);
8132 if Ekind (E) = E_Enumeration_Literal then
8133 Error_Pragma ("enumeration literal not allowed for pragma%");
8136 -- Check for rep item appearing too early or too late
8138 if Etype (E) = Any_Type
8139 or else Rep_Item_Too_Early (E, N)
8143 elsif Present (Underlying_Type (E)) then
8144 E := Underlying_Type (E);
8147 if Rep_Item_Too_Late (E, N) then
8151 if Has_Convention_Pragma (E) then
8152 Diagnose_Multiple_Pragmas (E);
8154 elsif Convention (E) = Convention_Protected
8155 or else Ekind (Scope (E)) = E_Protected_Type
8158 ("a protected operation cannot be given a different convention",
8162 -- For Intrinsic, a subprogram is required
8164 if C = Convention_Intrinsic
8165 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8167 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8169 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8170 if From_Aspect_Specification (N) then
8172 ("entity for aspect% must be a subprogram", Arg2);
8175 ("second argument of pragma% must be a subprogram", Arg2);
8179 -- Special checks for C_Variadic_n
8181 elsif C in Convention_C_Variadic then
8183 -- Several allowed cases
8185 if Is_Subprogram_Or_Generic_Subprogram (E) then
8188 -- An access to subprogram is also allowed
8190 elsif Is_Access_Type (E)
8191 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8193 Subp := Designated_Type (E);
8195 -- Allow internal call to set convention of subprogram type
8197 elsif Ekind (E) = E_Subprogram_Type then
8202 ("argument of pragma% must be subprogram or access type",
8207 -- ISO C requires a named parameter before the ellipsis, so a
8208 -- variadic C function taking 0 fixed parameter cannot exist.
8210 if C = Convention_C_Variadic_0 then
8213 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8214 Get_Pragma_Arg (Arg2));
8216 -- Now check the number of parameters of the subprogram and give
8217 -- an error if it is lower than n.
8219 elsif Present (Subp) then
8221 Minimum : constant Nat :=
8222 Convention_Id'Pos (C) -
8223 Convention_Id'Pos (Convention_C_Variadic_0);
8230 Formal := First_Formal (Subp);
8231 while Present (Formal) loop
8233 Next_Formal (Formal);
8236 if Count < Minimum then
8237 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8239 ("argument of pragma% must have at least"
8240 & "^ parameters", Arg2);
8245 -- Special checks for Stdcall
8247 elsif C = Convention_Stdcall then
8249 -- Several allowed cases
8251 if Is_Subprogram_Or_Generic_Subprogram (E)
8255 or else Ekind (E) = E_Variable
8257 -- A component as well. The entity does not have its Ekind
8258 -- set until the enclosing record declaration is fully
8261 or else Nkind (Parent (E)) = N_Component_Declaration
8263 -- An access to subprogram is also allowed
8267 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8269 -- Allow internal call to set convention of subprogram type
8271 or else Ekind (E) = E_Subprogram_Type
8277 ("argument of pragma% must be subprogram or access type",
8282 Set_Convention_From_Pragma (E);
8284 -- Deal with non-subprogram cases
8286 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8289 -- The pragma must apply to a first subtype, but it can also
8290 -- apply to a generic type in a generic formal part, in which
8291 -- case it will also appear in the corresponding instance.
8293 if Is_Generic_Type (E) or else In_Instance then
8296 Check_First_Subtype (Arg2);
8299 Set_Convention_From_Pragma (Base_Type (E));
8301 -- For access subprograms, we must set the convention on the
8302 -- internally generated directly designated type as well.
8304 if Ekind (E) = E_Access_Subprogram_Type then
8305 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8309 -- For the subprogram case, set proper convention for all homonyms
8310 -- in same scope and the same declarative part, i.e. the same
8311 -- compilation unit.
8314 -- Treat a pragma Import as an implicit body, and pragma import
8315 -- as implicit reference (for navigation in GNAT Studio).
8317 if Prag_Id = Pragma_Import then
8318 Generate_Reference (E, Id, 'b');
8320 -- For exported entities we restrict the generation of references
8321 -- to entities exported to foreign languages since entities
8322 -- exported to Ada do not provide further information to
8323 -- GNAT Studio and add undesired references to the output of the
8326 elsif Prag_Id = Pragma_Export
8327 and then Convention (E) /= Convention_Ada
8329 Generate_Reference (E, Id, 'i');
8332 -- If the pragma comes from an aspect, it only applies to the
8333 -- given entity, not its homonyms.
8335 if From_Aspect_Specification (N) then
8336 if C = Convention_Intrinsic
8337 and then Nkind (Ent) = N_Defining_Operator_Symbol
8339 if Is_Fixed_Point_Type (Etype (Ent))
8340 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8341 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8344 ("no intrinsic operator available for this fixed-point "
8347 ("\use expression functions with the desired "
8348 & "conversions made explicit", N);
8355 -- Otherwise Loop through the homonyms of the pragma argument's
8356 -- entity, an apply convention to those in the current scope.
8358 Comp_Unit := Get_Source_Unit (E);
8363 exit when No (E1) or else Scope (E1) /= Current_Scope;
8365 -- Ignore entry for which convention is already set
8367 if Has_Convention_Pragma (E1) then
8371 if Is_Subprogram (E1)
8372 and then Nkind (Parent (Declaration_Node (E1))) =
8374 and then not Relaxed_RM_Semantics
8376 Set_Has_Completion (E); -- to prevent cascaded error
8378 ("pragma% requires separate spec and must come before "
8382 -- Do not set the pragma on inherited operations or on formal
8385 if Comes_From_Source (E1)
8386 and then Comp_Unit = Get_Source_Unit (E1)
8387 and then not Is_Formal_Subprogram (E1)
8388 and then Nkind (Original_Node (Parent (E1))) /=
8389 N_Full_Type_Declaration
8391 if Present (Alias (E1))
8392 and then Scope (E1) /= Scope (Alias (E1))
8395 ("cannot apply pragma% to non-local entity& declared#",
8399 Set_Convention_From_Pragma (E1);
8401 if Prag_Id = Pragma_Import then
8402 Generate_Reference (E1, Id, 'b');
8410 end Process_Convention;
8412 ----------------------------------------
8413 -- Process_Disable_Enable_Atomic_Sync --
8414 ----------------------------------------
8416 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8418 Check_No_Identifiers;
8419 Check_At_Most_N_Arguments (1);
8421 -- Modeled internally as
8422 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8427 Pragma_Argument_Associations => New_List (
8428 Make_Pragma_Argument_Association (Loc,
8430 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8432 if Present (Arg1) then
8433 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8437 end Process_Disable_Enable_Atomic_Sync;
8439 -------------------------------------------------
8440 -- Process_Extended_Import_Export_Internal_Arg --
8441 -------------------------------------------------
8443 procedure Process_Extended_Import_Export_Internal_Arg
8444 (Arg_Internal : Node_Id := Empty)
8447 if No (Arg_Internal) then
8448 Error_Pragma ("Internal parameter required for pragma%");
8451 if Nkind (Arg_Internal) = N_Identifier then
8454 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8455 and then (Prag_Id = Pragma_Import_Function
8457 Prag_Id = Pragma_Export_Function)
8463 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8466 Check_Arg_Is_Local_Name (Arg_Internal);
8467 end Process_Extended_Import_Export_Internal_Arg;
8469 --------------------------------------------------
8470 -- Process_Extended_Import_Export_Object_Pragma --
8471 --------------------------------------------------
8473 procedure Process_Extended_Import_Export_Object_Pragma
8474 (Arg_Internal : Node_Id;
8475 Arg_External : Node_Id;
8481 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8482 Def_Id := Entity (Arg_Internal);
8484 if Ekind (Def_Id) not in E_Constant | E_Variable then
8486 ("pragma% must designate an object", Arg_Internal);
8489 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8491 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8494 ("previous Common/Psect_Object applies, pragma % not permitted",
8498 if Rep_Item_Too_Late (Def_Id, N) then
8502 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8504 if Present (Arg_Size) then
8505 Check_Arg_Is_External_Name (Arg_Size);
8508 -- Export_Object case
8510 if Prag_Id = Pragma_Export_Object then
8511 if not Is_Library_Level_Entity (Def_Id) then
8513 ("argument for pragma% must be library level entity",
8517 if Ekind (Current_Scope) = E_Generic_Package then
8518 Error_Pragma ("pragma& cannot appear in a generic unit");
8521 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8523 ("exported object must have compile time known size",
8527 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8528 Error_Msg_N ("??duplicate Export_Object pragma", N);
8530 Set_Exported (Def_Id, Arg_Internal);
8533 -- Import_Object case
8536 if Is_Concurrent_Type (Etype (Def_Id)) then
8538 ("cannot use pragma% for task/protected object",
8542 if Ekind (Def_Id) = E_Constant then
8544 ("cannot import a constant", Arg_Internal);
8547 if Warn_On_Export_Import
8548 and then Has_Discriminants (Etype (Def_Id))
8551 ("imported value must be initialized??", Arg_Internal);
8554 if Warn_On_Export_Import
8555 and then Is_Access_Type (Etype (Def_Id))
8558 ("cannot import object of an access type??", Arg_Internal);
8561 if Warn_On_Export_Import
8562 and then Is_Imported (Def_Id)
8564 Error_Msg_N ("??duplicate Import_Object pragma", N);
8566 -- Check for explicit initialization present. Note that an
8567 -- initialization generated by the code generator, e.g. for an
8568 -- access type, does not count here.
8570 elsif Present (Expression (Parent (Def_Id)))
8573 (Original_Node (Expression (Parent (Def_Id))))
8575 Error_Msg_Sloc := Sloc (Def_Id);
8577 ("imported entities cannot be initialized (RM B.1(24))",
8578 "\no initialization allowed for & declared#", Arg1);
8580 Set_Imported (Def_Id);
8581 Note_Possible_Modification (Arg_Internal, Sure => False);
8584 end Process_Extended_Import_Export_Object_Pragma;
8586 ------------------------------------------------------
8587 -- Process_Extended_Import_Export_Subprogram_Pragma --
8588 ------------------------------------------------------
8590 procedure Process_Extended_Import_Export_Subprogram_Pragma
8591 (Arg_Internal : Node_Id;
8592 Arg_External : Node_Id;
8593 Arg_Parameter_Types : Node_Id;
8594 Arg_Result_Type : Node_Id := Empty;
8595 Arg_Mechanism : Node_Id;
8596 Arg_Result_Mechanism : Node_Id := Empty)
8602 Ambiguous : Boolean;
8605 function Same_Base_Type
8607 Formal : Entity_Id) return Boolean;
8608 -- Determines if Ptype references the type of Formal. Note that only
8609 -- the base types need to match according to the spec. Ptype here is
8610 -- the argument from the pragma, which is either a type name, or an
8611 -- access attribute.
8613 --------------------
8614 -- Same_Base_Type --
8615 --------------------
8617 function Same_Base_Type
8619 Formal : Entity_Id) return Boolean
8621 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8625 -- Case where pragma argument is typ'Access
8627 if Nkind (Ptype) = N_Attribute_Reference
8628 and then Attribute_Name (Ptype) = Name_Access
8630 Pref := Prefix (Ptype);
8633 if not Is_Entity_Name (Pref)
8634 or else Entity (Pref) = Any_Type
8639 -- We have a match if the corresponding argument is of an
8640 -- anonymous access type, and its designated type matches the
8641 -- type of the prefix of the access attribute
8643 return Ekind (Ftyp) = E_Anonymous_Access_Type
8644 and then Base_Type (Entity (Pref)) =
8645 Base_Type (Etype (Designated_Type (Ftyp)));
8647 -- Case where pragma argument is a type name
8652 if not Is_Entity_Name (Ptype)
8653 or else Entity (Ptype) = Any_Type
8658 -- We have a match if the corresponding argument is of the type
8659 -- given in the pragma (comparing base types)
8661 return Base_Type (Entity (Ptype)) = Ftyp;
8665 -- Start of processing for
8666 -- Process_Extended_Import_Export_Subprogram_Pragma
8669 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8673 -- Loop through homonyms (overloadings) of the entity
8675 Hom_Id := Entity (Arg_Internal);
8676 while Present (Hom_Id) loop
8677 Def_Id := Get_Base_Subprogram (Hom_Id);
8679 -- We need a subprogram in the current scope
8681 if not Is_Subprogram (Def_Id)
8682 or else Scope (Def_Id) /= Current_Scope
8689 -- Pragma cannot apply to subprogram body
8691 if Is_Subprogram (Def_Id)
8692 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8696 ("pragma% requires separate spec and must come before "
8700 -- Test result type if given, note that the result type
8701 -- parameter can only be present for the function cases.
8703 if Present (Arg_Result_Type)
8704 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8708 elsif Etype (Def_Id) /= Standard_Void_Type
8710 Pname in Name_Export_Procedure | Name_Import_Procedure
8714 -- Test parameter types if given. Note that this parameter has
8715 -- not been analyzed (and must not be, since it is semantic
8716 -- nonsense), so we get it as the parser left it.
8718 elsif Present (Arg_Parameter_Types) then
8719 Check_Matching_Types : declare
8724 Formal := First_Formal (Def_Id);
8726 if Nkind (Arg_Parameter_Types) = N_Null then
8727 if Present (Formal) then
8731 -- A list of one type, e.g. (List) is parsed as a
8732 -- parenthesized expression.
8734 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8735 and then Paren_Count (Arg_Parameter_Types) = 1
8738 or else Present (Next_Formal (Formal))
8743 Same_Base_Type (Arg_Parameter_Types, Formal);
8746 -- A list of more than one type is parsed as a aggregate
8748 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8749 and then Paren_Count (Arg_Parameter_Types) = 0
8751 Ptype := First (Expressions (Arg_Parameter_Types));
8752 while Present (Ptype) or else Present (Formal) loop
8755 or else not Same_Base_Type (Ptype, Formal)
8760 Next_Formal (Formal);
8765 -- Anything else is of the wrong form
8769 ("wrong form for Parameter_Types parameter",
8770 Arg_Parameter_Types);
8772 end Check_Matching_Types;
8775 -- Match is now False if the entry we found did not match
8776 -- either a supplied Parameter_Types or Result_Types argument
8782 -- Ambiguous case, the flag Ambiguous shows if we already
8783 -- detected this and output the initial messages.
8786 if not Ambiguous then
8788 Error_Msg_Name_1 := Pname;
8790 ("pragma% does not uniquely identify subprogram!",
8792 Error_Msg_Sloc := Sloc (Ent);
8793 Error_Msg_N ("matching subprogram #!", N);
8797 Error_Msg_Sloc := Sloc (Def_Id);
8798 Error_Msg_N ("matching subprogram #!", N);
8803 Hom_Id := Homonym (Hom_Id);
8806 -- See if we found an entry
8809 if not Ambiguous then
8810 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8812 ("pragma% cannot be given for generic subprogram");
8815 ("pragma% does not identify local subprogram");
8822 -- Import pragmas must be for imported entities
8824 if Prag_Id = Pragma_Import_Function
8826 Prag_Id = Pragma_Import_Procedure
8828 Prag_Id = Pragma_Import_Valued_Procedure
8830 if not Is_Imported (Ent) then
8832 ("pragma Import or Interface must precede pragma%");
8835 -- Here we have the Export case which can set the entity as exported
8837 -- But does not do so if the specified external name is null, since
8838 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8839 -- compatible) to request no external name.
8841 elsif Nkind (Arg_External) = N_String_Literal
8842 and then String_Length (Strval (Arg_External)) = 0
8846 -- In all other cases, set entity as exported
8849 Set_Exported (Ent, Arg_Internal);
8852 -- Special processing for Valued_Procedure cases
8854 if Prag_Id = Pragma_Import_Valued_Procedure
8856 Prag_Id = Pragma_Export_Valued_Procedure
8858 Formal := First_Formal (Ent);
8861 Error_Pragma ("at least one parameter required for pragma%");
8863 elsif Ekind (Formal) /= E_Out_Parameter then
8864 Error_Pragma ("first parameter must have mode out for pragma%");
8867 Set_Is_Valued_Procedure (Ent);
8871 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8873 -- Process Result_Mechanism argument if present. We have already
8874 -- checked that this is only allowed for the function case.
8876 if Present (Arg_Result_Mechanism) then
8877 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8880 -- Process Mechanism parameter if present. Note that this parameter
8881 -- is not analyzed, and must not be analyzed since it is semantic
8882 -- nonsense, so we get it in exactly as the parser left it.
8884 if Present (Arg_Mechanism) then
8892 -- A single mechanism association without a formal parameter
8893 -- name is parsed as a parenthesized expression. All other
8894 -- cases are parsed as aggregates, so we rewrite the single
8895 -- parameter case as an aggregate for consistency.
8897 if Nkind (Arg_Mechanism) /= N_Aggregate
8898 and then Paren_Count (Arg_Mechanism) = 1
8900 Rewrite (Arg_Mechanism,
8901 Make_Aggregate (Sloc (Arg_Mechanism),
8902 Expressions => New_List (
8903 Relocate_Node (Arg_Mechanism))));
8906 -- Case of only mechanism name given, applies to all formals
8908 if Nkind (Arg_Mechanism) /= N_Aggregate then
8909 Formal := First_Formal (Ent);
8910 while Present (Formal) loop
8911 Set_Mechanism_Value (Formal, Arg_Mechanism);
8912 Next_Formal (Formal);
8915 -- Case of list of mechanism associations given
8918 if Null_Record_Present (Arg_Mechanism) then
8920 ("inappropriate form for Mechanism parameter",
8924 -- Deal with positional ones first
8926 Formal := First_Formal (Ent);
8928 if Present (Expressions (Arg_Mechanism)) then
8929 Mname := First (Expressions (Arg_Mechanism));
8930 while Present (Mname) loop
8933 ("too many mechanism associations", Mname);
8936 Set_Mechanism_Value (Formal, Mname);
8937 Next_Formal (Formal);
8942 -- Deal with named entries
8944 if Present (Component_Associations (Arg_Mechanism)) then
8945 Massoc := First (Component_Associations (Arg_Mechanism));
8946 while Present (Massoc) loop
8947 Choice := First (Choices (Massoc));
8949 if Nkind (Choice) /= N_Identifier
8950 or else Present (Next (Choice))
8953 ("incorrect form for mechanism association",
8957 Formal := First_Formal (Ent);
8961 ("parameter name & not present", Choice);
8964 if Chars (Choice) = Chars (Formal) then
8966 (Formal, Expression (Massoc));
8968 -- Set entity on identifier for proper tree
8971 Set_Entity (Choice, Formal);
8976 Next_Formal (Formal);
8985 end Process_Extended_Import_Export_Subprogram_Pragma;
8987 --------------------------
8988 -- Process_Generic_List --
8989 --------------------------
8991 procedure Process_Generic_List is
8996 Check_No_Identifiers;
8997 Check_At_Least_N_Arguments (1);
8999 -- Check all arguments are names of generic units or instances
9002 while Present (Arg) loop
9003 Exp := Get_Pragma_Arg (Arg);
9006 if not Is_Entity_Name (Exp)
9008 (not Is_Generic_Instance (Entity (Exp))
9010 not Is_Generic_Unit (Entity (Exp)))
9013 ("pragma% argument must be name of generic unit/instance",
9019 end Process_Generic_List;
9021 ------------------------------------
9022 -- Process_Import_Predefined_Type --
9023 ------------------------------------
9025 procedure Process_Import_Predefined_Type is
9026 Loc : constant Source_Ptr := Sloc (N);
9028 Ftyp : Node_Id := Empty;
9034 Nam := String_To_Name (Strval (Expression (Arg3)));
9036 Elmt := First_Elmt (Predefined_Float_Types);
9037 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9041 Ftyp := Node (Elmt);
9043 if Present (Ftyp) then
9045 -- Don't build a derived type declaration, because predefined C
9046 -- types have no declaration anywhere, so cannot really be named.
9047 -- Instead build a full type declaration, starting with an
9048 -- appropriate type definition is built
9050 if Is_Floating_Point_Type (Ftyp) then
9051 Def := Make_Floating_Point_Definition (Loc,
9052 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9053 Make_Real_Range_Specification (Loc,
9054 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9055 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9057 -- Should never have a predefined type we cannot handle
9060 raise Program_Error;
9063 -- Build and insert a Full_Type_Declaration, which will be
9064 -- analyzed as soon as this list entry has been analyzed.
9066 Decl := Make_Full_Type_Declaration (Loc,
9067 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9068 Type_Definition => Def);
9070 Insert_After (N, Decl);
9071 Mark_Rewrite_Insertion (Decl);
9074 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9076 end Process_Import_Predefined_Type;
9078 ---------------------------------
9079 -- Process_Import_Or_Interface --
9080 ---------------------------------
9082 procedure Process_Import_Or_Interface is
9088 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9089 -- pragma Import (Entity, "external name");
9091 if Relaxed_RM_Semantics
9092 and then Arg_Count = 2
9093 and then Prag_Id = Pragma_Import
9094 and then Nkind (Expression (Arg2)) = N_String_Literal
9097 Def_Id := Get_Pragma_Arg (Arg1);
9100 if not Is_Entity_Name (Def_Id) then
9101 Error_Pragma_Arg ("entity name required", Arg1);
9104 Def_Id := Entity (Def_Id);
9105 Kill_Size_Check_Code (Def_Id);
9106 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9109 Process_Convention (C, Def_Id);
9111 -- A pragma that applies to a Ghost entity becomes Ghost for the
9112 -- purposes of legality checks and removal of ignored Ghost code.
9114 Mark_Ghost_Pragma (N, Def_Id);
9115 Kill_Size_Check_Code (Def_Id);
9116 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9119 -- Various error checks
9121 if Ekind (Def_Id) in E_Variable | E_Constant then
9123 -- We do not permit Import to apply to a renaming declaration
9125 if Present (Renamed_Object (Def_Id)) then
9127 ("pragma% not allowed for object renaming", Arg2);
9129 -- User initialization is not allowed for imported object, but
9130 -- the object declaration may contain a default initialization,
9131 -- that will be discarded. Note that an explicit initialization
9132 -- only counts if it comes from source, otherwise it is simply
9133 -- the code generator making an implicit initialization explicit.
9135 elsif Present (Expression (Parent (Def_Id)))
9136 and then Comes_From_Source
9137 (Original_Node (Expression (Parent (Def_Id))))
9139 -- Set imported flag to prevent cascaded errors
9141 Set_Is_Imported (Def_Id);
9143 Error_Msg_Sloc := Sloc (Def_Id);
9145 ("no initialization allowed for declaration of& #",
9146 "\imported entities cannot be initialized (RM B.1(24))",
9150 -- If the pragma comes from an aspect specification the
9151 -- Is_Imported flag has already been set.
9153 if not From_Aspect_Specification (N) then
9154 Set_Imported (Def_Id);
9157 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9159 -- Note that we do not set Is_Public here. That's because we
9160 -- only want to set it if there is no address clause, and we
9161 -- don't know that yet, so we delay that processing till
9164 -- pragma Import completes deferred constants
9166 if Ekind (Def_Id) = E_Constant then
9167 Set_Has_Completion (Def_Id);
9170 -- It is not possible to import a constant of an unconstrained
9171 -- array type (e.g. string) because there is no simple way to
9172 -- write a meaningful subtype for it.
9174 if Is_Array_Type (Etype (Def_Id))
9175 and then not Is_Constrained (Etype (Def_Id))
9178 ("imported constant& must have a constrained subtype",
9183 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9185 -- If the name is overloaded, pragma applies to all of the denoted
9186 -- entities in the same declarative part, unless the pragma comes
9187 -- from an aspect specification or was generated by the compiler
9188 -- (such as for pragma Provide_Shift_Operators).
9191 while Present (Hom_Id) loop
9193 Def_Id := Get_Base_Subprogram (Hom_Id);
9195 -- Ignore inherited subprograms because the pragma will apply
9196 -- to the parent operation, which is the one called.
9198 if Is_Overloadable (Def_Id)
9199 and then Present (Alias (Def_Id))
9203 -- If it is not a subprogram, it must be in an outer scope and
9204 -- pragma does not apply.
9206 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9209 -- The pragma does not apply to primitives of interfaces
9211 elsif Is_Dispatching_Operation (Def_Id)
9212 and then Present (Find_Dispatching_Type (Def_Id))
9213 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9217 -- Verify that the homonym is in the same declarative part (not
9218 -- just the same scope). If the pragma comes from an aspect
9219 -- specification we know that it is part of the declaration.
9221 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9222 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9223 and then not From_Aspect_Specification (N)
9228 -- If the pragma comes from an aspect specification the
9229 -- Is_Imported flag has already been set.
9231 if not From_Aspect_Specification (N) then
9232 Set_Imported (Def_Id);
9235 -- Reject an Import applied to an abstract subprogram
9237 if Is_Subprogram (Def_Id)
9238 and then Is_Abstract_Subprogram (Def_Id)
9240 Error_Msg_Sloc := Sloc (Def_Id);
9242 ("cannot import abstract subprogram& declared#",
9246 -- Special processing for Convention_Intrinsic
9248 if C = Convention_Intrinsic then
9250 -- Link_Name argument not allowed for intrinsic
9254 Set_Is_Intrinsic_Subprogram (Def_Id);
9256 -- If no external name is present, then check that this
9257 -- is a valid intrinsic subprogram. If an external name
9258 -- is present, then this is handled by the back end.
9261 Check_Intrinsic_Subprogram
9262 (Def_Id, Get_Pragma_Arg (Arg2));
9266 -- Verify that the subprogram does not have a completion
9267 -- through a renaming declaration. For other completions the
9268 -- pragma appears as a too late representation.
9271 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9275 and then Nkind (Decl) = N_Subprogram_Declaration
9276 and then Present (Corresponding_Body (Decl))
9277 and then Nkind (Unit_Declaration_Node
9278 (Corresponding_Body (Decl))) =
9279 N_Subprogram_Renaming_Declaration
9281 Error_Msg_Sloc := Sloc (Def_Id);
9283 ("cannot import&, renaming already provided for "
9284 & "declaration #", N, Def_Id);
9288 -- If the pragma comes from an aspect specification, there
9289 -- must be an Import aspect specified as well. In the rare
9290 -- case where Import is set to False, the suprogram needs to
9291 -- have a local completion.
9294 Imp_Aspect : constant Node_Id :=
9295 Find_Aspect (Def_Id, Aspect_Import);
9299 if Present (Imp_Aspect)
9300 and then Present (Expression (Imp_Aspect))
9302 Expr := Expression (Imp_Aspect);
9303 Analyze_And_Resolve (Expr, Standard_Boolean);
9305 if Is_Entity_Name (Expr)
9306 and then Entity (Expr) = Standard_True
9308 Set_Has_Completion (Def_Id);
9311 -- If there is no expression, the default is True, as for
9312 -- all boolean aspects. Same for the older pragma.
9315 Set_Has_Completion (Def_Id);
9319 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9322 if Is_Compilation_Unit (Hom_Id) then
9324 -- Its possible homonyms are not affected by the pragma.
9325 -- Such homonyms might be present in the context of other
9326 -- units being compiled.
9330 elsif From_Aspect_Specification (N) then
9333 -- If the pragma was created by the compiler, then we don't
9334 -- want it to apply to other homonyms. This kind of case can
9335 -- occur when using pragma Provide_Shift_Operators, which
9336 -- generates implicit shift and rotate operators with Import
9337 -- pragmas that might apply to earlier explicit or implicit
9338 -- declarations marked with Import (for example, coming from
9339 -- an earlier pragma Provide_Shift_Operators for another type),
9340 -- and we don't generally want other homonyms being treated
9341 -- as imported or the pragma flagged as an illegal duplicate.
9343 elsif not Comes_From_Source (N) then
9347 Hom_Id := Homonym (Hom_Id);
9351 -- Import a CPP class
9353 elsif C = Convention_CPP
9354 and then (Is_Record_Type (Def_Id)
9355 or else Ekind (Def_Id) = E_Incomplete_Type)
9357 if Ekind (Def_Id) = E_Incomplete_Type then
9358 if Present (Full_View (Def_Id)) then
9359 Def_Id := Full_View (Def_Id);
9363 ("cannot import 'C'P'P type before full declaration seen",
9364 Get_Pragma_Arg (Arg2));
9366 -- Although we have reported the error we decorate it as
9367 -- CPP_Class to avoid reporting spurious errors
9369 Set_Is_CPP_Class (Def_Id);
9374 -- Types treated as CPP classes must be declared limited (note:
9375 -- this used to be a warning but there is no real benefit to it
9376 -- since we did effectively intend to treat the type as limited
9379 if not Is_Limited_Type (Def_Id) then
9381 ("imported 'C'P'P type must be limited",
9382 Get_Pragma_Arg (Arg2));
9385 if Etype (Def_Id) /= Def_Id
9386 and then not Is_CPP_Class (Root_Type (Def_Id))
9388 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9391 Set_Is_CPP_Class (Def_Id);
9393 -- Imported CPP types must not have discriminants (because C++
9394 -- classes do not have discriminants).
9396 if Has_Discriminants (Def_Id) then
9398 ("imported 'C'P'P type cannot have discriminants",
9399 First (Discriminant_Specifications
9400 (Declaration_Node (Def_Id))));
9403 -- Check that components of imported CPP types do not have default
9404 -- expressions. For private types this check is performed when the
9405 -- full view is analyzed (see Process_Full_View).
9407 if not Is_Private_Type (Def_Id) then
9408 Check_CPP_Type_Has_No_Defaults (Def_Id);
9411 -- Import a CPP exception
9413 elsif C = Convention_CPP
9414 and then Ekind (Def_Id) = E_Exception
9418 ("'External_'Name arguments is required for 'Cpp exception",
9421 -- As only a string is allowed, Check_Arg_Is_External_Name
9424 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9427 if Present (Arg4) then
9429 ("Link_Name argument not allowed for imported Cpp exception",
9433 -- Do not call Set_Interface_Name as the name of the exception
9434 -- shouldn't be modified (and in particular it shouldn't be
9435 -- the External_Name). For exceptions, the External_Name is the
9436 -- name of the RTTI structure.
9438 -- ??? Emit an error if pragma Import/Export_Exception is present
9440 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9442 Check_Arg_Count (3);
9443 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9445 Process_Import_Predefined_Type;
9448 if From_Aspect_Specification (N) then
9450 ("entity for aspect% must be object, subprogram "
9451 & "or incomplete type",
9455 ("second argument of pragma% must be object, subprogram "
9456 & "or incomplete type",
9461 -- If this pragma applies to a compilation unit, then the unit, which
9462 -- is a subprogram, does not require (or allow) a body. We also do
9463 -- not need to elaborate imported procedures.
9465 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9467 Cunit : constant Node_Id := Parent (Parent (N));
9469 Set_Body_Required (Cunit, False);
9472 end Process_Import_Or_Interface;
9474 --------------------
9475 -- Process_Inline --
9476 --------------------
9478 procedure Process_Inline (Status : Inline_Status) is
9485 Ghost_Error_Posted : Boolean := False;
9486 -- Flag set when an error concerning the illegal mix of Ghost and
9487 -- non-Ghost subprograms is emitted.
9489 Ghost_Id : Entity_Id := Empty;
9490 -- The entity of the first Ghost subprogram encountered while
9491 -- processing the arguments of the pragma.
9493 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9494 -- Verify the placement of pragma Inline_Always with respect to the
9495 -- initial declaration of subprogram Spec_Id.
9497 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9498 -- Returns True if it can be determined at this stage that inlining
9499 -- is not possible, for example if the body is available and contains
9500 -- exception handlers, we prevent inlining, since otherwise we can
9501 -- get undefined symbols at link time. This function also emits a
9502 -- warning if the pragma appears too late.
9504 -- ??? is business with link symbols still valid, or does it relate
9505 -- to front end ZCX which is being phased out ???
9507 procedure Make_Inline (Subp : Entity_Id);
9508 -- Subp is the defining unit name of the subprogram declaration. If
9509 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9510 -- the corresponding body, if there is one present.
9512 procedure Set_Inline_Flags (Subp : Entity_Id);
9513 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9514 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9516 -----------------------------------
9517 -- Check_Inline_Always_Placement --
9518 -----------------------------------
9520 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9521 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9523 function Compilation_Unit_OK return Boolean;
9524 pragma Inline (Compilation_Unit_OK);
9525 -- Determine whether pragma Inline_Always applies to a compatible
9526 -- compilation unit denoted by Spec_Id.
9528 function Declarative_List_OK return Boolean;
9529 pragma Inline (Declarative_List_OK);
9530 -- Determine whether the initial declaration of subprogram Spec_Id
9531 -- and the pragma appear in compatible declarative lists.
9533 function Subprogram_Body_OK return Boolean;
9534 pragma Inline (Subprogram_Body_OK);
9535 -- Determine whether pragma Inline_Always applies to a compatible
9536 -- subprogram body denoted by Spec_Id.
9538 -------------------------
9539 -- Compilation_Unit_OK --
9540 -------------------------
9542 function Compilation_Unit_OK return Boolean is
9543 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9546 -- The pragma appears after the initial declaration of a
9547 -- compilation unit.
9549 -- procedure Comp_Unit;
9550 -- pragma Inline_Always (Comp_Unit);
9552 -- Note that for compatibility reasons, the following case is
9555 -- procedure Stand_Alone_Body_Comp_Unit is
9557 -- end Stand_Alone_Body_Comp_Unit;
9558 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9561 Nkind (Comp_Unit) = N_Compilation_Unit
9562 and then Present (Aux_Decls_Node (Comp_Unit))
9563 and then Is_List_Member (N)
9564 and then List_Containing (N) =
9565 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9566 end Compilation_Unit_OK;
9568 -------------------------
9569 -- Declarative_List_OK --
9570 -------------------------
9572 function Declarative_List_OK return Boolean is
9573 Context : constant Node_Id := Parent (Spec_Decl);
9575 Init_Decl : Node_Id;
9576 Init_List : List_Id;
9577 Prag_List : List_Id;
9580 -- Determine the proper initial declaration. In general this is
9581 -- the declaration node of the subprogram except when the input
9582 -- denotes a generic instantiation.
9584 -- procedure Inst is new Gen;
9585 -- pragma Inline_Always (Inst);
9587 -- In this case the original subprogram is moved inside an
9588 -- anonymous package while pragma Inline_Always remains at the
9589 -- level of the anonymous package. Use the declaration of the
9590 -- package because it reflects the placement of the original
9593 -- package Anon_Pack is
9594 -- procedure Inst is ... end Inst; -- original
9597 -- procedure Inst renames Anon_Pack.Inst;
9598 -- pragma Inline_Always (Inst);
9600 if Is_Generic_Instance (Spec_Id) then
9601 Init_Decl := Parent (Parent (Spec_Decl));
9602 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9604 Init_Decl := Spec_Decl;
9607 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9608 Init_List := List_Containing (Init_Decl);
9609 Prag_List := List_Containing (N);
9611 -- The pragma and then initial declaration appear within the
9612 -- same declarative list.
9614 if Init_List = Prag_List then
9617 -- A special case of the above is when both the pragma and
9618 -- the initial declaration appear in different lists of a
9619 -- package spec, protected definition, or a task definition.
9624 -- pragma Inline_Always (Proc);
9627 elsif Nkind (Context) in N_Package_Specification
9628 | N_Protected_Definition
9630 and then Init_List = Visible_Declarations (Context)
9631 and then Prag_List = Private_Declarations (Context)
9638 end Declarative_List_OK;
9640 ------------------------
9641 -- Subprogram_Body_OK --
9642 ------------------------
9644 function Subprogram_Body_OK return Boolean is
9645 Body_Decl : Node_Id;
9648 -- The pragma appears within the declarative list of a stand-
9649 -- alone subprogram body.
9651 -- procedure Stand_Alone_Body is
9652 -- pragma Inline_Always (Stand_Alone_Body);
9655 -- end Stand_Alone_Body;
9657 -- The compiler creates a dummy spec in this case, however the
9658 -- pragma remains within the declarative list of the body.
9660 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9661 and then not Comes_From_Source (Spec_Decl)
9662 and then Present (Corresponding_Body (Spec_Decl))
9665 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9667 if Present (Declarations (Body_Decl))
9668 and then Is_List_Member (N)
9669 and then List_Containing (N) = Declarations (Body_Decl)
9676 end Subprogram_Body_OK;
9678 -- Start of processing for Check_Inline_Always_Placement
9681 -- This check is relevant only for pragma Inline_Always
9683 if Pname /= Name_Inline_Always then
9686 -- Nothing to do when the pragma is internally generated on the
9687 -- assumption that it is properly placed.
9689 elsif not Comes_From_Source (N) then
9692 -- Nothing to do for internally generated subprograms that act
9693 -- as accidental homonyms of a source subprogram being inlined.
9695 elsif not Comes_From_Source (Spec_Id) then
9698 -- Nothing to do for generic formal subprograms that act as
9699 -- homonyms of another source subprogram being inlined.
9701 elsif Is_Formal_Subprogram (Spec_Id) then
9704 elsif Compilation_Unit_OK
9705 or else Declarative_List_OK
9706 or else Subprogram_Body_OK
9711 -- At this point it is known that the pragma applies to or appears
9712 -- within a completing body, a completing stub, or a subunit.
9714 Error_Msg_Name_1 := Pname;
9715 Error_Msg_Name_2 := Chars (Spec_Id);
9716 Error_Msg_Sloc := Sloc (Spec_Id);
9719 ("pragma % must appear on initial declaration of subprogram "
9720 & "% defined #", N);
9721 end Check_Inline_Always_Placement;
9723 ---------------------------
9724 -- Inlining_Not_Possible --
9725 ---------------------------
9727 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9728 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9732 if Nkind (Decl) = N_Subprogram_Body then
9733 Stats := Handled_Statement_Sequence (Decl);
9734 return Present (Exception_Handlers (Stats))
9735 or else Present (At_End_Proc (Stats));
9737 elsif Nkind (Decl) = N_Subprogram_Declaration
9738 and then Present (Corresponding_Body (Decl))
9740 if Analyzed (Corresponding_Body (Decl)) then
9741 Error_Msg_N ("pragma appears too late, ignored??", N);
9744 -- If the subprogram is a renaming as body, the body is just a
9745 -- call to the renamed subprogram, and inlining is trivially
9749 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9750 N_Subprogram_Renaming_Declaration
9756 Handled_Statement_Sequence
9757 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9760 Present (Exception_Handlers (Stats))
9761 or else Present (At_End_Proc (Stats));
9765 -- If body is not available, assume the best, the check is
9766 -- performed again when compiling enclosing package bodies.
9770 end Inlining_Not_Possible;
9776 procedure Make_Inline (Subp : Entity_Id) is
9777 Kind : constant Entity_Kind := Ekind (Subp);
9778 Inner_Subp : Entity_Id := Subp;
9781 -- Ignore if bad type, avoid cascaded error
9783 if Etype (Subp) = Any_Type then
9787 -- If inlining is not possible, for now do not treat as an error
9789 elsif Status /= Suppressed
9790 and then Front_End_Inlining
9791 and then Inlining_Not_Possible (Subp)
9796 -- Here we have a candidate for inlining, but we must exclude
9797 -- derived operations. Otherwise we would end up trying to inline
9798 -- a phantom declaration, and the result would be to drag in a
9799 -- body which has no direct inlining associated with it. That
9800 -- would not only be inefficient but would also result in the
9801 -- backend doing cross-unit inlining in cases where it was
9802 -- definitely inappropriate to do so.
9804 -- However, a simple Comes_From_Source test is insufficient, since
9805 -- we do want to allow inlining of generic instances which also do
9806 -- not come from source. We also need to recognize specs generated
9807 -- by the front-end for bodies that carry the pragma. Finally,
9808 -- predefined operators do not come from source but are not
9809 -- inlineable either.
9811 elsif Is_Generic_Instance (Subp)
9812 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9816 elsif not Comes_From_Source (Subp)
9817 and then Scope (Subp) /= Standard_Standard
9823 -- The referenced entity must either be the enclosing entity, or
9824 -- an entity declared within the current open scope.
9826 if Present (Scope (Subp))
9827 and then Scope (Subp) /= Current_Scope
9828 and then Subp /= Current_Scope
9831 ("argument of% must be entity in current scope", Assoc);
9835 -- Processing for procedure, operator or function. If subprogram
9836 -- is aliased (as for an instance) indicate that the renamed
9837 -- entity (if declared in the same unit) is inlined.
9838 -- If this is the anonymous subprogram created for a subprogram
9839 -- instance, the inlining applies to it directly. Otherwise we
9840 -- retrieve it as the alias of the visible subprogram instance.
9842 if Is_Subprogram (Subp) then
9844 -- Ensure that pragma Inline_Always is associated with the
9845 -- initial declaration of the subprogram.
9847 Check_Inline_Always_Placement (Subp);
9849 if Is_Wrapper_Package (Scope (Subp)) then
9852 Inner_Subp := Ultimate_Alias (Inner_Subp);
9855 if In_Same_Source_Unit (Subp, Inner_Subp) then
9856 Set_Inline_Flags (Inner_Subp);
9858 Decl := Parent (Parent (Inner_Subp));
9860 if Nkind (Decl) = N_Subprogram_Declaration
9861 and then Present (Corresponding_Body (Decl))
9863 Set_Inline_Flags (Corresponding_Body (Decl));
9865 elsif Is_Generic_Instance (Subp)
9866 and then Comes_From_Source (Subp)
9868 -- Indicate that the body needs to be created for
9869 -- inlining subsequent calls. The instantiation node
9870 -- follows the declaration of the wrapper package
9871 -- created for it. The subprogram that requires the
9872 -- body is the anonymous one in the wrapper package.
9874 if Scope (Subp) /= Standard_Standard
9876 Need_Subprogram_Instance_Body
9877 (Next (Unit_Declaration_Node
9878 (Scope (Alias (Subp)))), Subp)
9883 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9884 -- appear in a formal part to apply to a formal subprogram.
9885 -- Do not apply check within an instance or a formal package
9886 -- the test will have been applied to the original generic.
9888 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9889 and then In_Same_List (Decl, N)
9890 and then not In_Instance
9893 ("Inline cannot apply to a formal subprogram", N);
9899 -- For a generic subprogram set flag as well, for use at the point
9900 -- of instantiation, to determine whether the body should be
9903 elsif Is_Generic_Subprogram (Subp) then
9904 Set_Inline_Flags (Subp);
9907 -- Literals are by definition inlined
9909 elsif Kind = E_Enumeration_Literal then
9912 -- Anything else is an error
9916 ("expect subprogram name for pragma%", Assoc);
9920 ----------------------
9921 -- Set_Inline_Flags --
9922 ----------------------
9924 procedure Set_Inline_Flags (Subp : Entity_Id) is
9926 -- First set the Has_Pragma_XXX flags and issue the appropriate
9927 -- errors and warnings for suspicious combinations.
9929 if Prag_Id = Pragma_No_Inline then
9930 if Has_Pragma_Inline_Always (Subp) then
9932 ("Inline_Always and No_Inline are mutually exclusive", N);
9933 elsif Has_Pragma_Inline (Subp) then
9935 ("Inline and No_Inline both specified for& ??",
9936 N, Entity (Subp_Id));
9939 Set_Has_Pragma_No_Inline (Subp);
9941 if Prag_Id = Pragma_Inline_Always then
9942 if Has_Pragma_No_Inline (Subp) then
9944 ("Inline_Always and No_Inline are mutually exclusive",
9948 Set_Has_Pragma_Inline_Always (Subp);
9950 if Has_Pragma_No_Inline (Subp) then
9952 ("Inline and No_Inline both specified for& ??",
9953 N, Entity (Subp_Id));
9957 Set_Has_Pragma_Inline (Subp);
9960 -- Then adjust the Is_Inlined flag. It can never be set if the
9961 -- subprogram is subject to pragma No_Inline.
9965 Set_Is_Inlined (Subp, False);
9971 if not Has_Pragma_No_Inline (Subp) then
9972 Set_Is_Inlined (Subp, True);
9976 -- A pragma that applies to a Ghost entity becomes Ghost for the
9977 -- purposes of legality checks and removal of ignored Ghost code.
9979 Mark_Ghost_Pragma (N, Subp);
9981 -- Capture the entity of the first Ghost subprogram being
9982 -- processed for error detection purposes.
9984 if Is_Ghost_Entity (Subp) then
9985 if No (Ghost_Id) then
9989 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9990 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9992 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9993 Ghost_Error_Posted := True;
9995 Error_Msg_Name_1 := Pname;
9997 ("pragma % cannot mention ghost and non-ghost subprograms",
10000 Error_Msg_Sloc := Sloc (Ghost_Id);
10001 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10003 Error_Msg_Sloc := Sloc (Subp);
10004 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10006 end Set_Inline_Flags;
10008 -- Start of processing for Process_Inline
10011 -- An inlined subprogram may grant access to its private enclosing
10012 -- context depending on the placement of its body. From elaboration
10013 -- point of view, the flow of execution may enter this private
10014 -- context, and then reach an external unit, thus producing a
10015 -- dependency on that external unit. For such a path to be properly
10016 -- discovered and encoded in the ALI file of the main unit, let the
10017 -- ABE mechanism process the body of the main unit, and encode all
10018 -- relevant invocation constructs and the relations between them.
10020 Mark_Save_Invocation_Graph_Of_Body;
10022 Check_No_Identifiers;
10023 Check_At_Least_N_Arguments (1);
10025 if Status = Enabled then
10026 Inline_Processing_Required := True;
10030 while Present (Assoc) loop
10031 Subp_Id := Get_Pragma_Arg (Assoc);
10035 if Is_Entity_Name (Subp_Id) then
10036 Subp := Entity (Subp_Id);
10038 if Subp = Any_Id then
10040 -- If previous error, avoid cascaded errors
10042 Check_Error_Detected;
10046 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10047 -- is given that directly specifies an aspect of an entity,
10048 -- then it is illegal to give another [...]
10049 -- aspect_specification that directly specifies the same
10050 -- aspect of the entity.
10051 -- We only check Subp directly as per "directly specifies"
10052 -- above and because the case of pragma Inline is really
10053 -- special given its pre aspect usage.
10055 Check_Duplicate_Pragma (Subp);
10056 Record_Rep_Item (Subp, N);
10058 Make_Inline (Subp);
10060 -- For the pragma case, climb homonym chain. This is
10061 -- what implements allowing the pragma in the renaming
10062 -- case, with the result applying to the ancestors, and
10063 -- also allows Inline to apply to all previous homonyms.
10065 if not From_Aspect_Specification (N) then
10066 while Present (Homonym (Subp))
10067 and then Scope (Homonym (Subp)) = Current_Scope
10069 Subp := Homonym (Subp);
10070 Make_Inline (Subp);
10076 if not Applies then
10077 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10083 -- If the context is a package declaration, the pragma indicates
10084 -- that inlining will require the presence of the corresponding
10085 -- body. (this may be further refined).
10088 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10089 N_Package_Declaration
10091 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10093 end Process_Inline;
10095 ----------------------------
10096 -- Process_Interface_Name --
10097 ----------------------------
10099 procedure Process_Interface_Name
10100 (Subprogram_Def : Entity_Id;
10102 Link_Arg : Node_Id;
10106 Link_Nam : Node_Id;
10107 String_Val : String_Id;
10109 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10110 -- SN is a string literal node for an interface name. This routine
10111 -- performs some minimal checks that the name is reasonable. In
10112 -- particular that no spaces or other obviously incorrect characters
10113 -- appear. This is only a warning, since any characters are allowed.
10115 ----------------------------------
10116 -- Check_Form_Of_Interface_Name --
10117 ----------------------------------
10119 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10120 S : constant String_Id := Strval (Expr_Value_S (SN));
10121 SL : constant Nat := String_Length (S);
10126 Error_Msg_N ("interface name cannot be null string", SN);
10129 for J in 1 .. SL loop
10130 C := Get_String_Char (S, J);
10132 -- Look for dubious character and issue unconditional warning.
10133 -- Definitely dubious if not in character range.
10135 if not In_Character_Range (C)
10137 -- Commas, spaces and (back)slashes are dubious
10139 or else Get_Character (C) = ','
10140 or else Get_Character (C) = '\'
10141 or else Get_Character (C) = ' '
10142 or else Get_Character (C) = '/'
10145 ("??interface name contains illegal character",
10146 Sloc (SN) + Source_Ptr (J));
10149 end Check_Form_Of_Interface_Name;
10151 -- Start of processing for Process_Interface_Name
10154 -- If we are looking at a pragma that comes from an aspect then it
10155 -- needs to have its corresponding aspect argument expressions
10156 -- analyzed in addition to the generated pragma so that aspects
10157 -- within generic units get properly resolved.
10159 if Present (Prag) and then From_Aspect_Specification (Prag) then
10161 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10169 -- Obtain all interfacing aspects used to construct the pragma
10171 Get_Interfacing_Aspects
10172 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10174 -- Analyze the expression of aspect External_Name
10176 if Present (EN) then
10177 Analyze (Expression (EN));
10180 -- Analyze the expressio of aspect Link_Name
10182 if Present (LN) then
10183 Analyze (Expression (LN));
10188 if No (Link_Arg) then
10189 if No (Ext_Arg) then
10192 elsif Chars (Ext_Arg) = Name_Link_Name then
10194 Link_Nam := Expression (Ext_Arg);
10197 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10198 Ext_Nam := Expression (Ext_Arg);
10203 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10204 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10205 Ext_Nam := Expression (Ext_Arg);
10206 Link_Nam := Expression (Link_Arg);
10209 -- Check expressions for external name and link name are static
10211 if Present (Ext_Nam) then
10212 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10213 Check_Form_Of_Interface_Name (Ext_Nam);
10215 -- Verify that external name is not the name of a local entity,
10216 -- which would hide the imported one and could lead to run-time
10217 -- surprises. The problem can only arise for entities declared in
10218 -- a package body (otherwise the external name is fully qualified
10219 -- and will not conflict).
10227 if Prag_Id = Pragma_Import then
10228 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10229 E := Entity_Id (Get_Name_Table_Int (Nam));
10231 if Nam /= Chars (Subprogram_Def)
10232 and then Present (E)
10233 and then not Is_Overloadable (E)
10234 and then Is_Immediately_Visible (E)
10235 and then not Is_Imported (E)
10236 and then Ekind (Scope (E)) = E_Package
10239 while Present (Par) loop
10240 if Nkind (Par) = N_Package_Body then
10241 Error_Msg_Sloc := Sloc (E);
10243 ("imported entity is hidden by & declared#",
10248 Par := Parent (Par);
10255 if Present (Link_Nam) then
10256 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10257 Check_Form_Of_Interface_Name (Link_Nam);
10260 -- If there is no link name, just set the external name
10262 if No (Link_Nam) then
10263 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10265 -- For the Link_Name case, the given literal is preceded by an
10266 -- asterisk, which indicates to GCC that the given name should be
10267 -- taken literally, and in particular that no prepending of
10268 -- underlines should occur, even in systems where this is the
10273 Store_String_Char (Get_Char_Code ('*'));
10274 String_Val := Strval (Expr_Value_S (Link_Nam));
10275 Store_String_Chars (String_Val);
10277 Make_String_Literal (Sloc (Link_Nam),
10278 Strval => End_String);
10281 -- Set the interface name. If the entity is a generic instance, use
10282 -- its alias, which is the callable entity.
10284 if Is_Generic_Instance (Subprogram_Def) then
10285 Set_Encoded_Interface_Name
10286 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10288 Set_Encoded_Interface_Name
10289 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10292 Check_Duplicated_Export_Name (Link_Nam);
10293 end Process_Interface_Name;
10295 -----------------------------------------
10296 -- Process_Interrupt_Or_Attach_Handler --
10297 -----------------------------------------
10299 procedure Process_Interrupt_Or_Attach_Handler is
10300 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10301 Prot_Typ : constant Entity_Id := Scope (Handler);
10304 -- A pragma that applies to a Ghost entity becomes Ghost for the
10305 -- purposes of legality checks and removal of ignored Ghost code.
10307 Mark_Ghost_Pragma (N, Handler);
10308 Set_Is_Interrupt_Handler (Handler);
10310 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10312 Record_Rep_Item (Prot_Typ, N);
10314 -- Chain the pragma on the contract for completeness
10316 Add_Contract_Item (N, Handler);
10317 end Process_Interrupt_Or_Attach_Handler;
10319 --------------------------------------------------
10320 -- Process_Restrictions_Or_Restriction_Warnings --
10321 --------------------------------------------------
10323 -- Note: some of the simple identifier cases were handled in par-prag,
10324 -- but it is harmless (and more straightforward) to simply handle all
10325 -- cases here, even if it means we repeat a bit of work in some cases.
10327 procedure Process_Restrictions_Or_Restriction_Warnings
10331 R_Id : Restriction_Id;
10337 -- Ignore all Restrictions pragmas in CodePeer mode
10339 if CodePeer_Mode then
10343 Check_Ada_83_Warning;
10344 Check_At_Least_N_Arguments (1);
10345 Check_Valid_Configuration_Pragma;
10348 while Present (Arg) loop
10350 Expr := Get_Pragma_Arg (Arg);
10352 -- Case of no restriction identifier present
10354 if Id = No_Name then
10355 if Nkind (Expr) /= N_Identifier then
10357 ("invalid form for restriction", Arg);
10362 (Process_Restriction_Synonyms (Expr));
10364 if R_Id not in All_Boolean_Restrictions then
10365 Error_Msg_Name_1 := Pname;
10367 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10369 -- Check for possible misspelling
10371 for J in Restriction_Id loop
10373 Rnm : constant String := Restriction_Id'Image (J);
10376 Name_Buffer (1 .. Rnm'Length) := Rnm;
10377 Name_Len := Rnm'Length;
10378 Set_Casing (All_Lower_Case);
10380 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10383 (Source_Index (Current_Sem_Unit)));
10384 Error_Msg_String (1 .. Rnm'Length) :=
10385 Name_Buffer (1 .. Name_Len);
10386 Error_Msg_Strlen := Rnm'Length;
10387 Error_Msg_N -- CODEFIX
10388 ("\possible misspelling of ""~""",
10389 Get_Pragma_Arg (Arg));
10398 if Implementation_Restriction (R_Id) then
10399 Check_Restriction (No_Implementation_Restrictions, Arg);
10402 -- Special processing for No_Elaboration_Code restriction
10404 if R_Id = No_Elaboration_Code then
10406 -- Restriction is only recognized within a configuration
10407 -- pragma file, or within a unit of the main extended
10408 -- program. Note: the test for Main_Unit is needed to
10409 -- properly include the case of configuration pragma files.
10411 if not (Current_Sem_Unit = Main_Unit
10412 or else In_Extended_Main_Source_Unit (N))
10416 -- Don't allow in a subunit unless already specified in
10419 elsif Nkind (Parent (N)) = N_Compilation_Unit
10420 and then Nkind (Unit (Parent (N))) = N_Subunit
10421 and then not Restriction_Active (No_Elaboration_Code)
10424 ("invalid specification of ""No_Elaboration_Code""",
10427 ("\restriction cannot be specified in a subunit", N);
10429 ("\unless also specified in body or spec", N);
10432 -- If we accept a No_Elaboration_Code restriction, then it
10433 -- needs to be added to the configuration restriction set so
10434 -- that we get proper application to other units in the main
10435 -- extended source as required.
10438 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10441 -- Special processing for No_Tasking restriction (not just a
10442 -- warning) when it appears as a configuration pragma.
10444 elsif R_Id = No_Tasking
10445 and then No (Cunit (Main_Unit))
10448 Set_Global_No_Tasking;
10451 Set_Restriction (R_Id, N, Warn);
10453 if R_Id = No_Dynamic_CPU_Assignment
10454 or else R_Id = No_Tasks_Unassigned_To_CPU
10456 -- These imply No_Dependence =>
10457 -- "System.Multiprocessors.Dispatching_Domains".
10458 -- This is not strictly what the AI says, but it eliminates
10459 -- the need for run-time checks, which are undesirable in
10462 Set_Restriction_No_Dependence
10464 (Sel_Comp ("system", "multiprocessors", Loc),
10465 "dispatching_domains"),
10469 if R_Id = No_Tasks_Unassigned_To_CPU then
10470 -- Likewise, imply No_Dynamic_CPU_Assignment
10472 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
10475 -- Check for obsolescent restrictions in Ada 2005 mode
10478 and then Ada_Version >= Ada_2005
10479 and then (R_Id = No_Asynchronous_Control
10481 R_Id = No_Unchecked_Deallocation
10483 R_Id = No_Unchecked_Conversion)
10485 Check_Restriction (No_Obsolescent_Features, N);
10488 -- A very special case that must be processed here: pragma
10489 -- Restrictions (No_Exceptions) turns off all run-time
10490 -- checking. This is a bit dubious in terms of the formal
10491 -- language definition, but it is what is intended by RM
10492 -- H.4(12). Restriction_Warnings never affects generated code
10493 -- so this is done only in the real restriction case.
10495 -- Atomic_Synchronization is not a real check, so it is not
10496 -- affected by this processing).
10498 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10499 -- run-time checks in CodePeer and GNATprove modes: we want to
10500 -- generate checks for analysis purposes, as set respectively
10501 -- by -gnatC and -gnatd.F
10504 and then not (CodePeer_Mode or GNATprove_Mode)
10505 and then R_Id = No_Exceptions
10507 for J in Scope_Suppress.Suppress'Range loop
10508 if J /= Atomic_Synchronization then
10509 Scope_Suppress.Suppress (J) := True;
10514 -- Case of No_Dependence => unit-name. Note that the parser
10515 -- already made the necessary entry in the No_Dependence table.
10517 elsif Id = Name_No_Dependence then
10518 if not OK_No_Dependence_Unit_Name (Expr) then
10522 -- Case of No_Specification_Of_Aspect => aspect-identifier
10524 elsif Id = Name_No_Specification_Of_Aspect then
10529 if Nkind (Expr) /= N_Identifier then
10532 A_Id := Get_Aspect_Id (Chars (Expr));
10535 if A_Id = No_Aspect then
10536 Error_Pragma_Arg ("invalid restriction name", Arg);
10538 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10542 -- Case of No_Use_Of_Attribute => attribute-identifier
10544 elsif Id = Name_No_Use_Of_Attribute then
10545 if Nkind (Expr) /= N_Identifier
10546 or else not Is_Attribute_Name (Chars (Expr))
10548 Error_Msg_N ("unknown attribute name??", Expr);
10551 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10554 -- Case of No_Use_Of_Entity => fully-qualified-name
10556 elsif Id = Name_No_Use_Of_Entity then
10558 -- Restriction is only recognized within a configuration
10559 -- pragma file, or within a unit of the main extended
10560 -- program. Note: the test for Main_Unit is needed to
10561 -- properly include the case of configuration pragma files.
10563 if Current_Sem_Unit = Main_Unit
10564 or else In_Extended_Main_Source_Unit (N)
10566 if not OK_No_Dependence_Unit_Name (Expr) then
10567 Error_Msg_N ("wrong form for entity name", Expr);
10569 Set_Restriction_No_Use_Of_Entity
10570 (Expr, Warn, No_Profile);
10574 -- Case of No_Use_Of_Pragma => pragma-identifier
10576 elsif Id = Name_No_Use_Of_Pragma then
10577 if Nkind (Expr) /= N_Identifier
10578 or else not Is_Pragma_Name (Chars (Expr))
10580 Error_Msg_N ("unknown pragma name??", Expr);
10582 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10585 -- All other cases of restriction identifier present
10588 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10589 Analyze_And_Resolve (Expr, Any_Integer);
10591 if R_Id not in All_Parameter_Restrictions then
10593 ("invalid restriction parameter identifier", Arg);
10595 elsif not Is_OK_Static_Expression (Expr) then
10596 Flag_Non_Static_Expr
10597 ("value must be static expression!", Expr);
10600 elsif not Is_Integer_Type (Etype (Expr))
10601 or else Expr_Value (Expr) < 0
10604 ("value must be non-negative integer", Arg);
10607 -- Restriction pragma is active
10609 Val := Expr_Value (Expr);
10611 if not UI_Is_In_Int_Range (Val) then
10613 ("pragma ignored, value too large??", Arg);
10616 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
10621 end Process_Restrictions_Or_Restriction_Warnings;
10623 ---------------------------------
10624 -- Process_Suppress_Unsuppress --
10625 ---------------------------------
10627 -- Note: this procedure makes entries in the check suppress data
10628 -- structures managed by Sem. See spec of package Sem for full
10629 -- details on how we handle recording of check suppression.
10631 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10636 In_Package_Spec : constant Boolean :=
10637 Is_Package_Or_Generic_Package (Current_Scope)
10638 and then not In_Package_Body (Current_Scope);
10640 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10641 -- Used to suppress a single check on the given entity
10643 --------------------------------
10644 -- Suppress_Unsuppress_Echeck --
10645 --------------------------------
10647 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10649 -- Check for error of trying to set atomic synchronization for
10650 -- a non-atomic variable.
10652 if C = Atomic_Synchronization
10653 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10656 ("pragma & requires atomic type or variable",
10657 Pragma_Identifier (Original_Node (N)));
10660 Set_Checks_May_Be_Suppressed (E);
10662 if In_Package_Spec then
10663 Push_Global_Suppress_Stack_Entry
10666 Suppress => Suppress_Case);
10668 Push_Local_Suppress_Stack_Entry
10671 Suppress => Suppress_Case);
10674 -- If this is a first subtype, and the base type is distinct,
10675 -- then also set the suppress flags on the base type.
10677 if Is_First_Subtype (E) and then Etype (E) /= E then
10678 Suppress_Unsuppress_Echeck (Etype (E), C);
10680 end Suppress_Unsuppress_Echeck;
10682 -- Start of processing for Process_Suppress_Unsuppress
10685 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10686 -- on user code: we want to generate checks for analysis purposes, as
10687 -- set respectively by -gnatC and -gnatd.F
10689 if Comes_From_Source (N)
10690 and then (CodePeer_Mode or GNATprove_Mode)
10695 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10696 -- declarative part or a package spec (RM 11.5(5)).
10698 if not Is_Configuration_Pragma then
10699 Check_Is_In_Decl_Part_Or_Package_Spec;
10702 Check_At_Least_N_Arguments (1);
10703 Check_At_Most_N_Arguments (2);
10704 Check_No_Identifier (Arg1);
10705 Check_Arg_Is_Identifier (Arg1);
10707 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10709 if C = No_Check_Id then
10711 ("argument of pragma% is not valid check name", Arg1);
10714 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10716 if C = Elaboration_Check and then SPARK_Mode = On then
10718 ("Suppress of Elaboration_Check ignored in SPARK??",
10719 "\elaboration checking rules are statically enforced "
10720 & "(SPARK RM 7.7)", Arg1);
10723 -- One-argument case
10725 if Arg_Count = 1 then
10727 -- Make an entry in the local scope suppress table. This is the
10728 -- table that directly shows the current value of the scope
10729 -- suppress check for any check id value.
10731 if C = All_Checks then
10733 -- For All_Checks, we set all specific predefined checks with
10734 -- the exception of Elaboration_Check, which is handled
10735 -- specially because of not wanting All_Checks to have the
10736 -- effect of deactivating static elaboration order processing.
10737 -- Atomic_Synchronization is also not affected, since this is
10738 -- not a real check.
10740 for J in Scope_Suppress.Suppress'Range loop
10741 if J /= Elaboration_Check
10743 J /= Atomic_Synchronization
10745 Scope_Suppress.Suppress (J) := Suppress_Case;
10749 -- If not All_Checks, and predefined check, then set appropriate
10750 -- scope entry. Note that we will set Elaboration_Check if this
10751 -- is explicitly specified. Atomic_Synchronization is allowed
10752 -- only if internally generated and entity is atomic.
10754 elsif C in Predefined_Check_Id
10755 and then (not Comes_From_Source (N)
10756 or else C /= Atomic_Synchronization)
10758 Scope_Suppress.Suppress (C) := Suppress_Case;
10761 -- Also make an entry in the Local_Entity_Suppress table
10763 Push_Local_Suppress_Stack_Entry
10766 Suppress => Suppress_Case);
10768 -- Case of two arguments present, where the check is suppressed for
10769 -- a specified entity (given as the second argument of the pragma)
10772 -- This is obsolescent in Ada 2005 mode
10774 if Ada_Version >= Ada_2005 then
10775 Check_Restriction (No_Obsolescent_Features, Arg2);
10778 Check_Optional_Identifier (Arg2, Name_On);
10779 E_Id := Get_Pragma_Arg (Arg2);
10782 if not Is_Entity_Name (E_Id) then
10784 ("second argument of pragma% must be entity name", Arg2);
10787 E := Entity (E_Id);
10793 -- A pragma that applies to a Ghost entity becomes Ghost for the
10794 -- purposes of legality checks and removal of ignored Ghost code.
10796 Mark_Ghost_Pragma (N, E);
10798 -- Enforce RM 11.5(7) which requires that for a pragma that
10799 -- appears within a package spec, the named entity must be
10800 -- within the package spec. We allow the package name itself
10801 -- to be mentioned since that makes sense, although it is not
10802 -- strictly allowed by 11.5(7).
10805 and then E /= Current_Scope
10806 and then Scope (E) /= Current_Scope
10809 ("entity in pragma% is not in package spec (RM 11.5(7))",
10813 -- Loop through homonyms. As noted below, in the case of a package
10814 -- spec, only homonyms within the package spec are considered.
10817 Suppress_Unsuppress_Echeck (E, C);
10819 if Is_Generic_Instance (E)
10820 and then Is_Subprogram (E)
10821 and then Present (Alias (E))
10823 Suppress_Unsuppress_Echeck (Alias (E), C);
10826 -- Move to next homonym if not aspect spec case
10828 exit when From_Aspect_Specification (N);
10832 -- If we are within a package specification, the pragma only
10833 -- applies to homonyms in the same scope.
10835 exit when In_Package_Spec
10836 and then Scope (E) /= Current_Scope;
10839 end Process_Suppress_Unsuppress;
10841 -------------------------------
10842 -- Record_Independence_Check --
10843 -------------------------------
10845 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10846 pragma Unreferenced (N, E);
10848 -- For GCC back ends the validation is done a priori
10849 -- ??? This code is dead, might be useful in the future
10851 -- if not AAMP_On_Target then
10855 -- Independence_Checks.Append ((N, E));
10858 end Record_Independence_Check;
10864 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10866 if Is_Imported (E) then
10868 ("cannot export entity& that was previously imported", Arg);
10870 elsif Present (Address_Clause (E))
10871 and then not Relaxed_RM_Semantics
10874 ("cannot export entity& that has an address clause", Arg);
10877 Set_Is_Exported (E);
10879 -- Generate a reference for entity explicitly, because the
10880 -- identifier may be overloaded and name resolution will not
10883 Generate_Reference (E, Arg);
10885 -- Deal with exporting non-library level entity
10887 if not Is_Library_Level_Entity (E) then
10889 -- Not allowed at all for subprograms
10891 if Is_Subprogram (E) then
10892 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10894 -- Otherwise set public and statically allocated
10898 Set_Is_Statically_Allocated (E);
10900 -- Warn if the corresponding W flag is set
10902 if Warn_On_Export_Import
10904 -- Only do this for something that was in the source. Not
10905 -- clear if this can be False now (there used for sure to be
10906 -- cases on some systems where it was False), but anyway the
10907 -- test is harmless if not needed, so it is retained.
10909 and then Comes_From_Source (Arg)
10912 ("?x?& has been made static as a result of Export",
10915 ("\?x?this usage is non-standard and non-portable",
10921 if Warn_On_Export_Import and then Is_Type (E) then
10922 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10925 if Warn_On_Export_Import and Inside_A_Generic then
10927 ("all instances of& will have the same external name?x?",
10932 ----------------------------------------------
10933 -- Set_Extended_Import_Export_External_Name --
10934 ----------------------------------------------
10936 procedure Set_Extended_Import_Export_External_Name
10937 (Internal_Ent : Entity_Id;
10938 Arg_External : Node_Id)
10940 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10941 New_Name : Node_Id;
10944 if No (Arg_External) then
10948 Check_Arg_Is_External_Name (Arg_External);
10950 if Nkind (Arg_External) = N_String_Literal then
10951 if String_Length (Strval (Arg_External)) = 0 then
10954 New_Name := Adjust_External_Name_Case (Arg_External);
10957 elsif Nkind (Arg_External) = N_Identifier then
10958 New_Name := Get_Default_External_Name (Arg_External);
10960 -- Check_Arg_Is_External_Name should let through only identifiers and
10961 -- string literals or static string expressions (which are folded to
10962 -- string literals).
10965 raise Program_Error;
10968 -- If we already have an external name set (by a prior normal Import
10969 -- or Export pragma), then the external names must match
10971 if Present (Interface_Name (Internal_Ent)) then
10973 -- Ignore mismatching names in CodePeer mode, to support some
10974 -- old compilers which would export the same procedure under
10975 -- different names, e.g:
10977 -- pragma Export_Procedure (P, "a");
10978 -- pragma Export_Procedure (P, "b");
10980 if CodePeer_Mode then
10984 Check_Matching_Internal_Names : declare
10985 S1 : constant String_Id := Strval (Old_Name);
10986 S2 : constant String_Id := Strval (New_Name);
10988 procedure Mismatch;
10989 pragma No_Return (Mismatch);
10990 -- Called if names do not match
10996 procedure Mismatch is
10998 Error_Msg_Sloc := Sloc (Old_Name);
11000 ("external name does not match that given #",
11004 -- Start of processing for Check_Matching_Internal_Names
11007 if String_Length (S1) /= String_Length (S2) then
11011 for J in 1 .. String_Length (S1) loop
11012 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11017 end Check_Matching_Internal_Names;
11019 -- Otherwise set the given name
11022 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11023 Check_Duplicated_Export_Name (New_Name);
11025 end Set_Extended_Import_Export_External_Name;
11031 procedure Set_Imported (E : Entity_Id) is
11033 -- Error message if already imported or exported
11035 if Is_Exported (E) or else Is_Imported (E) then
11037 -- Error if being set Exported twice
11039 if Is_Exported (E) then
11040 Error_Msg_NE ("entity& was previously exported", N, E);
11042 -- Ignore error in CodePeer mode where we treat all imported
11043 -- subprograms as unknown.
11045 elsif CodePeer_Mode then
11048 -- OK if Import/Interface case
11050 elsif Import_Interface_Present (N) then
11053 -- Error if being set Imported twice
11056 Error_Msg_NE ("entity& was previously imported", N, E);
11059 Error_Msg_Name_1 := Pname;
11061 ("\(pragma% applies to all previous entities)", N);
11063 Error_Msg_Sloc := Sloc (E);
11064 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11066 -- Here if not previously imported or exported, OK to import
11069 Set_Is_Imported (E);
11071 -- For subprogram, set Import_Pragma field
11073 if Is_Subprogram (E) then
11074 Set_Import_Pragma (E, N);
11077 -- If the entity is an object that is not at the library level,
11078 -- then it is statically allocated. We do not worry about objects
11079 -- with address clauses in this context since they are not really
11080 -- imported in the linker sense.
11083 and then not Is_Library_Level_Entity (E)
11084 and then No (Address_Clause (E))
11086 Set_Is_Statically_Allocated (E);
11093 -------------------------
11094 -- Set_Mechanism_Value --
11095 -------------------------
11097 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11098 -- analyzed, since it is semantic nonsense), so we get it in the exact
11099 -- form created by the parser.
11101 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11102 procedure Bad_Mechanism;
11103 pragma No_Return (Bad_Mechanism);
11104 -- Signal bad mechanism name
11106 -------------------
11107 -- Bad_Mechanism --
11108 -------------------
11110 procedure Bad_Mechanism is
11112 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11115 -- Start of processing for Set_Mechanism_Value
11118 if Mechanism (Ent) /= Default_Mechanism then
11120 ("mechanism for & has already been set", Mech_Name, Ent);
11123 -- MECHANISM_NAME ::= value | reference
11125 if Nkind (Mech_Name) = N_Identifier then
11126 if Chars (Mech_Name) = Name_Value then
11127 Set_Mechanism (Ent, By_Copy);
11130 elsif Chars (Mech_Name) = Name_Reference then
11131 Set_Mechanism (Ent, By_Reference);
11134 elsif Chars (Mech_Name) = Name_Copy then
11136 ("bad mechanism name, Value assumed", Mech_Name);
11145 end Set_Mechanism_Value;
11147 --------------------------
11148 -- Set_Rational_Profile --
11149 --------------------------
11151 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11152 -- extension to the semantics of renaming declarations.
11154 procedure Set_Rational_Profile is
11156 Implicit_Packing := True;
11157 Overriding_Renamings := True;
11158 Use_VADS_Size := True;
11159 end Set_Rational_Profile;
11161 ---------------------------
11162 -- Set_Ravenscar_Profile --
11163 ---------------------------
11165 -- The tasks to be done here are
11167 -- Set required policies
11169 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11170 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11171 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11172 -- (For GNAT_Ravenscar_EDF profile)
11173 -- pragma Locking_Policy (Ceiling_Locking)
11175 -- Set Detect_Blocking mode
11177 -- Set required restrictions (see System.Rident for detailed list)
11179 -- Set the No_Dependence rules
11180 -- No_Dependence => Ada.Asynchronous_Task_Control
11181 -- No_Dependence => Ada.Calendar
11182 -- No_Dependence => Ada.Execution_Time.Group_Budget
11183 -- No_Dependence => Ada.Execution_Time.Timers
11184 -- No_Dependence => Ada.Task_Attributes
11185 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11187 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11188 procedure Set_Error_Msg_To_Profile_Name;
11189 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11192 -----------------------------------
11193 -- Set_Error_Msg_To_Profile_Name --
11194 -----------------------------------
11196 procedure Set_Error_Msg_To_Profile_Name is
11197 Prof_Nam : constant Node_Id :=
11199 (First (Pragma_Argument_Associations (N)));
11202 Get_Name_String (Chars (Prof_Nam));
11203 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11204 Error_Msg_Strlen := Name_Len;
11205 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11206 end Set_Error_Msg_To_Profile_Name;
11208 Profile_Dispatching_Policy : Character;
11210 -- Start of processing for Set_Ravenscar_Profile
11213 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11215 if Profile = GNAT_Ravenscar_EDF then
11216 Profile_Dispatching_Policy := 'E';
11218 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11221 Profile_Dispatching_Policy := 'F';
11224 if Task_Dispatching_Policy /= ' '
11225 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11227 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11228 Set_Error_Msg_To_Profile_Name;
11229 Error_Pragma ("Profile (~) incompatible with policy#");
11231 -- Set the FIFO_Within_Priorities policy, but always preserve
11232 -- System_Location since we like the error message with the run time
11236 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11238 if Task_Dispatching_Policy_Sloc /= System_Location then
11239 Task_Dispatching_Policy_Sloc := Loc;
11243 -- pragma Locking_Policy (Ceiling_Locking)
11245 if Locking_Policy /= ' '
11246 and then Locking_Policy /= 'C'
11248 Error_Msg_Sloc := Locking_Policy_Sloc;
11249 Set_Error_Msg_To_Profile_Name;
11250 Error_Pragma ("Profile (~) incompatible with policy#");
11252 -- Set the Ceiling_Locking policy, but preserve System_Location since
11253 -- we like the error message with the run time name.
11256 Locking_Policy := 'C';
11258 if Locking_Policy_Sloc /= System_Location then
11259 Locking_Policy_Sloc := Loc;
11263 -- pragma Detect_Blocking
11265 Detect_Blocking := True;
11267 -- Set the corresponding restrictions
11269 Set_Profile_Restrictions
11270 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11272 -- Set the No_Dependence restrictions
11274 -- The following No_Dependence restrictions:
11275 -- No_Dependence => Ada.Asynchronous_Task_Control
11276 -- No_Dependence => Ada.Calendar
11277 -- No_Dependence => Ada.Task_Attributes
11278 -- are already set by previous call to Set_Profile_Restrictions.
11281 -- Set the following restrictions which were added to Ada 2005:
11282 -- No_Dependence => Ada.Execution_Time.Group_Budget
11283 -- No_Dependence => Ada.Execution_Time.Timers
11285 if Ada_Version >= Ada_2005 then
11287 Execution_Time : constant Node_Id :=
11288 Sel_Comp ("ada", "execution_time", Loc);
11289 Group_Budgets : constant Node_Id :=
11290 Sel_Comp (Execution_Time, "group_budgets");
11291 Timers : constant Node_Id :=
11292 Sel_Comp (Execution_Time, "timers");
11294 Set_Restriction_No_Dependence
11295 (Unit => Group_Budgets,
11296 Warn => Treat_Restrictions_As_Warnings,
11297 Profile => Ravenscar);
11298 Set_Restriction_No_Dependence
11300 Warn => Treat_Restrictions_As_Warnings,
11301 Profile => Ravenscar);
11305 -- Set the following restriction which was added to Ada 2012 (see
11307 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11309 if Ada_Version >= Ada_2012 then
11310 Set_Restriction_No_Dependence
11312 (Sel_Comp ("system", "multiprocessors", Loc),
11313 "dispatching_domains"),
11314 Warn => Treat_Restrictions_As_Warnings,
11315 Profile => Ravenscar);
11317 -- Set the following restriction which was added to Ada 2020,
11318 -- but as a binding interpretation:
11319 -- No_Dependence => Ada.Synchronous_Barriers
11320 -- for Ravenscar (and therefore for Ravenscar variants) but not
11321 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11322 -- in Ada2012 (AI05-0174).
11324 if Profile /= Jorvik then
11325 Set_Restriction_No_Dependence
11326 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11327 Warn => Treat_Restrictions_As_Warnings,
11328 Profile => Ravenscar);
11332 end Set_Ravenscar_Profile;
11334 -- Start of processing for Analyze_Pragma
11337 -- The following code is a defense against recursion. Not clear that
11338 -- this can happen legitimately, but perhaps some error situations can
11339 -- cause it, and we did see this recursion during testing.
11341 if Analyzed (N) then
11347 Check_Restriction_No_Use_Of_Pragma (N);
11349 if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
11350 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11351 -- no aspect_specification, attribute_definition_clause, or pragma
11353 Check_Restriction_No_Specification_Of_Aspect (N);
11356 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11357 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11359 if Should_Ignore_Pragma_Sem (N)
11360 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11361 and then Ignore_Rep_Clauses)
11366 -- Deal with unrecognized pragma
11368 if not Is_Pragma_Name (Pname) then
11370 Msg_Issued : Boolean := False;
11373 (Msg_Issued, No_Unrecognized_Pragmas, Pragma_Identifier (N));
11374 if not Msg_Issued and then Warn_On_Unrecognized_Pragma then
11375 Error_Msg_Name_1 := Pname;
11376 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11378 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11379 if Is_Bad_Spelling_Of (Pname, PN) then
11380 Error_Msg_Name_1 := PN;
11381 Error_Msg_N -- CODEFIX
11382 ("\?g?possible misspelling of %!",
11383 Pragma_Identifier (N));
11393 -- Here to start processing for recognized pragma
11395 Pname := Original_Aspect_Pragma_Name (N);
11397 -- Capture setting of Opt.Uneval_Old
11399 case Opt.Uneval_Old is
11401 Set_Uneval_Old_Accept (N);
11407 Set_Uneval_Old_Warn (N);
11410 raise Program_Error;
11413 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11414 -- is already set, indicating that we have already checked the policy
11415 -- at the right point. This happens for example in the case of a pragma
11416 -- that is derived from an Aspect.
11418 if Is_Ignored (N) or else Is_Checked (N) then
11421 -- For a pragma that is a rewriting of another pragma, copy the
11422 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11424 elsif Is_Rewrite_Substitution (N)
11425 and then Nkind (Original_Node (N)) = N_Pragma
11427 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11428 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11430 -- Otherwise query the applicable policy at this point
11433 Check_Applicable_Policy (N);
11435 -- If pragma is disabled, rewrite as NULL and skip analysis
11437 if Is_Disabled (N) then
11438 Rewrite (N, Make_Null_Statement (Loc));
11444 -- Mark assertion pragmas as Ghost depending on their enclosing context
11446 if Assertion_Expression_Pragma (Prag_Id) then
11447 Mark_Ghost_Pragma (N, Current_Scope);
11450 -- Preset arguments
11459 if Present (Pragma_Argument_Associations (N)) then
11460 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11461 Arg1 := First (Pragma_Argument_Associations (N));
11463 if Present (Arg1) then
11464 Arg2 := Next (Arg1);
11466 if Present (Arg2) then
11467 Arg3 := Next (Arg2);
11469 if Present (Arg3) then
11470 Arg4 := Next (Arg3);
11472 if Present (Arg4) then
11473 Arg5 := Next (Arg4);
11480 -- An enumeration type defines the pragmas that are supported by the
11481 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11482 -- into the corresponding enumeration value for the following case.
11490 -- pragma Abort_Defer;
11492 when Pragma_Abort_Defer =>
11494 Check_Arg_Count (0);
11496 -- The only required semantic processing is to check the
11497 -- placement. This pragma must appear at the start of the
11498 -- statement sequence of a handled sequence of statements.
11500 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11501 or else N /= First (Statements (Parent (N)))
11506 --------------------
11507 -- Abstract_State --
11508 --------------------
11510 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11512 -- ABSTRACT_STATE_LIST ::=
11514 -- | STATE_NAME_WITH_OPTIONS
11515 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11517 -- STATE_NAME_WITH_OPTIONS ::=
11519 -- | (STATE_NAME with OPTION_LIST)
11521 -- OPTION_LIST ::= OPTION {, OPTION}
11525 -- | NAME_VALUE_OPTION
11527 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11529 -- NAME_VALUE_OPTION ::=
11530 -- Part_Of => ABSTRACT_STATE
11531 -- | External [=> EXTERNAL_PROPERTY_LIST]
11533 -- EXTERNAL_PROPERTY_LIST ::=
11534 -- EXTERNAL_PROPERTY
11535 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11537 -- EXTERNAL_PROPERTY ::=
11538 -- Async_Readers [=> boolean_EXPRESSION]
11539 -- | Async_Writers [=> boolean_EXPRESSION]
11540 -- | Effective_Reads [=> boolean_EXPRESSION]
11541 -- | Effective_Writes [=> boolean_EXPRESSION]
11542 -- others => boolean_EXPRESSION
11544 -- STATE_NAME ::= defining_identifier
11546 -- ABSTRACT_STATE ::= name
11548 -- Characteristics:
11550 -- * Analysis - The annotation is fully analyzed immediately upon
11551 -- elaboration as it cannot forward reference entities.
11553 -- * Expansion - None.
11555 -- * Template - The annotation utilizes the generic template of the
11556 -- related package declaration.
11558 -- * Globals - The annotation cannot reference global entities.
11560 -- * Instance - The annotation is instantiated automatically when
11561 -- the related generic package is instantiated.
11563 when Pragma_Abstract_State => Abstract_State : declare
11564 Missing_Parentheses : Boolean := False;
11565 -- Flag set when a state declaration with options is not properly
11568 -- Flags used to verify the consistency of states
11570 Non_Null_Seen : Boolean := False;
11571 Null_Seen : Boolean := False;
11573 procedure Analyze_Abstract_State
11575 Pack_Id : Entity_Id);
11576 -- Verify the legality of a single state declaration. Create and
11577 -- decorate a state abstraction entity and introduce it into the
11578 -- visibility chain. Pack_Id denotes the entity or the related
11579 -- package where pragma Abstract_State appears.
11581 procedure Malformed_State_Error (State : Node_Id);
11582 -- Emit an error concerning the illegal declaration of abstract
11583 -- state State. This routine diagnoses syntax errors that lead to
11584 -- a different parse tree. The error is issued regardless of the
11585 -- SPARK mode in effect.
11587 ----------------------------
11588 -- Analyze_Abstract_State --
11589 ----------------------------
11591 procedure Analyze_Abstract_State
11593 Pack_Id : Entity_Id)
11595 -- Flags used to verify the consistency of options
11597 AR_Seen : Boolean := False;
11598 AW_Seen : Boolean := False;
11599 ER_Seen : Boolean := False;
11600 EW_Seen : Boolean := False;
11601 External_Seen : Boolean := False;
11602 Ghost_Seen : Boolean := False;
11603 Others_Seen : Boolean := False;
11604 Part_Of_Seen : Boolean := False;
11605 Relaxed_Initialization_Seen : Boolean := False;
11606 Synchronous_Seen : Boolean := False;
11608 -- Flags used to store the static value of all external states'
11611 AR_Val : Boolean := False;
11612 AW_Val : Boolean := False;
11613 ER_Val : Boolean := False;
11614 EW_Val : Boolean := False;
11616 State_Id : Entity_Id := Empty;
11617 -- The entity to be generated for the current state declaration
11619 procedure Analyze_External_Option (Opt : Node_Id);
11620 -- Verify the legality of option External
11622 procedure Analyze_External_Property
11624 Expr : Node_Id := Empty);
11625 -- Verify the legailty of a single external property. Prop
11626 -- denotes the external property. Expr is the expression used
11627 -- to set the property.
11629 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11630 -- Verify the legality of option Part_Of
11632 procedure Check_Duplicate_Option
11634 Status : in out Boolean);
11635 -- Flag Status denotes whether a particular option has been
11636 -- seen while processing a state. This routine verifies that
11637 -- Opt is not a duplicate option and sets the flag Status
11638 -- (SPARK RM 7.1.4(1)).
11640 procedure Check_Duplicate_Property
11642 Status : in out Boolean);
11643 -- Flag Status denotes whether a particular property has been
11644 -- seen while processing option External. This routine verifies
11645 -- that Prop is not a duplicate property and sets flag Status.
11646 -- Opt is not a duplicate property and sets the flag Status.
11647 -- (SPARK RM 7.1.4(2))
11649 procedure Check_Ghost_Synchronous;
11650 -- Ensure that the abstract state is not subject to both Ghost
11651 -- and Synchronous simple options. Emit an error if this is the
11654 procedure Create_Abstract_State
11658 Is_Null : Boolean);
11659 -- Generate an abstract state entity with name Nam and enter it
11660 -- into visibility. Decl is the "declaration" of the state as
11661 -- it appears in pragma Abstract_State. Loc is the location of
11662 -- the related state "declaration". Flag Is_Null should be set
11663 -- when the associated Abstract_State pragma defines a null
11666 -----------------------------
11667 -- Analyze_External_Option --
11668 -----------------------------
11670 procedure Analyze_External_Option (Opt : Node_Id) is
11671 Errors : constant Nat := Serious_Errors_Detected;
11673 Props : Node_Id := Empty;
11676 if Nkind (Opt) = N_Component_Association then
11677 Props := Expression (Opt);
11680 -- External state with properties
11682 if Present (Props) then
11684 -- Multiple properties appear as an aggregate
11686 if Nkind (Props) = N_Aggregate then
11688 -- Simple property form
11690 Prop := First (Expressions (Props));
11691 while Present (Prop) loop
11692 Analyze_External_Property (Prop);
11696 -- Property with expression form
11698 Prop := First (Component_Associations (Props));
11699 while Present (Prop) loop
11700 Analyze_External_Property
11701 (Prop => First (Choices (Prop)),
11702 Expr => Expression (Prop));
11710 Analyze_External_Property (Props);
11713 -- An external state defined without any properties defaults
11714 -- all properties to True.
11723 -- Once all external properties have been processed, verify
11724 -- their mutual interaction. Do not perform the check when
11725 -- at least one of the properties is illegal as this will
11726 -- produce a bogus error.
11728 if Errors = Serious_Errors_Detected then
11729 Check_External_Properties
11730 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11732 end Analyze_External_Option;
11734 -------------------------------
11735 -- Analyze_External_Property --
11736 -------------------------------
11738 procedure Analyze_External_Property
11740 Expr : Node_Id := Empty)
11742 Expr_Val : Boolean;
11745 -- Check the placement of "others" (if available)
11747 if Nkind (Prop) = N_Others_Choice then
11748 if Others_Seen then
11750 ("only one others choice allowed in option External",
11753 Others_Seen := True;
11756 elsif Others_Seen then
11758 ("others must be the last property in option External",
11761 -- The only remaining legal options are the four predefined
11762 -- external properties.
11764 elsif Nkind (Prop) = N_Identifier
11765 and then Chars (Prop) in Name_Async_Readers
11766 | Name_Async_Writers
11767 | Name_Effective_Reads
11768 | Name_Effective_Writes
11772 -- Otherwise the construct is not a valid property
11775 SPARK_Msg_N ("invalid external state property", Prop);
11779 -- Ensure that the expression of the external state property
11780 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11782 if Present (Expr) then
11783 Analyze_And_Resolve (Expr, Standard_Boolean);
11785 if Is_OK_Static_Expression (Expr) then
11786 Expr_Val := Is_True (Expr_Value (Expr));
11789 ("expression of external state property must be "
11794 -- The lack of expression defaults the property to True
11800 -- Named properties
11802 if Nkind (Prop) = N_Identifier then
11803 if Chars (Prop) = Name_Async_Readers then
11804 Check_Duplicate_Property (Prop, AR_Seen);
11805 AR_Val := Expr_Val;
11807 elsif Chars (Prop) = Name_Async_Writers then
11808 Check_Duplicate_Property (Prop, AW_Seen);
11809 AW_Val := Expr_Val;
11811 elsif Chars (Prop) = Name_Effective_Reads then
11812 Check_Duplicate_Property (Prop, ER_Seen);
11813 ER_Val := Expr_Val;
11816 Check_Duplicate_Property (Prop, EW_Seen);
11817 EW_Val := Expr_Val;
11820 -- The handling of property "others" must take into account
11821 -- all other named properties that have been encountered so
11822 -- far. Only those that have not been seen are affected by
11826 if not AR_Seen then
11827 AR_Val := Expr_Val;
11830 if not AW_Seen then
11831 AW_Val := Expr_Val;
11834 if not ER_Seen then
11835 ER_Val := Expr_Val;
11838 if not EW_Seen then
11839 EW_Val := Expr_Val;
11842 end Analyze_External_Property;
11844 ----------------------------
11845 -- Analyze_Part_Of_Option --
11846 ----------------------------
11848 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11849 Encap : constant Node_Id := Expression (Opt);
11850 Constits : Elist_Id;
11851 Encap_Id : Entity_Id;
11855 Check_Duplicate_Option (Opt, Part_Of_Seen);
11858 (Indic => First (Choices (Opt)),
11859 Item_Id => State_Id,
11861 Encap_Id => Encap_Id,
11864 -- The Part_Of indicator transforms the abstract state into
11865 -- a constituent of the encapsulating state or single
11866 -- concurrent type.
11869 pragma Assert (Present (Encap_Id));
11870 Constits := Part_Of_Constituents (Encap_Id);
11872 if No (Constits) then
11873 Constits := New_Elmt_List;
11874 Set_Part_Of_Constituents (Encap_Id, Constits);
11877 Append_Elmt (State_Id, Constits);
11878 Set_Encapsulating_State (State_Id, Encap_Id);
11880 end Analyze_Part_Of_Option;
11882 ----------------------------
11883 -- Check_Duplicate_Option --
11884 ----------------------------
11886 procedure Check_Duplicate_Option
11888 Status : in out Boolean)
11892 SPARK_Msg_N ("duplicate state option", Opt);
11896 end Check_Duplicate_Option;
11898 ------------------------------
11899 -- Check_Duplicate_Property --
11900 ------------------------------
11902 procedure Check_Duplicate_Property
11904 Status : in out Boolean)
11908 SPARK_Msg_N ("duplicate external property", Prop);
11912 end Check_Duplicate_Property;
11914 -----------------------------
11915 -- Check_Ghost_Synchronous --
11916 -----------------------------
11918 procedure Check_Ghost_Synchronous is
11920 -- A synchronized abstract state cannot be Ghost and vice
11921 -- versa (SPARK RM 6.9(19)).
11923 if Ghost_Seen and Synchronous_Seen then
11924 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11926 end Check_Ghost_Synchronous;
11928 ---------------------------
11929 -- Create_Abstract_State --
11930 ---------------------------
11932 procedure Create_Abstract_State
11939 -- The abstract state may be semi-declared when the related
11940 -- package was withed through a limited with clause. In that
11941 -- case reuse the entity to fully declare the state.
11943 if Present (Decl) and then Present (Entity (Decl)) then
11944 State_Id := Entity (Decl);
11946 -- Otherwise the elaboration of pragma Abstract_State
11947 -- declares the state.
11950 State_Id := Make_Defining_Identifier (Loc, Nam);
11952 if Present (Decl) then
11953 Set_Entity (Decl, State_Id);
11957 -- Null states never come from source
11959 Set_Comes_From_Source (State_Id, not Is_Null);
11960 Set_Parent (State_Id, State);
11961 Set_Ekind (State_Id, E_Abstract_State);
11962 Set_Etype (State_Id, Standard_Void_Type);
11963 Set_Encapsulating_State (State_Id, Empty);
11965 -- Set the SPARK mode from the current context
11967 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
11968 Set_SPARK_Pragma_Inherited (State_Id);
11970 -- An abstract state declared within a Ghost region becomes
11971 -- Ghost (SPARK RM 6.9(2)).
11973 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11974 Set_Is_Ghost_Entity (State_Id);
11977 -- Establish a link between the state declaration and the
11978 -- abstract state entity. Note that a null state remains as
11979 -- N_Null and does not carry any linkages.
11981 if not Is_Null then
11982 if Present (Decl) then
11983 Set_Entity (Decl, State_Id);
11984 Set_Etype (Decl, Standard_Void_Type);
11987 -- Every non-null state must be defined, nameable and
11990 Push_Scope (Pack_Id);
11991 Generate_Definition (State_Id);
11992 Enter_Name (State_Id);
11995 end Create_Abstract_State;
12002 -- Start of processing for Analyze_Abstract_State
12005 -- A package with a null abstract state is not allowed to
12006 -- declare additional states.
12010 ("package & has null abstract state", State, Pack_Id);
12012 -- Null states appear as internally generated entities
12014 elsif Nkind (State) = N_Null then
12015 Create_Abstract_State
12016 (Nam => New_Internal_Name ('S'),
12018 Loc => Sloc (State),
12022 -- Catch a case where a null state appears in a list of
12023 -- non-null states.
12025 if Non_Null_Seen then
12027 ("package & has non-null abstract state",
12031 -- Simple state declaration
12033 elsif Nkind (State) = N_Identifier then
12034 Create_Abstract_State
12035 (Nam => Chars (State),
12037 Loc => Sloc (State),
12039 Non_Null_Seen := True;
12041 -- State declaration with various options. This construct
12042 -- appears as an extension aggregate in the tree.
12044 elsif Nkind (State) = N_Extension_Aggregate then
12045 if Nkind (Ancestor_Part (State)) = N_Identifier then
12046 Create_Abstract_State
12047 (Nam => Chars (Ancestor_Part (State)),
12048 Decl => Ancestor_Part (State),
12049 Loc => Sloc (Ancestor_Part (State)),
12051 Non_Null_Seen := True;
12054 ("state name must be an identifier",
12055 Ancestor_Part (State));
12058 -- Options External, Ghost and Synchronous appear as
12061 Opt := First (Expressions (State));
12062 while Present (Opt) loop
12063 if Nkind (Opt) = N_Identifier then
12067 if Chars (Opt) = Name_External then
12068 Check_Duplicate_Option (Opt, External_Seen);
12069 Analyze_External_Option (Opt);
12073 elsif Chars (Opt) = Name_Ghost then
12074 Check_Duplicate_Option (Opt, Ghost_Seen);
12075 Check_Ghost_Synchronous;
12077 if Present (State_Id) then
12078 Set_Is_Ghost_Entity (State_Id);
12083 elsif Chars (Opt) = Name_Synchronous then
12084 Check_Duplicate_Option (Opt, Synchronous_Seen);
12085 Check_Ghost_Synchronous;
12087 -- Relaxed_Initialization
12089 elsif Chars (Opt) = Name_Relaxed_Initialization then
12090 Check_Duplicate_Option
12091 (Opt, Relaxed_Initialization_Seen);
12093 -- Option Part_Of without an encapsulating state is
12094 -- illegal (SPARK RM 7.1.4(8)).
12096 elsif Chars (Opt) = Name_Part_Of then
12098 ("indicator Part_Of must denote abstract state, "
12099 & "single protected type or single task type",
12102 -- Do not emit an error message when a previous state
12103 -- declaration with options was not parenthesized as
12104 -- the option is actually another state declaration.
12106 -- with Abstract_State
12107 -- (State_1 with ..., -- missing parentheses
12108 -- (State_2 with ...),
12109 -- State_3) -- ok state declaration
12111 elsif Missing_Parentheses then
12114 -- Otherwise the option is not allowed. Note that it
12115 -- is not possible to distinguish between an option
12116 -- and a state declaration when a previous state with
12117 -- options not properly parentheses.
12119 -- with Abstract_State
12120 -- (State_1 with ..., -- missing parentheses
12121 -- State_2); -- could be an option
12125 ("simple option not allowed in state declaration",
12129 -- Catch a case where missing parentheses around a state
12130 -- declaration with options cause a subsequent state
12131 -- declaration with options to be treated as an option.
12133 -- with Abstract_State
12134 -- (State_1 with ..., -- missing parentheses
12135 -- (State_2 with ...))
12137 elsif Nkind (Opt) = N_Extension_Aggregate then
12138 Missing_Parentheses := True;
12140 ("state declaration must be parenthesized",
12141 Ancestor_Part (State));
12143 -- Otherwise the option is malformed
12146 SPARK_Msg_N ("malformed option", Opt);
12152 -- Options External and Part_Of appear as component
12155 Opt := First (Component_Associations (State));
12156 while Present (Opt) loop
12157 Opt_Nam := First (Choices (Opt));
12159 if Nkind (Opt_Nam) = N_Identifier then
12160 if Chars (Opt_Nam) = Name_External then
12161 Analyze_External_Option (Opt);
12163 elsif Chars (Opt_Nam) = Name_Part_Of then
12164 Analyze_Part_Of_Option (Opt);
12167 SPARK_Msg_N ("invalid state option", Opt);
12170 SPARK_Msg_N ("invalid state option", Opt);
12176 -- Any other attempt to declare a state is illegal
12179 Malformed_State_Error (State);
12183 -- Guard against a junk state. In such cases no entity is
12184 -- generated and the subsequent checks cannot be applied.
12186 if Present (State_Id) then
12188 -- Verify whether the state does not introduce an illegal
12189 -- hidden state within a package subject to a null abstract
12192 Check_No_Hidden_State (State_Id);
12194 -- Check whether the lack of option Part_Of agrees with the
12195 -- placement of the abstract state with respect to the state
12198 if not Part_Of_Seen then
12199 Check_Missing_Part_Of (State_Id);
12202 -- Associate the state with its related package
12204 if No (Abstract_States (Pack_Id)) then
12205 Set_Abstract_States (Pack_Id, New_Elmt_List);
12208 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12210 end Analyze_Abstract_State;
12212 ---------------------------
12213 -- Malformed_State_Error --
12214 ---------------------------
12216 procedure Malformed_State_Error (State : Node_Id) is
12218 Error_Msg_N ("malformed abstract state declaration", State);
12220 -- An abstract state with a simple option is being declared
12221 -- with "=>" rather than the legal "with". The state appears
12222 -- as a component association.
12224 if Nkind (State) = N_Component_Association then
12225 Error_Msg_N ("\use WITH to specify simple option", State);
12227 end Malformed_State_Error;
12231 Pack_Decl : Node_Id;
12232 Pack_Id : Entity_Id;
12236 -- Start of processing for Abstract_State
12240 Check_No_Identifiers;
12241 Check_Arg_Count (1);
12243 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12245 if Nkind (Pack_Decl) not in
12246 N_Generic_Package_Declaration | N_Package_Declaration
12252 Pack_Id := Defining_Entity (Pack_Decl);
12254 -- A pragma that applies to a Ghost entity becomes Ghost for the
12255 -- purposes of legality checks and removal of ignored Ghost code.
12257 Mark_Ghost_Pragma (N, Pack_Id);
12258 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12260 -- Chain the pragma on the contract for completeness
12262 Add_Contract_Item (N, Pack_Id);
12264 -- The legality checks of pragmas Abstract_State, Initializes, and
12265 -- Initial_Condition are affected by the SPARK mode in effect. In
12266 -- addition, these three pragmas are subject to an inherent order:
12268 -- 1) Abstract_State
12270 -- 3) Initial_Condition
12272 -- Analyze all these pragmas in the order outlined above
12274 Analyze_If_Present (Pragma_SPARK_Mode);
12275 States := Expression (Get_Argument (N, Pack_Id));
12277 -- Multiple non-null abstract states appear as an aggregate
12279 if Nkind (States) = N_Aggregate then
12280 State := First (Expressions (States));
12281 while Present (State) loop
12282 Analyze_Abstract_State (State, Pack_Id);
12286 -- An abstract state with a simple option is being illegaly
12287 -- declared with "=>" rather than "with". In this case the
12288 -- state declaration appears as a component association.
12290 if Present (Component_Associations (States)) then
12291 State := First (Component_Associations (States));
12292 while Present (State) loop
12293 Malformed_State_Error (State);
12298 -- Various forms of a single abstract state. Note that these may
12299 -- include malformed state declarations.
12302 Analyze_Abstract_State (States, Pack_Id);
12305 Analyze_If_Present (Pragma_Initializes);
12306 Analyze_If_Present (Pragma_Initial_Condition);
12307 end Abstract_State;
12315 -- Note: this pragma also has some specific processing in Par.Prag
12316 -- because we want to set the Ada version mode during parsing.
12318 when Pragma_Ada_83 =>
12320 Check_Arg_Count (0);
12322 -- We really should check unconditionally for proper configuration
12323 -- pragma placement, since we really don't want mixed Ada modes
12324 -- within a single unit, and the GNAT reference manual has always
12325 -- said this was a configuration pragma, but we did not check and
12326 -- are hesitant to add the check now.
12328 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12329 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12330 -- or Ada 2012 mode.
12332 if Ada_Version >= Ada_2005 then
12333 Check_Valid_Configuration_Pragma;
12336 -- Now set Ada 83 mode
12338 if Latest_Ada_Only then
12339 Error_Pragma ("??pragma% ignored");
12341 Ada_Version := Ada_83;
12342 Ada_Version_Explicit := Ada_83;
12343 Ada_Version_Pragma := N;
12352 -- Note: this pragma also has some specific processing in Par.Prag
12353 -- because we want to set the Ada 83 version mode during parsing.
12355 when Pragma_Ada_95 =>
12357 Check_Arg_Count (0);
12359 -- We really should check unconditionally for proper configuration
12360 -- pragma placement, since we really don't want mixed Ada modes
12361 -- within a single unit, and the GNAT reference manual has always
12362 -- said this was a configuration pragma, but we did not check and
12363 -- are hesitant to add the check now.
12365 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12366 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12368 if Ada_Version >= Ada_2005 then
12369 Check_Valid_Configuration_Pragma;
12372 -- Now set Ada 95 mode
12374 if Latest_Ada_Only then
12375 Error_Pragma ("??pragma% ignored");
12377 Ada_Version := Ada_95;
12378 Ada_Version_Explicit := Ada_95;
12379 Ada_Version_Pragma := N;
12382 ---------------------
12383 -- Ada_05/Ada_2005 --
12384 ---------------------
12387 -- pragma Ada_05 (LOCAL_NAME);
12389 -- pragma Ada_2005;
12390 -- pragma Ada_2005 (LOCAL_NAME):
12392 -- Note: these pragmas also have some specific processing in Par.Prag
12393 -- because we want to set the Ada 2005 version mode during parsing.
12395 -- The one argument form is used for managing the transition from
12396 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12397 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12398 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12399 -- mode, a preference rule is established which does not choose
12400 -- such an entity unless it is unambiguously specified. This avoids
12401 -- extra subprograms marked this way from generating ambiguities in
12402 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12403 -- intended for exclusive use in the GNAT run-time library.
12414 if Arg_Count = 1 then
12415 Check_Arg_Is_Local_Name (Arg1);
12416 E_Id := Get_Pragma_Arg (Arg1);
12418 if Etype (E_Id) = Any_Type then
12422 Set_Is_Ada_2005_Only (Entity (E_Id));
12423 Record_Rep_Item (Entity (E_Id), N);
12426 Check_Arg_Count (0);
12428 -- For Ada_2005 we unconditionally enforce the documented
12429 -- configuration pragma placement, since we do not want to
12430 -- tolerate mixed modes in a unit involving Ada 2005. That
12431 -- would cause real difficulties for those cases where there
12432 -- are incompatibilities between Ada 95 and Ada 2005.
12434 Check_Valid_Configuration_Pragma;
12436 -- Now set appropriate Ada mode
12438 if Latest_Ada_Only then
12439 Error_Pragma ("??pragma% ignored");
12441 Ada_Version := Ada_2005;
12442 Ada_Version_Explicit := Ada_2005;
12443 Ada_Version_Pragma := N;
12448 ---------------------
12449 -- Ada_12/Ada_2012 --
12450 ---------------------
12453 -- pragma Ada_12 (LOCAL_NAME);
12455 -- pragma Ada_2012;
12456 -- pragma Ada_2012 (LOCAL_NAME):
12458 -- Note: these pragmas also have some specific processing in Par.Prag
12459 -- because we want to set the Ada 2012 version mode during parsing.
12461 -- The one argument form is used for managing the transition from Ada
12462 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12463 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12464 -- mode will generate a warning. In addition, in any pre-Ada_2012
12465 -- mode, a preference rule is established which does not choose
12466 -- such an entity unless it is unambiguously specified. This avoids
12467 -- extra subprograms marked this way from generating ambiguities in
12468 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12469 -- intended for exclusive use in the GNAT run-time library.
12480 if Arg_Count = 1 then
12481 Check_Arg_Is_Local_Name (Arg1);
12482 E_Id := Get_Pragma_Arg (Arg1);
12484 if Etype (E_Id) = Any_Type then
12488 Set_Is_Ada_2012_Only (Entity (E_Id));
12489 Record_Rep_Item (Entity (E_Id), N);
12492 Check_Arg_Count (0);
12494 -- For Ada_2012 we unconditionally enforce the documented
12495 -- configuration pragma placement, since we do not want to
12496 -- tolerate mixed modes in a unit involving Ada 2012. That
12497 -- would cause real difficulties for those cases where there
12498 -- are incompatibilities between Ada 95 and Ada 2012. We could
12499 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12501 Check_Valid_Configuration_Pragma;
12503 -- Now set appropriate Ada mode
12505 Ada_Version := Ada_2012;
12506 Ada_Version_Explicit := Ada_2012;
12507 Ada_Version_Pragma := N;
12515 -- pragma Ada_2020;
12517 -- Note: this pragma also has some specific processing in Par.Prag
12518 -- because we want to set the Ada 2020 version mode during parsing.
12520 when Pragma_Ada_2020 =>
12523 Check_Arg_Count (0);
12525 Check_Valid_Configuration_Pragma;
12527 -- Now set appropriate Ada mode
12529 Ada_Version := Ada_2020;
12530 Ada_Version_Explicit := Ada_2020;
12531 Ada_Version_Pragma := N;
12533 -------------------------------------
12534 -- Aggregate_Individually_Assign --
12535 -------------------------------------
12537 -- pragma Aggregate_Individually_Assign;
12539 when Pragma_Aggregate_Individually_Assign =>
12541 Check_Arg_Count (0);
12542 Check_Valid_Configuration_Pragma;
12543 Aggregate_Individually_Assign := True;
12545 ----------------------
12546 -- All_Calls_Remote --
12547 ----------------------
12549 -- pragma All_Calls_Remote [(library_package_NAME)];
12551 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12552 Lib_Entity : Entity_Id;
12555 Check_Ada_83_Warning;
12556 Check_Valid_Library_Unit_Pragma;
12558 Lib_Entity := Find_Lib_Unit_Name;
12560 -- A pragma that applies to a Ghost entity becomes Ghost for the
12561 -- purposes of legality checks and removal of ignored Ghost code.
12563 Mark_Ghost_Pragma (N, Lib_Entity);
12565 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12567 if Present (Lib_Entity) and then not Debug_Flag_U then
12568 if not Is_Remote_Call_Interface (Lib_Entity) then
12569 Error_Pragma ("pragma% only apply to rci unit");
12571 -- Set flag for entity of the library unit
12574 Set_Has_All_Calls_Remote (Lib_Entity);
12577 end All_Calls_Remote;
12579 ---------------------------
12580 -- Allow_Integer_Address --
12581 ---------------------------
12583 -- pragma Allow_Integer_Address;
12585 when Pragma_Allow_Integer_Address =>
12587 Check_Valid_Configuration_Pragma;
12588 Check_Arg_Count (0);
12590 -- If Address is a private type, then set the flag to allow
12591 -- integer address values. If Address is not private, then this
12592 -- pragma has no purpose, so it is simply ignored. Not clear if
12593 -- there are any such targets now.
12595 if Opt.Address_Is_Private then
12596 Opt.Allow_Integer_Address := True;
12604 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12605 -- ARG ::= NAME | EXPRESSION
12607 -- The first two arguments are by convention intended to refer to an
12608 -- external tool and a tool-specific function. These arguments are
12611 when Pragma_Annotate => Annotate : declare
12616 --------------------------
12617 -- Inferred_String_Type --
12618 --------------------------
12620 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12621 -- Infer the type to use for a string literal or a concatentation
12622 -- of operands whose types can be inferred. For such expressions,
12623 -- returns the "narrowest" of the three predefined string types
12624 -- that can represent the characters occurring in the expression.
12625 -- For other expressions, returns Empty.
12627 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12629 case Nkind (Expr) is
12630 when N_String_Literal =>
12631 if Has_Wide_Wide_Character (Expr) then
12632 return Standard_Wide_Wide_String;
12633 elsif Has_Wide_Character (Expr) then
12634 return Standard_Wide_String;
12636 return Standard_String;
12639 when N_Op_Concat =>
12641 L_Type : constant Entity_Id
12642 := Preferred_String_Type (Left_Opnd (Expr));
12643 R_Type : constant Entity_Id
12644 := Preferred_String_Type (Right_Opnd (Expr));
12646 Type_Table : constant array (1 .. 4) of Entity_Id
12648 Standard_Wide_Wide_String,
12649 Standard_Wide_String,
12652 for Idx in Type_Table'Range loop
12653 if (L_Type = Type_Table (Idx)) or
12654 (R_Type = Type_Table (Idx))
12656 return Type_Table (Idx);
12659 raise Program_Error;
12665 end Preferred_String_Type;
12668 Check_At_Least_N_Arguments (1);
12670 Nam_Arg := Last (Pragma_Argument_Associations (N));
12672 -- Determine whether the last argument is "Entity => local_NAME"
12673 -- and if it is, perform the required semantic checks. Remove the
12674 -- argument from further processing.
12676 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12677 and then Chars (Nam_Arg) = Name_Entity
12679 Check_Arg_Is_Local_Name (Nam_Arg);
12680 Arg_Count := Arg_Count - 1;
12682 -- A pragma that applies to a Ghost entity becomes Ghost for
12683 -- the purposes of legality checks and removal of ignored Ghost
12686 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12687 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12689 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12692 -- Not allowed in compiler units (bootstrap issues)
12694 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12697 -- Continue the processing with last argument removed for now
12699 Check_Arg_Is_Identifier (Arg1);
12700 Check_No_Identifiers;
12703 -- The second parameter is optional, it is never analyzed
12708 -- Otherwise there is a second parameter
12711 -- The second parameter must be an identifier
12713 Check_Arg_Is_Identifier (Arg2);
12715 -- Process the remaining parameters (if any)
12717 Arg := Next (Arg2);
12718 while Present (Arg) loop
12719 Expr := Get_Pragma_Arg (Arg);
12722 if Is_Entity_Name (Expr) then
12725 -- For string literals and concatenations of string literals
12726 -- we assume Standard_String as the type, unless the string
12727 -- contains wide or wide_wide characters.
12729 elsif Present (Preferred_String_Type (Expr)) then
12730 Resolve (Expr, Preferred_String_Type (Expr));
12732 elsif Is_Overloaded (Expr) then
12733 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12744 -------------------------------------------------
12745 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12746 -------------------------------------------------
12749 -- ( [Check => ] Boolean_EXPRESSION
12750 -- [, [Message =>] Static_String_EXPRESSION]);
12752 -- pragma Assert_And_Cut
12753 -- ( [Check => ] Boolean_EXPRESSION
12754 -- [, [Message =>] Static_String_EXPRESSION]);
12757 -- ( [Check => ] Boolean_EXPRESSION
12758 -- [, [Message =>] Static_String_EXPRESSION]);
12760 -- pragma Loop_Invariant
12761 -- ( [Check => ] Boolean_EXPRESSION
12762 -- [, [Message =>] Static_String_EXPRESSION]);
12765 | Pragma_Assert_And_Cut
12767 | Pragma_Loop_Invariant
12770 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12771 -- Determine whether expression Expr contains a Loop_Entry
12772 -- attribute reference.
12774 -------------------------
12775 -- Contains_Loop_Entry --
12776 -------------------------
12778 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12779 Has_Loop_Entry : Boolean := False;
12781 function Process (N : Node_Id) return Traverse_Result;
12782 -- Process function for traversal to look for Loop_Entry
12788 function Process (N : Node_Id) return Traverse_Result is
12790 if Nkind (N) = N_Attribute_Reference
12791 and then Attribute_Name (N) = Name_Loop_Entry
12793 Has_Loop_Entry := True;
12800 procedure Traverse is new Traverse_Proc (Process);
12802 -- Start of processing for Contains_Loop_Entry
12806 return Has_Loop_Entry;
12807 end Contains_Loop_Entry;
12812 New_Args : List_Id;
12814 -- Start of processing for Assert
12817 -- Assert is an Ada 2005 RM-defined pragma
12819 if Prag_Id = Pragma_Assert then
12822 -- The remaining ones are GNAT pragmas
12828 Check_At_Least_N_Arguments (1);
12829 Check_At_Most_N_Arguments (2);
12830 Check_Arg_Order ((Name_Check, Name_Message));
12831 Check_Optional_Identifier (Arg1, Name_Check);
12832 Expr := Get_Pragma_Arg (Arg1);
12834 -- Special processing for Loop_Invariant, Loop_Variant or for
12835 -- other cases where a Loop_Entry attribute is present. If the
12836 -- assertion pragma contains attribute Loop_Entry, ensure that
12837 -- the related pragma is within a loop.
12839 if Prag_Id = Pragma_Loop_Invariant
12840 or else Prag_Id = Pragma_Loop_Variant
12841 or else Contains_Loop_Entry (Expr)
12843 Check_Loop_Pragma_Placement;
12845 -- Perform preanalysis to deal with embedded Loop_Entry
12848 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12851 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12852 -- a corresponding Check pragma:
12854 -- pragma Check (name, condition [, msg]);
12856 -- Where name is the identifier matching the pragma name. So
12857 -- rewrite pragma in this manner, transfer the message argument
12858 -- if present, and analyze the result
12860 -- Note: When dealing with a semantically analyzed tree, the
12861 -- information that a Check node N corresponds to a source Assert,
12862 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12863 -- pragma kind of Original_Node(N).
12865 New_Args := New_List (
12866 Make_Pragma_Argument_Association (Loc,
12867 Expression => Make_Identifier (Loc, Pname)),
12868 Make_Pragma_Argument_Association (Sloc (Expr),
12869 Expression => Expr));
12871 if Arg_Count > 1 then
12872 Check_Optional_Identifier (Arg2, Name_Message);
12874 -- Provide semantic annotations for optional argument, for
12875 -- ASIS use, before rewriting.
12876 -- Is this still needed???
12878 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12879 Append_To (New_Args, New_Copy_Tree (Arg2));
12882 -- Rewrite as Check pragma
12886 Chars => Name_Check,
12887 Pragma_Argument_Associations => New_Args));
12892 ----------------------
12893 -- Assertion_Policy --
12894 ----------------------
12896 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12898 -- The following form is Ada 2012 only, but we allow it in all modes
12900 -- Pragma Assertion_Policy (
12901 -- ASSERTION_KIND => POLICY_IDENTIFIER
12902 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12904 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12906 -- RM_ASSERTION_KIND ::= Assert |
12907 -- Static_Predicate |
12908 -- Dynamic_Predicate |
12913 -- Type_Invariant |
12914 -- Type_Invariant'Class |
12915 -- Default_Initial_Condition
12917 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12919 -- Contract_Cases |
12922 -- Initial_Condition |
12923 -- Loop_Invariant |
12929 -- Statement_Assertions |
12930 -- Subprogram_Variant
12932 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12933 -- ID_ASSERTION_KIND list contains implementation-defined additions
12934 -- recognized by GNAT. The effect is to control the behavior of
12935 -- identically named aspects and pragmas, depending on the specified
12936 -- policy identifier:
12938 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12940 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12941 -- implementation-defined addition that results in totally ignoring
12942 -- the corresponding assertion. If Disable is specified, then the
12943 -- argument of the assertion is not even analyzed. This is useful
12944 -- when the aspect/pragma argument references entities in a with'ed
12945 -- package that is replaced by a dummy package in the final build.
12947 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12948 -- and Type_Invariant'Class were recognized by the parser and
12949 -- transformed into references to the special internal identifiers
12950 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12951 -- processing is required here.
12953 when Pragma_Assertion_Policy => Assertion_Policy : declare
12954 procedure Resolve_Suppressible (Policy : Node_Id);
12955 -- Converts the assertion policy 'Suppressible' to either Check or
12956 -- Ignore based on whether checks are suppressed via -gnatp.
12958 --------------------------
12959 -- Resolve_Suppressible --
12960 --------------------------
12962 procedure Resolve_Suppressible (Policy : Node_Id) is
12963 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12967 -- Transform policy argument Suppressible into either Ignore or
12968 -- Check depending on whether checks are enabled or suppressed.
12970 if Chars (Arg) = Name_Suppressible then
12971 if Suppress_Checks then
12972 Nam := Name_Ignore;
12977 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12979 end Resolve_Suppressible;
12991 -- This can always appear as a configuration pragma
12993 if Is_Configuration_Pragma then
12996 -- It can also appear in a declarative part or package spec in Ada
12997 -- 2012 mode. We allow this in other modes, but in that case we
12998 -- consider that we have an Ada 2012 pragma on our hands.
13001 Check_Is_In_Decl_Part_Or_Package_Spec;
13005 -- One argument case with no identifier (first form above)
13008 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13009 or else Chars (Arg1) = No_Name)
13011 Check_Arg_Is_One_Of (Arg1,
13012 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13014 Resolve_Suppressible (Arg1);
13016 -- Treat one argument Assertion_Policy as equivalent to:
13018 -- pragma Check_Policy (Assertion, policy)
13020 -- So rewrite pragma in that manner and link on to the chain
13021 -- of Check_Policy pragmas, marking the pragma as analyzed.
13023 Policy := Get_Pragma_Arg (Arg1);
13027 Chars => Name_Check_Policy,
13028 Pragma_Argument_Associations => New_List (
13029 Make_Pragma_Argument_Association (Loc,
13030 Expression => Make_Identifier (Loc, Name_Assertion)),
13032 Make_Pragma_Argument_Association (Loc,
13034 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13037 -- Here if we have two or more arguments
13040 Check_At_Least_N_Arguments (1);
13043 -- Loop through arguments
13046 while Present (Arg) loop
13047 LocP := Sloc (Arg);
13049 -- Kind must be specified
13051 if Nkind (Arg) /= N_Pragma_Argument_Association
13052 or else Chars (Arg) = No_Name
13055 ("missing assertion kind for pragma%", Arg);
13058 -- Check Kind and Policy have allowed forms
13060 Kind := Chars (Arg);
13061 Policy := Get_Pragma_Arg (Arg);
13063 if not Is_Valid_Assertion_Kind (Kind) then
13065 ("invalid assertion kind for pragma%", Arg);
13068 Check_Arg_Is_One_Of (Arg,
13069 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13071 Resolve_Suppressible (Arg);
13073 if Kind = Name_Ghost then
13075 -- The Ghost policy must be either Check or Ignore
13076 -- (SPARK RM 6.9(6)).
13078 if Chars (Policy) not in Name_Check | Name_Ignore then
13080 ("argument of pragma % Ghost must be Check or "
13081 & "Ignore", Policy);
13084 -- Pragma Assertion_Policy specifying a Ghost policy
13085 -- cannot occur within a Ghost subprogram or package
13086 -- (SPARK RM 6.9(14)).
13088 if Ghost_Mode > None then
13090 ("pragma % cannot appear within ghost subprogram or "
13095 -- Rewrite the Assertion_Policy pragma as a series of
13096 -- Check_Policy pragmas of the form:
13098 -- Check_Policy (Kind, Policy);
13100 -- Note: the insertion of the pragmas cannot be done with
13101 -- Insert_Action because in the configuration case, there
13102 -- are no scopes on the scope stack and the mechanism will
13105 Insert_Before_And_Analyze (N,
13107 Chars => Name_Check_Policy,
13108 Pragma_Argument_Associations => New_List (
13109 Make_Pragma_Argument_Association (LocP,
13110 Expression => Make_Identifier (LocP, Kind)),
13111 Make_Pragma_Argument_Association (LocP,
13112 Expression => Policy))));
13117 -- Rewrite the Assertion_Policy pragma as null since we have
13118 -- now inserted all the equivalent Check pragmas.
13120 Rewrite (N, Make_Null_Statement (Loc));
13123 end Assertion_Policy;
13125 ------------------------------
13126 -- Assume_No_Invalid_Values --
13127 ------------------------------
13129 -- pragma Assume_No_Invalid_Values (On | Off);
13131 when Pragma_Assume_No_Invalid_Values =>
13133 Check_Valid_Configuration_Pragma;
13134 Check_Arg_Count (1);
13135 Check_No_Identifiers;
13136 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13138 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13139 Assume_No_Invalid_Values := True;
13141 Assume_No_Invalid_Values := False;
13144 --------------------------
13145 -- Attribute_Definition --
13146 --------------------------
13148 -- pragma Attribute_Definition
13149 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13150 -- [Entity =>] LOCAL_NAME,
13151 -- [Expression =>] EXPRESSION | NAME);
13153 when Pragma_Attribute_Definition => Attribute_Definition : declare
13154 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13159 Check_Arg_Count (3);
13160 Check_Optional_Identifier (Arg1, "attribute");
13161 Check_Optional_Identifier (Arg2, "entity");
13162 Check_Optional_Identifier (Arg3, "expression");
13164 if Nkind (Attribute_Designator) /= N_Identifier then
13165 Error_Msg_N ("attribute name expected", Attribute_Designator);
13169 Check_Arg_Is_Local_Name (Arg2);
13171 -- If the attribute is not recognized, then issue a warning (not
13172 -- an error), and ignore the pragma.
13174 Aname := Chars (Attribute_Designator);
13176 if not Is_Attribute_Name (Aname) then
13177 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13181 -- Otherwise, rewrite the pragma as an attribute definition clause
13184 Make_Attribute_Definition_Clause (Loc,
13185 Name => Get_Pragma_Arg (Arg2),
13187 Expression => Get_Pragma_Arg (Arg3)));
13189 end Attribute_Definition;
13191 ------------------------------------------------------------------
13192 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13194 ------------------------------------------------------------------
13196 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13197 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13198 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13199 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13200 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13202 when Pragma_Async_Readers
13203 | Pragma_Async_Writers
13204 | Pragma_Effective_Reads
13205 | Pragma_Effective_Writes
13206 | Pragma_No_Caching
13208 Async_Effective : declare
13209 Obj_Or_Type_Decl : Node_Id;
13210 Obj_Or_Type_Id : Entity_Id;
13213 Check_No_Identifiers;
13214 Check_At_Most_N_Arguments (1);
13216 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
13218 -- Pragma must apply to a object declaration or to a type
13219 -- declaration (only the former in the No_Caching case).
13220 -- Original_Node is necessary to account for untagged derived
13221 -- types that are rewritten as subtypes of their
13222 -- respective root types.
13224 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
13225 if Prag_Id = Pragma_No_Caching
13226 or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
13227 N_Full_Type_Declaration |
13228 N_Private_Type_Declaration |
13229 N_Formal_Type_Declaration |
13230 N_Task_Type_Declaration |
13231 N_Protected_Type_Declaration
13238 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
13240 -- Perform minimal verification to ensure that the argument is at
13241 -- least a variable or a type. Subsequent finer grained checks
13242 -- will be done at the end of the declarative region that
13243 -- contains the pragma.
13245 if Ekind (Obj_Or_Type_Id) = E_Variable
13246 or else Is_Type (Obj_Or_Type_Id)
13249 -- In the case of a type, pragma is a type-related
13250 -- representation item and so requires checks common to
13251 -- all type-related representation items.
13253 if Is_Type (Obj_Or_Type_Id)
13254 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
13259 -- A pragma that applies to a Ghost entity becomes Ghost for
13260 -- the purposes of legality checks and removal of ignored Ghost
13263 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
13265 -- Chain the pragma on the contract for further processing by
13266 -- Analyze_External_Property_In_Decl_Part.
13268 Add_Contract_Item (N, Obj_Or_Type_Id);
13270 -- Analyze the Boolean expression (if any)
13272 if Present (Arg1) then
13273 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13276 -- Otherwise the external property applies to a constant
13280 ("pragma % must apply to a volatile type or object");
13282 end Async_Effective;
13288 -- pragma Asynchronous (LOCAL_NAME);
13290 when Pragma_Asynchronous => Asynchronous : declare
13293 Formal : Entity_Id;
13298 procedure Process_Async_Pragma;
13299 -- Common processing for procedure and access-to-procedure case
13301 --------------------------
13302 -- Process_Async_Pragma --
13303 --------------------------
13305 procedure Process_Async_Pragma is
13308 Set_Is_Asynchronous (Nm);
13312 -- The formals should be of mode IN (RM E.4.1(6))
13315 while Present (S) loop
13316 Formal := Defining_Identifier (S);
13318 if Nkind (Formal) = N_Defining_Identifier
13319 and then Ekind (Formal) /= E_In_Parameter
13322 ("pragma% procedure can only have IN parameter",
13329 Set_Is_Asynchronous (Nm);
13330 end Process_Async_Pragma;
13332 -- Start of processing for pragma Asynchronous
13335 Check_Ada_83_Warning;
13336 Check_No_Identifiers;
13337 Check_Arg_Count (1);
13338 Check_Arg_Is_Local_Name (Arg1);
13340 if Debug_Flag_U then
13344 C_Ent := Cunit_Entity (Current_Sem_Unit);
13345 Analyze (Get_Pragma_Arg (Arg1));
13346 Nm := Entity (Get_Pragma_Arg (Arg1));
13348 -- A pragma that applies to a Ghost entity becomes Ghost for the
13349 -- purposes of legality checks and removal of ignored Ghost code.
13351 Mark_Ghost_Pragma (N, Nm);
13353 if not Is_Remote_Call_Interface (C_Ent)
13354 and then not Is_Remote_Types (C_Ent)
13356 -- This pragma should only appear in an RCI or Remote Types
13357 -- unit (RM E.4.1(4)).
13360 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13363 if Ekind (Nm) = E_Procedure
13364 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13366 if not Is_Remote_Call_Interface (Nm) then
13368 ("pragma% cannot be applied on non-remote procedure",
13372 L := Parameter_Specifications (Parent (Nm));
13373 Process_Async_Pragma;
13376 elsif Ekind (Nm) = E_Function then
13378 ("pragma% cannot be applied to function", Arg1);
13380 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13381 if Is_Record_Type (Nm) then
13383 -- A record type that is the Equivalent_Type for a remote
13384 -- access-to-subprogram type.
13386 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13389 -- A non-expanded RAS type (distribution is not enabled)
13391 Decl := Declaration_Node (Nm);
13394 if Nkind (Decl) = N_Full_Type_Declaration
13395 and then Nkind (Type_Definition (Decl)) =
13396 N_Access_Procedure_Definition
13398 L := Parameter_Specifications (Type_Definition (Decl));
13399 Process_Async_Pragma;
13401 if Is_Asynchronous (Nm)
13402 and then Expander_Active
13403 and then Get_PCS_Name /= Name_No_DSA
13405 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13410 ("pragma% cannot reference access-to-function type",
13414 -- Only other possibility is Access-to-class-wide type
13416 elsif Is_Access_Type (Nm)
13417 and then Is_Class_Wide_Type (Designated_Type (Nm))
13419 Check_First_Subtype (Arg1);
13420 Set_Is_Asynchronous (Nm);
13421 if Expander_Active then
13422 RACW_Type_Is_Asynchronous (Nm);
13426 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13434 -- pragma Atomic (LOCAL_NAME);
13436 when Pragma_Atomic =>
13437 Process_Atomic_Independent_Shared_Volatile;
13439 -----------------------
13440 -- Atomic_Components --
13441 -----------------------
13443 -- pragma Atomic_Components (array_LOCAL_NAME);
13445 -- This processing is shared by Volatile_Components
13447 when Pragma_Atomic_Components
13448 | Pragma_Volatile_Components
13450 Atomic_Components : declare
13456 Check_Ada_83_Warning;
13457 Check_No_Identifiers;
13458 Check_Arg_Count (1);
13459 Check_Arg_Is_Local_Name (Arg1);
13460 E_Id := Get_Pragma_Arg (Arg1);
13462 if Etype (E_Id) = Any_Type then
13466 E := Entity (E_Id);
13468 -- A pragma that applies to a Ghost entity becomes Ghost for the
13469 -- purposes of legality checks and removal of ignored Ghost code.
13471 Mark_Ghost_Pragma (N, E);
13472 Check_Duplicate_Pragma (E);
13474 if Rep_Item_Too_Early (E, N)
13476 Rep_Item_Too_Late (E, N)
13481 D := Declaration_Node (E);
13483 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13485 (Nkind (D) = N_Object_Declaration
13486 and then Ekind (E) in E_Constant | E_Variable
13487 and then Nkind (Object_Definition (D)) =
13488 N_Constrained_Array_Definition)
13490 (Ada_Version >= Ada_2020
13491 and then Nkind (D) = N_Formal_Type_Declaration)
13493 -- The flag is set on the base type, or on the object
13495 if Nkind (D) = N_Full_Type_Declaration then
13496 E := Base_Type (E);
13499 -- Atomic implies both Independent and Volatile
13501 if Prag_Id = Pragma_Atomic_Components then
13502 Set_Has_Atomic_Components (E);
13503 Set_Has_Independent_Components (E);
13506 Set_Has_Volatile_Components (E);
13509 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13511 end Atomic_Components;
13513 --------------------
13514 -- Attach_Handler --
13515 --------------------
13517 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13519 when Pragma_Attach_Handler =>
13520 Check_Ada_83_Warning;
13521 Check_No_Identifiers;
13522 Check_Arg_Count (2);
13524 if No_Run_Time_Mode then
13525 Error_Msg_CRT ("Attach_Handler pragma", N);
13527 Check_Interrupt_Or_Attach_Handler;
13529 -- The expression that designates the attribute may depend on a
13530 -- discriminant, and is therefore a per-object expression, to
13531 -- be expanded in the init proc. If expansion is enabled, then
13532 -- perform semantic checks on a copy only.
13537 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13540 -- In Relaxed_RM_Semantics mode, we allow any static
13541 -- integer value, for compatibility with other compilers.
13543 if Relaxed_RM_Semantics
13544 and then Nkind (Parg2) = N_Integer_Literal
13546 Typ := Standard_Integer;
13548 Typ := RTE (RE_Interrupt_ID);
13551 if Expander_Active then
13552 Temp := New_Copy_Tree (Parg2);
13553 Set_Parent (Temp, N);
13554 Preanalyze_And_Resolve (Temp, Typ);
13557 Resolve (Parg2, Typ);
13561 Process_Interrupt_Or_Attach_Handler;
13564 --------------------
13565 -- C_Pass_By_Copy --
13566 --------------------
13568 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13570 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13576 Check_Valid_Configuration_Pragma;
13577 Check_Arg_Count (1);
13578 Check_Optional_Identifier (Arg1, "max_size");
13580 Arg := Get_Pragma_Arg (Arg1);
13581 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13583 Val := Expr_Value (Arg);
13587 ("maximum size for pragma% must be positive", Arg1);
13589 elsif UI_Is_In_Int_Range (Val) then
13590 Default_C_Record_Mechanism := UI_To_Int (Val);
13592 -- If a giant value is given, Int'Last will do well enough.
13593 -- If sometime someone complains that a record larger than
13594 -- two gigabytes is not copied, we will worry about it then.
13597 Default_C_Record_Mechanism := Mechanism_Type'Last;
13599 end C_Pass_By_Copy;
13605 -- pragma Check ([Name =>] CHECK_KIND,
13606 -- [Check =>] Boolean_EXPRESSION
13607 -- [,[Message =>] String_EXPRESSION]);
13609 -- CHECK_KIND ::= IDENTIFIER |
13612 -- Invariant'Class |
13613 -- Type_Invariant'Class
13615 -- The identifiers Assertions and Statement_Assertions are not
13616 -- allowed, since they have special meaning for Check_Policy.
13618 -- WARNING: The code below manages Ghost regions. Return statements
13619 -- must be replaced by gotos which jump to the end of the code and
13620 -- restore the Ghost mode.
13622 when Pragma_Check => Check : declare
13623 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13624 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13625 -- Save the Ghost-related attributes to restore on exit
13631 pragma Warnings (Off, Str);
13634 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13635 -- the mode now to ensure that any nodes generated during analysis
13636 -- and expansion are marked as Ghost.
13638 Set_Ghost_Mode (N);
13641 Check_At_Least_N_Arguments (2);
13642 Check_At_Most_N_Arguments (3);
13643 Check_Optional_Identifier (Arg1, Name_Name);
13644 Check_Optional_Identifier (Arg2, Name_Check);
13646 if Arg_Count = 3 then
13647 Check_Optional_Identifier (Arg3, Name_Message);
13648 Str := Get_Pragma_Arg (Arg3);
13651 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13652 Check_Arg_Is_Identifier (Arg1);
13653 Cname := Chars (Get_Pragma_Arg (Arg1));
13655 -- Check forbidden name Assertions or Statement_Assertions
13658 when Name_Assertions =>
13660 ("""Assertions"" is not allowed as a check kind for "
13661 & "pragma%", Arg1);
13663 when Name_Statement_Assertions =>
13665 ("""Statement_Assertions"" is not allowed as a check kind "
13666 & "for pragma%", Arg1);
13672 -- Check applicable policy. We skip this if Checked/Ignored status
13673 -- is already set (e.g. in the case of a pragma from an aspect).
13675 if Is_Checked (N) or else Is_Ignored (N) then
13678 -- For a non-source pragma that is a rewriting of another pragma,
13679 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13681 elsif Is_Rewrite_Substitution (N)
13682 and then Nkind (Original_Node (N)) = N_Pragma
13684 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13685 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13687 -- Otherwise query the applicable policy at this point
13690 case Check_Kind (Cname) is
13691 when Name_Ignore =>
13692 Set_Is_Ignored (N, True);
13693 Set_Is_Checked (N, False);
13696 Set_Is_Ignored (N, False);
13697 Set_Is_Checked (N, True);
13699 -- For disable, rewrite pragma as null statement and skip
13700 -- rest of the analysis of the pragma.
13702 when Name_Disable =>
13703 Rewrite (N, Make_Null_Statement (Loc));
13707 -- No other possibilities
13710 raise Program_Error;
13714 -- If check kind was not Disable, then continue pragma analysis
13716 Expr := Get_Pragma_Arg (Arg2);
13718 -- Mark the pragma (or, if rewritten from an aspect, the original
13719 -- aspect) as enabled. Nothing to do for an internally generated
13720 -- check for a dynamic predicate.
13723 and then not Split_PPC (N)
13724 and then Cname /= Name_Dynamic_Predicate
13726 Set_SCO_Pragma_Enabled (Loc);
13729 -- Deal with analyzing the string argument. If checks are not
13730 -- on we don't want any expansion (since such expansion would
13731 -- not get properly deleted) but we do want to analyze (to get
13732 -- proper references). The Preanalyze_And_Resolve routine does
13733 -- just what we want. Ditto if pragma is active, because it will
13734 -- be rewritten as an if-statement whose analysis will complete
13735 -- analysis and expansion of the string message. This makes a
13736 -- difference in the unusual case where the expression for the
13737 -- string may have a side effect, such as raising an exception.
13738 -- This is mandated by RM 11.4.2, which specifies that the string
13739 -- expression is only evaluated if the check fails and
13740 -- Assertion_Error is to be raised.
13742 if Arg_Count = 3 then
13743 Preanalyze_And_Resolve (Str, Standard_String);
13746 -- Now you might think we could just do the same with the Boolean
13747 -- expression if checks are off (and expansion is on) and then
13748 -- rewrite the check as a null statement. This would work but we
13749 -- would lose the useful warnings about an assertion being bound
13750 -- to fail even if assertions are turned off.
13752 -- So instead we wrap the boolean expression in an if statement
13753 -- that looks like:
13755 -- if False and then condition then
13759 -- The reason we do this rewriting during semantic analysis rather
13760 -- than as part of normal expansion is that we cannot analyze and
13761 -- expand the code for the boolean expression directly, or it may
13762 -- cause insertion of actions that would escape the attempt to
13763 -- suppress the check code.
13765 -- Note that the Sloc for the if statement corresponds to the
13766 -- argument condition, not the pragma itself. The reason for
13767 -- this is that we may generate a warning if the condition is
13768 -- False at compile time, and we do not want to delete this
13769 -- warning when we delete the if statement.
13771 if Expander_Active and Is_Ignored (N) then
13772 Eloc := Sloc (Expr);
13775 Make_If_Statement (Eloc,
13777 Make_And_Then (Eloc,
13778 Left_Opnd => Make_Identifier (Eloc, Name_False),
13779 Right_Opnd => Expr),
13780 Then_Statements => New_List (
13781 Make_Null_Statement (Eloc))));
13783 -- Now go ahead and analyze the if statement
13785 In_Assertion_Expr := In_Assertion_Expr + 1;
13787 -- One rather special treatment. If we are now in Eliminated
13788 -- overflow mode, then suppress overflow checking since we do
13789 -- not want to drag in the bignum stuff if we are in Ignore
13790 -- mode anyway. This is particularly important if we are using
13791 -- a configurable run time that does not support bignum ops.
13793 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13795 Svo : constant Boolean :=
13796 Scope_Suppress.Suppress (Overflow_Check);
13798 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13799 Scope_Suppress.Suppress (Overflow_Check) := True;
13801 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13802 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13805 -- Not that special case
13811 -- All done with this check
13813 In_Assertion_Expr := In_Assertion_Expr - 1;
13815 -- Check is active or expansion not active. In these cases we can
13816 -- just go ahead and analyze the boolean with no worries.
13819 In_Assertion_Expr := In_Assertion_Expr + 1;
13820 Analyze_And_Resolve (Expr, Any_Boolean);
13821 In_Assertion_Expr := In_Assertion_Expr - 1;
13824 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13827 --------------------------
13828 -- Check_Float_Overflow --
13829 --------------------------
13831 -- pragma Check_Float_Overflow;
13833 when Pragma_Check_Float_Overflow =>
13835 Check_Valid_Configuration_Pragma;
13836 Check_Arg_Count (0);
13837 Check_Float_Overflow := not Machine_Overflows_On_Target;
13843 -- pragma Check_Name (check_IDENTIFIER);
13845 when Pragma_Check_Name =>
13847 Check_No_Identifiers;
13848 Check_Valid_Configuration_Pragma;
13849 Check_Arg_Count (1);
13850 Check_Arg_Is_Identifier (Arg1);
13853 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13856 for J in Check_Names.First .. Check_Names.Last loop
13857 if Check_Names.Table (J) = Nam then
13862 Check_Names.Append (Nam);
13869 -- This is the old style syntax, which is still allowed in all modes:
13871 -- pragma Check_Policy ([Name =>] CHECK_KIND
13872 -- [Policy =>] POLICY_IDENTIFIER);
13874 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13876 -- CHECK_KIND ::= IDENTIFIER |
13879 -- Type_Invariant'Class |
13882 -- This is the new style syntax, compatible with Assertion_Policy
13883 -- and also allowed in all modes.
13885 -- Pragma Check_Policy (
13886 -- CHECK_KIND => POLICY_IDENTIFIER
13887 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13889 -- Note: the identifiers Name and Policy are not allowed as
13890 -- Check_Kind values. This avoids ambiguities between the old and
13891 -- new form syntax.
13893 when Pragma_Check_Policy => Check_Policy : declare
13898 Check_At_Least_N_Arguments (1);
13900 -- A Check_Policy pragma can appear either as a configuration
13901 -- pragma, or in a declarative part or a package spec (see RM
13902 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13903 -- followed for Check_Policy).
13905 if not Is_Configuration_Pragma then
13906 Check_Is_In_Decl_Part_Or_Package_Spec;
13909 -- Figure out if we have the old or new syntax. We have the
13910 -- old syntax if the first argument has no identifier, or the
13911 -- identifier is Name.
13913 if Nkind (Arg1) /= N_Pragma_Argument_Association
13914 or else Chars (Arg1) in No_Name | Name_Name
13918 Check_Arg_Count (2);
13919 Check_Optional_Identifier (Arg1, Name_Name);
13920 Kind := Get_Pragma_Arg (Arg1);
13921 Rewrite_Assertion_Kind (Kind,
13922 From_Policy => Comes_From_Source (N));
13923 Check_Arg_Is_Identifier (Arg1);
13925 -- Check forbidden check kind
13927 if Chars (Kind) in Name_Name | Name_Policy then
13928 Error_Msg_Name_2 := Chars (Kind);
13930 ("pragma% does not allow% as check name", Arg1);
13935 Check_Optional_Identifier (Arg2, Name_Policy);
13936 Check_Arg_Is_One_Of
13938 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
13940 -- And chain pragma on the Check_Policy_List for search
13942 Set_Next_Pragma (N, Opt.Check_Policy_List);
13943 Opt.Check_Policy_List := N;
13945 -- For the new syntax, what we do is to convert each argument to
13946 -- an old syntax equivalent. We do that because we want to chain
13947 -- old style Check_Policy pragmas for the search (we don't want
13948 -- to have to deal with multiple arguments in the search).
13959 while Present (Arg) loop
13960 LocP := Sloc (Arg);
13961 Argx := Get_Pragma_Arg (Arg);
13963 -- Kind must be specified
13965 if Nkind (Arg) /= N_Pragma_Argument_Association
13966 or else Chars (Arg) = No_Name
13969 ("missing assertion kind for pragma%", Arg);
13972 -- Construct equivalent old form syntax Check_Policy
13973 -- pragma and insert it to get remaining checks.
13977 Chars => Name_Check_Policy,
13978 Pragma_Argument_Associations => New_List (
13979 Make_Pragma_Argument_Association (LocP,
13981 Make_Identifier (LocP, Chars (Arg))),
13982 Make_Pragma_Argument_Association (Sloc (Argx),
13983 Expression => Argx)));
13987 -- For a configuration pragma, insert old form in
13988 -- the corresponding file.
13990 if Is_Configuration_Pragma then
13991 Insert_After (N, New_P);
13995 Insert_Action (N, New_P);
13999 -- Rewrite original Check_Policy pragma to null, since we
14000 -- have converted it into a series of old syntax pragmas.
14002 Rewrite (N, Make_Null_Statement (Loc));
14012 -- pragma Comment (static_string_EXPRESSION)
14014 -- Processing for pragma Comment shares the circuitry for pragma
14015 -- Ident. The only differences are that Ident enforces a limit of 31
14016 -- characters on its argument, and also enforces limitations on
14017 -- placement for DEC compatibility. Pragma Comment shares neither of
14018 -- these restrictions.
14020 -------------------
14021 -- Common_Object --
14022 -------------------
14024 -- pragma Common_Object (
14025 -- [Internal =>] LOCAL_NAME
14026 -- [, [External =>] EXTERNAL_SYMBOL]
14027 -- [, [Size =>] EXTERNAL_SYMBOL]);
14029 -- Processing for this pragma is shared with Psect_Object
14031 ----------------------------------------------
14032 -- Compile_Time_Error, Compile_Time_Warning --
14033 ----------------------------------------------
14035 -- pragma Compile_Time_Error
14036 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14038 -- pragma Compile_Time_Warning
14039 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14041 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14043 Process_Compile_Time_Warning_Or_Error;
14045 ---------------------------
14046 -- Compiler_Unit_Warning --
14047 ---------------------------
14049 -- pragma Compiler_Unit_Warning;
14053 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14054 -- errors not warnings. This means that we had introduced a big extra
14055 -- inertia to compiler changes, since even if we implemented a new
14056 -- feature, and even if all versions to be used for bootstrapping
14057 -- implemented this new feature, we could not use it, since old
14058 -- compilers would give errors for using this feature in units
14059 -- having Compiler_Unit pragmas.
14061 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14062 -- problem. We no longer have any units mentioning Compiler_Unit,
14063 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14064 -- and thus generates a warning which can be ignored. So that deals
14065 -- with the problem of old compilers not implementing the newer form
14068 -- Newer compilers recognize the new pragma, but generate warning
14069 -- messages instead of errors, which again can be ignored in the
14070 -- case of an old compiler which implements a wanted new feature
14071 -- but at the time felt like warning about it for older compilers.
14073 -- We retain Compiler_Unit so that new compilers can be used to build
14074 -- older run-times that use this pragma. That's an unusual case, but
14075 -- it's easy enough to handle, so why not?
14077 when Pragma_Compiler_Unit
14078 | Pragma_Compiler_Unit_Warning
14081 Check_Arg_Count (0);
14083 -- Only recognized in main unit
14085 if Current_Sem_Unit = Main_Unit then
14086 Compiler_Unit := True;
14089 -----------------------------
14090 -- Complete_Representation --
14091 -----------------------------
14093 -- pragma Complete_Representation;
14095 when Pragma_Complete_Representation =>
14097 Check_Arg_Count (0);
14099 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14101 ("pragma & must appear within record representation clause");
14104 ----------------------------
14105 -- Complex_Representation --
14106 ----------------------------
14108 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14110 when Pragma_Complex_Representation => Complex_Representation : declare
14117 Check_Arg_Count (1);
14118 Check_Optional_Identifier (Arg1, Name_Entity);
14119 Check_Arg_Is_Local_Name (Arg1);
14120 E_Id := Get_Pragma_Arg (Arg1);
14122 if Etype (E_Id) = Any_Type then
14126 E := Entity (E_Id);
14128 if not Is_Record_Type (E) then
14130 ("argument for pragma% must be record type", Arg1);
14133 Ent := First_Entity (E);
14136 or else No (Next_Entity (Ent))
14137 or else Present (Next_Entity (Next_Entity (Ent)))
14138 or else not Is_Floating_Point_Type (Etype (Ent))
14139 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14142 ("record for pragma% must have two fields of the same "
14143 & "floating-point type", Arg1);
14146 Set_Has_Complex_Representation (Base_Type (E));
14148 -- We need to treat the type has having a non-standard
14149 -- representation, for back-end purposes, even though in
14150 -- general a complex will have the default representation
14151 -- of a record with two real components.
14153 Set_Has_Non_Standard_Rep (Base_Type (E));
14155 end Complex_Representation;
14157 -------------------------
14158 -- Component_Alignment --
14159 -------------------------
14161 -- pragma Component_Alignment (
14162 -- [Form =>] ALIGNMENT_CHOICE
14163 -- [, [Name =>] type_LOCAL_NAME]);
14165 -- ALIGNMENT_CHOICE ::=
14167 -- | Component_Size_4
14171 when Pragma_Component_Alignment => Component_AlignmentP : declare
14172 Args : Args_List (1 .. 2);
14173 Names : constant Name_List (1 .. 2) := (
14177 Form : Node_Id renames Args (1);
14178 Name : Node_Id renames Args (2);
14180 Atype : Component_Alignment_Kind;
14185 Gather_Associations (Names, Args);
14188 Error_Pragma ("missing Form argument for pragma%");
14191 Check_Arg_Is_Identifier (Form);
14193 -- Get proper alignment, note that Default = Component_Size on all
14194 -- machines we have so far, and we want to set this value rather
14195 -- than the default value to indicate that it has been explicitly
14196 -- set (and thus will not get overridden by the default component
14197 -- alignment for the current scope)
14199 if Chars (Form) = Name_Component_Size then
14200 Atype := Calign_Component_Size;
14202 elsif Chars (Form) = Name_Component_Size_4 then
14203 Atype := Calign_Component_Size_4;
14205 elsif Chars (Form) = Name_Default then
14206 Atype := Calign_Component_Size;
14208 elsif Chars (Form) = Name_Storage_Unit then
14209 Atype := Calign_Storage_Unit;
14213 ("invalid Form parameter for pragma%", Form);
14216 -- The pragma appears in a configuration file
14218 if No (Parent (N)) then
14219 Check_Valid_Configuration_Pragma;
14221 -- Capture the component alignment in a global variable when
14222 -- the pragma appears in a configuration file. Note that the
14223 -- scope stack is empty at this point and cannot be used to
14224 -- store the alignment value.
14226 Configuration_Component_Alignment := Atype;
14228 -- Case with no name, supplied, affects scope table entry
14230 elsif No (Name) then
14232 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14234 -- Case of name supplied
14237 Check_Arg_Is_Local_Name (Name);
14239 Typ := Entity (Name);
14242 or else Rep_Item_Too_Early (Typ, N)
14246 Typ := Underlying_Type (Typ);
14249 if not Is_Record_Type (Typ)
14250 and then not Is_Array_Type (Typ)
14253 ("Name parameter of pragma% must identify record or "
14254 & "array type", Name);
14257 -- An explicit Component_Alignment pragma overrides an
14258 -- implicit pragma Pack, but not an explicit one.
14260 if not Has_Pragma_Pack (Base_Type (Typ)) then
14261 Set_Is_Packed (Base_Type (Typ), False);
14262 Set_Component_Alignment (Base_Type (Typ), Atype);
14265 end Component_AlignmentP;
14267 --------------------------------
14268 -- Constant_After_Elaboration --
14269 --------------------------------
14271 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14273 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14275 Obj_Decl : Node_Id;
14276 Obj_Id : Entity_Id;
14280 Check_No_Identifiers;
14281 Check_At_Most_N_Arguments (1);
14283 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14285 if Nkind (Obj_Decl) /= N_Object_Declaration then
14290 Obj_Id := Defining_Entity (Obj_Decl);
14292 -- The object declaration must be a library-level variable which
14293 -- is either explicitly initialized or obtains a value during the
14294 -- elaboration of a package body (SPARK RM 3.3.1).
14296 if Ekind (Obj_Id) = E_Variable then
14297 if not Is_Library_Level_Entity (Obj_Id) then
14299 ("pragma % must apply to a library level variable");
14303 -- Otherwise the pragma applies to a constant, which is illegal
14306 Error_Pragma ("pragma % must apply to a variable declaration");
14310 -- A pragma that applies to a Ghost entity becomes Ghost for the
14311 -- purposes of legality checks and removal of ignored Ghost code.
14313 Mark_Ghost_Pragma (N, Obj_Id);
14315 -- Chain the pragma on the contract for completeness
14317 Add_Contract_Item (N, Obj_Id);
14319 -- Analyze the Boolean expression (if any)
14321 if Present (Arg1) then
14322 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14324 end Constant_After_Elaboration;
14326 --------------------
14327 -- Contract_Cases --
14328 --------------------
14330 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14332 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14334 -- CASE_GUARD ::= boolean_EXPRESSION | others
14336 -- CONSEQUENCE ::= boolean_EXPRESSION
14338 -- Characteristics:
14340 -- * Analysis - The annotation undergoes initial checks to verify
14341 -- the legal placement and context. Secondary checks preanalyze the
14344 -- Analyze_Contract_Cases_In_Decl_Part
14346 -- * Expansion - The annotation is expanded during the expansion of
14347 -- the related subprogram [body] contract as performed in:
14349 -- Expand_Subprogram_Contract
14351 -- * Template - The annotation utilizes the generic template of the
14352 -- related subprogram [body] when it is:
14354 -- aspect on subprogram declaration
14355 -- aspect on stand-alone subprogram body
14356 -- pragma on stand-alone subprogram body
14358 -- The annotation must prepare its own template when it is:
14360 -- pragma on subprogram declaration
14362 -- * Globals - Capture of global references must occur after full
14365 -- * Instance - The annotation is instantiated automatically when
14366 -- the related generic subprogram [body] is instantiated except for
14367 -- the "pragma on subprogram declaration" case. In that scenario
14368 -- the annotation must instantiate itself.
14370 when Pragma_Contract_Cases => Contract_Cases : declare
14371 Spec_Id : Entity_Id;
14372 Subp_Decl : Node_Id;
14373 Subp_Spec : Node_Id;
14377 Check_No_Identifiers;
14378 Check_Arg_Count (1);
14380 -- Ensure the proper placement of the pragma. Contract_Cases must
14381 -- be associated with a subprogram declaration or a body that acts
14385 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14389 if Nkind (Subp_Decl) = N_Entry_Declaration then
14392 -- Generic subprogram
14394 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14397 -- Body acts as spec
14399 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14400 and then No (Corresponding_Spec (Subp_Decl))
14404 -- Body stub acts as spec
14406 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14407 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14413 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14414 Subp_Spec := Specification (Subp_Decl);
14416 -- Pragma Contract_Cases is forbidden on null procedures, as
14417 -- this may lead to potential ambiguities in behavior when
14418 -- interface null procedures are involved.
14420 if Nkind (Subp_Spec) = N_Procedure_Specification
14421 and then Null_Present (Subp_Spec)
14423 Error_Msg_N (Fix_Error
14424 ("pragma % cannot apply to null procedure"), N);
14433 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14435 -- A pragma that applies to a Ghost entity becomes Ghost for the
14436 -- purposes of legality checks and removal of ignored Ghost code.
14438 Mark_Ghost_Pragma (N, Spec_Id);
14439 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14441 -- Chain the pragma on the contract for further processing by
14442 -- Analyze_Contract_Cases_In_Decl_Part.
14444 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14446 -- Fully analyze the pragma when it appears inside an entry
14447 -- or subprogram body because it cannot benefit from forward
14450 if Nkind (Subp_Decl) in N_Entry_Body
14451 | N_Subprogram_Body
14452 | N_Subprogram_Body_Stub
14454 -- The legality checks of pragma Contract_Cases are affected by
14455 -- the SPARK mode in effect and the volatility of the context.
14456 -- Analyze all pragmas in a specific order.
14458 Analyze_If_Present (Pragma_SPARK_Mode);
14459 Analyze_If_Present (Pragma_Volatile_Function);
14460 Analyze_Contract_Cases_In_Decl_Part (N);
14462 end Contract_Cases;
14468 -- pragma Controlled (first_subtype_LOCAL_NAME);
14470 when Pragma_Controlled => Controlled : declare
14474 Check_No_Identifiers;
14475 Check_Arg_Count (1);
14476 Check_Arg_Is_Local_Name (Arg1);
14477 Arg := Get_Pragma_Arg (Arg1);
14479 if not Is_Entity_Name (Arg)
14480 or else not Is_Access_Type (Entity (Arg))
14482 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14484 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14492 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14493 -- [Entity =>] LOCAL_NAME);
14495 when Pragma_Convention => Convention : declare
14498 pragma Warnings (Off, C);
14499 pragma Warnings (Off, E);
14502 Check_Arg_Order ((Name_Convention, Name_Entity));
14503 Check_Ada_83_Warning;
14504 Check_Arg_Count (2);
14505 Process_Convention (C, E);
14507 -- A pragma that applies to a Ghost entity becomes Ghost for the
14508 -- purposes of legality checks and removal of ignored Ghost code.
14510 Mark_Ghost_Pragma (N, E);
14513 ---------------------------
14514 -- Convention_Identifier --
14515 ---------------------------
14517 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14518 -- [Convention =>] convention_IDENTIFIER);
14520 when Pragma_Convention_Identifier => Convention_Identifier : declare
14526 Check_Arg_Order ((Name_Name, Name_Convention));
14527 Check_Arg_Count (2);
14528 Check_Optional_Identifier (Arg1, Name_Name);
14529 Check_Optional_Identifier (Arg2, Name_Convention);
14530 Check_Arg_Is_Identifier (Arg1);
14531 Check_Arg_Is_Identifier (Arg2);
14532 Idnam := Chars (Get_Pragma_Arg (Arg1));
14533 Cname := Chars (Get_Pragma_Arg (Arg2));
14535 if Is_Convention_Name (Cname) then
14536 Record_Convention_Identifier
14537 (Idnam, Get_Convention_Id (Cname));
14540 ("second arg for % pragma must be convention", Arg2);
14542 end Convention_Identifier;
14548 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14550 when Pragma_CPP_Class =>
14553 if Warn_On_Obsolescent_Feature then
14555 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14556 & "effect; replace it by pragma import?j?", N);
14559 Check_Arg_Count (1);
14563 Chars => Name_Import,
14564 Pragma_Argument_Associations => New_List (
14565 Make_Pragma_Argument_Association (Loc,
14566 Expression => Make_Identifier (Loc, Name_CPP)),
14567 New_Copy (First (Pragma_Argument_Associations (N))))));
14570 ---------------------
14571 -- CPP_Constructor --
14572 ---------------------
14574 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14575 -- [, [External_Name =>] static_string_EXPRESSION ]
14576 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14578 when Pragma_CPP_Constructor => CPP_Constructor : declare
14581 Def_Id : Entity_Id;
14582 Tag_Typ : Entity_Id;
14586 Check_At_Least_N_Arguments (1);
14587 Check_At_Most_N_Arguments (3);
14588 Check_Optional_Identifier (Arg1, Name_Entity);
14589 Check_Arg_Is_Local_Name (Arg1);
14591 Id := Get_Pragma_Arg (Arg1);
14592 Find_Program_Unit_Name (Id);
14594 -- If we did not find the name, we are done
14596 if Etype (Id) = Any_Type then
14600 Def_Id := Entity (Id);
14602 -- Check if already defined as constructor
14604 if Is_Constructor (Def_Id) then
14606 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14610 if Ekind (Def_Id) = E_Function
14611 and then (Is_CPP_Class (Etype (Def_Id))
14612 or else (Is_Class_Wide_Type (Etype (Def_Id))
14614 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14616 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14618 ("'C'P'P constructor must be defined in the scope of "
14619 & "its returned type", Arg1);
14622 if Arg_Count >= 2 then
14623 Set_Imported (Def_Id);
14624 Set_Is_Public (Def_Id);
14625 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14628 Set_Has_Completion (Def_Id);
14629 Set_Is_Constructor (Def_Id);
14630 Set_Convention (Def_Id, Convention_CPP);
14632 -- Imported C++ constructors are not dispatching primitives
14633 -- because in C++ they don't have a dispatch table slot.
14634 -- However, in Ada the constructor has the profile of a
14635 -- function that returns a tagged type and therefore it has
14636 -- been treated as a primitive operation during semantic
14637 -- analysis. We now remove it from the list of primitive
14638 -- operations of the type.
14640 if Is_Tagged_Type (Etype (Def_Id))
14641 and then not Is_Class_Wide_Type (Etype (Def_Id))
14642 and then Is_Dispatching_Operation (Def_Id)
14644 Tag_Typ := Etype (Def_Id);
14646 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14647 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14651 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14652 Set_Is_Dispatching_Operation (Def_Id, False);
14655 -- For backward compatibility, if the constructor returns a
14656 -- class wide type, and we internally change the return type to
14657 -- the corresponding root type.
14659 if Is_Class_Wide_Type (Etype (Def_Id)) then
14660 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14664 ("pragma% requires function returning a 'C'P'P_Class type",
14667 end CPP_Constructor;
14673 when Pragma_CPP_Virtual =>
14676 if Warn_On_Obsolescent_Feature then
14678 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14682 --------------------
14684 --------------------
14686 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14690 -- [, EXPRESSION]]);
14692 when Pragma_CUDA_Execute => CUDA_Execute : declare
14694 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
14695 -- Returns True if N is an acceptable argument for CUDA_Execute,
14696 -- False otherwise.
14698 ------------------------
14699 -- Is_Acceptable_Dim3 --
14700 ------------------------
14702 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
14705 if Is_RTE (Etype (N), RE_Dim3)
14706 or else Is_Integer_Type (Etype (N))
14711 if Nkind (N) = N_Aggregate
14712 and then List_Length (Expressions (N)) = 3
14714 Expr := First (Expressions (N));
14715 while Present (Expr) loop
14716 Analyze_And_Resolve (Expr, Any_Integer);
14723 end Is_Acceptable_Dim3;
14727 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
14728 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
14729 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
14730 Shared_Memory : Node_Id;
14733 -- Start of processing for CUDA_Execute
14737 Check_At_Least_N_Arguments (3);
14738 Check_At_Most_N_Arguments (5);
14740 Analyze_And_Resolve (Kernel_Call);
14741 if Nkind (Kernel_Call) /= N_Function_Call
14742 or else Etype (Kernel_Call) /= Standard_Void_Type
14744 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
14745 -- GNAT sees Kernel_Call as an N_Function_Call since
14746 -- Kernel_Call "looks" like an expression. However, only
14747 -- procedures can be kernels, so to make things easier for the
14748 -- user the error message complains about Kernel_Call not being
14749 -- a procedure call.
14751 Error_Msg_N ("first argument of & must be a procedure call", N);
14754 Analyze (Grid_Dimensions);
14755 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
14757 ("second argument of & must be an Integer, Dim3 or aggregate "
14758 & "containing 3 Integers", N);
14761 Analyze (Block_Dimensions);
14762 if not Is_Acceptable_Dim3 (Block_Dimensions) then
14764 ("third argument of & must be an Integer, Dim3 or aggregate "
14765 & "containing 3 Integers", N);
14768 if Present (Arg4) then
14769 Shared_Memory := Get_Pragma_Arg (Arg4);
14770 Analyze_And_Resolve (Shared_Memory, Any_Integer);
14772 if Present (Arg5) then
14773 Stream := Get_Pragma_Arg (Arg5);
14774 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
14783 -- pragma CUDA_Global (IDENTIFIER);
14785 when Pragma_CUDA_Global => CUDA_Global : declare
14786 Arg_Node : Node_Id;
14787 Kernel_Proc : Entity_Id;
14788 Pack_Id : Entity_Id;
14791 Check_At_Least_N_Arguments (1);
14792 Check_At_Most_N_Arguments (1);
14793 Check_Optional_Identifier (Arg1, Name_Entity);
14794 Check_Arg_Is_Local_Name (Arg1);
14796 Arg_Node := Get_Pragma_Arg (Arg1);
14797 Analyze (Arg_Node);
14799 Kernel_Proc := Entity (Arg_Node);
14800 Pack_Id := Scope (Kernel_Proc);
14802 if Ekind (Kernel_Proc) /= E_Procedure then
14803 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
14805 elsif Ekind (Pack_Id) /= E_Package
14806 or else not Is_Library_Level_Entity (Pack_Id)
14809 ("& must reside in a library-level package", N, Kernel_Proc);
14812 Set_Is_CUDA_Kernel (Kernel_Proc);
14813 Add_CUDA_Kernel (Pack_Id, Kernel_Proc);
14821 when Pragma_CPP_Vtable =>
14824 if Warn_On_Obsolescent_Feature then
14826 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14834 -- pragma CPU (EXPRESSION);
14836 when Pragma_CPU => CPU : declare
14837 P : constant Node_Id := Parent (N);
14843 Check_No_Identifiers;
14844 Check_Arg_Count (1);
14845 Arg := Get_Pragma_Arg (Arg1);
14849 if Nkind (P) = N_Subprogram_Body then
14850 Check_In_Main_Program;
14852 Analyze_And_Resolve (Arg, Any_Integer);
14854 Ent := Defining_Unit_Name (Specification (P));
14856 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14857 Ent := Defining_Identifier (Ent);
14862 if not Is_OK_Static_Expression (Arg) then
14863 Flag_Non_Static_Expr
14864 ("main subprogram affinity is not static!", Arg);
14867 -- If constraint error, then we already signalled an error
14869 elsif Raises_Constraint_Error (Arg) then
14872 -- Otherwise check in range
14876 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14877 -- This is the entity System.Multiprocessors.CPU_Range;
14879 Val : constant Uint := Expr_Value (Arg);
14882 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14884 Val > Expr_Value (Type_High_Bound (CPU_Id))
14887 ("main subprogram CPU is out of range", Arg1);
14893 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14897 elsif Nkind (P) = N_Task_Definition then
14898 Ent := Defining_Identifier (Parent (P));
14900 -- The expression must be analyzed in the special manner
14901 -- described in "Handling of Default and Per-Object
14902 -- Expressions" in sem.ads.
14904 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14906 -- See comment in Sem_Ch13 about the following restrictions
14908 if Is_OK_Static_Expression (Arg) then
14909 if Expr_Value (Arg) = Uint_0 then
14910 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
14913 Check_Restriction (No_Dynamic_CPU_Assignment, N);
14916 -- Anything else is incorrect
14922 -- Check duplicate pragma before we chain the pragma in the Rep
14923 -- Item chain of Ent.
14925 Check_Duplicate_Pragma (Ent);
14926 Record_Rep_Item (Ent, N);
14929 --------------------
14930 -- Deadline_Floor --
14931 --------------------
14933 -- pragma Deadline_Floor (time_span_EXPRESSION);
14935 when Pragma_Deadline_Floor => Deadline_Floor : declare
14936 P : constant Node_Id := Parent (N);
14942 Check_No_Identifiers;
14943 Check_Arg_Count (1);
14945 Arg := Get_Pragma_Arg (Arg1);
14947 -- The expression must be analyzed in the special manner described
14948 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14950 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
14952 -- Only protected types allowed
14954 if Nkind (P) /= N_Protected_Definition then
14958 Ent := Defining_Identifier (Parent (P));
14960 -- Check duplicate pragma before we chain the pragma in the Rep
14961 -- Item chain of Ent.
14963 Check_Duplicate_Pragma (Ent);
14964 Record_Rep_Item (Ent, N);
14966 end Deadline_Floor;
14972 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14974 when Pragma_Debug => Debug : declare
14981 -- The condition for executing the call is that the expander
14982 -- is active and that we are not ignoring this debug pragma.
14987 (Expander_Active and then not Is_Ignored (N)),
14990 if not Is_Ignored (N) then
14991 Set_SCO_Pragma_Enabled (Loc);
14994 if Arg_Count = 2 then
14996 Make_And_Then (Loc,
14997 Left_Opnd => Relocate_Node (Cond),
14998 Right_Opnd => Get_Pragma_Arg (Arg1));
14999 Call := Get_Pragma_Arg (Arg2);
15001 Call := Get_Pragma_Arg (Arg1);
15004 if Nkind (Call) in N_Expanded_Name
15007 | N_Indexed_Component
15008 | N_Selected_Component
15010 -- If this pragma Debug comes from source, its argument was
15011 -- parsed as a name form (which is syntactically identical).
15012 -- In a generic context a parameterless call will be left as
15013 -- an expanded name (if global) or selected_component if local.
15014 -- Change it to a procedure call statement now.
15016 Change_Name_To_Procedure_Call_Statement (Call);
15018 elsif Nkind (Call) = N_Procedure_Call_Statement then
15020 -- Already in the form of a procedure call statement: nothing
15021 -- to do (could happen in case of an internally generated
15027 -- All other cases: diagnose error
15030 ("argument of pragma ""Debug"" is not procedure call",
15035 -- Rewrite into a conditional with an appropriate condition. We
15036 -- wrap the procedure call in a block so that overhead from e.g.
15037 -- use of the secondary stack does not generate execution overhead
15038 -- for suppressed conditions.
15040 -- Normally the analysis that follows will freeze the subprogram
15041 -- being called. However, if the call is to a null procedure,
15042 -- we want to freeze it before creating the block, because the
15043 -- analysis that follows may be done with expansion disabled, in
15044 -- which case the body will not be generated, leading to spurious
15047 if Nkind (Call) = N_Procedure_Call_Statement
15048 and then Is_Entity_Name (Name (Call))
15050 Analyze (Name (Call));
15051 Freeze_Before (N, Entity (Name (Call)));
15055 Make_Implicit_If_Statement (N,
15057 Then_Statements => New_List (
15058 Make_Block_Statement (Loc,
15059 Handled_Statement_Sequence =>
15060 Make_Handled_Sequence_Of_Statements (Loc,
15061 Statements => New_List (Relocate_Node (Call)))))));
15064 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15065 -- after analysis of the normally rewritten node, to capture all
15066 -- references to entities, which avoids issuing wrong warnings
15067 -- about unused entities.
15069 if GNATprove_Mode then
15070 Rewrite (N, Make_Null_Statement (Loc));
15078 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15080 when Pragma_Debug_Policy =>
15082 Check_Arg_Count (1);
15083 Check_No_Identifiers;
15084 Check_Arg_Is_Identifier (Arg1);
15086 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15087 -- rewrite it that way, and let the rest of the checking come
15088 -- from analyzing the rewritten pragma.
15092 Chars => Name_Check_Policy,
15093 Pragma_Argument_Associations => New_List (
15094 Make_Pragma_Argument_Association (Loc,
15095 Expression => Make_Identifier (Loc, Name_Debug)),
15097 Make_Pragma_Argument_Association (Loc,
15098 Expression => Get_Pragma_Arg (Arg1)))));
15101 -------------------------------
15102 -- Default_Initial_Condition --
15103 -------------------------------
15105 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15107 when Pragma_Default_Initial_Condition => DIC : declare
15114 Check_No_Identifiers;
15115 Check_At_Most_N_Arguments (2); -- Accounts for implicit type arg
15119 while Present (Stmt) loop
15121 -- Skip prior pragmas, but check for duplicates
15123 if Nkind (Stmt) = N_Pragma then
15124 if Pragma_Name (Stmt) = Pname then
15131 -- Skip internally generated code. Note that derived type
15132 -- declarations of untagged types with discriminants are
15133 -- rewritten as private type declarations.
15135 elsif not Comes_From_Source (Stmt)
15136 and then Nkind (Stmt) /= N_Private_Type_Declaration
15140 -- The associated private type [extension] has been found, stop
15143 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15144 | N_Private_Type_Declaration
15146 Typ := Defining_Entity (Stmt);
15149 -- The pragma does not apply to a legal construct, issue an
15150 -- error and stop the analysis.
15157 Stmt := Prev (Stmt);
15160 -- The pragma does not apply to a legal construct, issue an error
15161 -- and stop the analysis.
15168 -- A pragma that applies to a Ghost entity becomes Ghost for the
15169 -- purposes of legality checks and removal of ignored Ghost code.
15171 Mark_Ghost_Pragma (N, Typ);
15173 -- The pragma signals that the type defines its own DIC assertion
15176 Set_Has_Own_DIC (Typ);
15178 -- A type entity argument is appended to facilitate inheriting the
15179 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15180 -- though that extra argument isn't documented for the pragma.
15182 if not Present (Arg2) then
15183 -- When the pragma has no arguments, create an argument with
15184 -- the value Empty, so the type name argument can be appended
15185 -- following it (since it's expected as the second argument).
15187 if not Present (Arg1) then
15188 Set_Pragma_Argument_Associations (N, New_List (
15189 Make_Pragma_Argument_Association (Sloc (Typ),
15190 Expression => Empty)));
15194 (Pragma_Argument_Associations (N),
15195 Make_Pragma_Argument_Association (Sloc (Typ),
15196 Expression => New_Occurrence_Of (Typ, Sloc (Typ))));
15199 -- Chain the pragma on the rep item chain for further processing
15201 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15203 -- Create the declaration of the procedure which verifies the
15204 -- assertion expression of pragma DIC at runtime.
15206 Build_DIC_Procedure_Declaration (Typ);
15209 ----------------------------------
15210 -- Default_Scalar_Storage_Order --
15211 ----------------------------------
15213 -- pragma Default_Scalar_Storage_Order
15214 -- (High_Order_First | Low_Order_First);
15216 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15217 Default : Character;
15221 Check_Arg_Count (1);
15223 -- Default_Scalar_Storage_Order can appear as a configuration
15224 -- pragma, or in a declarative part of a package spec.
15226 if not Is_Configuration_Pragma then
15227 Check_Is_In_Decl_Part_Or_Package_Spec;
15230 Check_No_Identifiers;
15231 Check_Arg_Is_One_Of
15232 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15233 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15234 Default := Fold_Upper (Name_Buffer (1));
15236 if not Support_Nondefault_SSO_On_Target
15237 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15239 if Warn_On_Unrecognized_Pragma then
15241 ("non-default Scalar_Storage_Order not supported "
15242 & "on target?g?", N);
15244 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15247 -- Here set the specified default
15250 Opt.Default_SSO := Default;
15254 --------------------------
15255 -- Default_Storage_Pool --
15256 --------------------------
15258 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15260 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15265 Check_Arg_Count (1);
15267 -- Default_Storage_Pool can appear as a configuration pragma, or
15268 -- in a declarative part of a package spec.
15270 if not Is_Configuration_Pragma then
15271 Check_Is_In_Decl_Part_Or_Package_Spec;
15274 if From_Aspect_Specification (N) then
15276 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15278 if not In_Open_Scopes (E) then
15280 ("aspect must apply to package or subprogram", N);
15285 if Present (Arg1) then
15286 Pool := Get_Pragma_Arg (Arg1);
15288 -- Case of Default_Storage_Pool (null);
15290 if Nkind (Pool) = N_Null then
15293 -- This is an odd case, this is not really an expression,
15294 -- so we don't have a type for it. So just set the type to
15297 Set_Etype (Pool, Empty);
15299 -- Case of Default_Storage_Pool (Standard);
15301 elsif Nkind (Pool) = N_Identifier
15302 and then Chars (Pool) = Name_Standard
15306 if Entity (Pool) /= Standard_Standard then
15308 ("package Standard is not directly visible", Arg1);
15311 -- Case of Default_Storage_Pool (storage_pool_NAME);
15314 -- If it's a configuration pragma, then the only allowed
15315 -- argument is "null".
15317 if Is_Configuration_Pragma then
15318 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
15321 -- The expected type for a non-"null" argument is
15322 -- Root_Storage_Pool'Class, and the pool must be a variable.
15324 Analyze_And_Resolve
15325 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15327 if Is_Variable (Pool) then
15329 -- A pragma that applies to a Ghost entity becomes Ghost
15330 -- for the purposes of legality checks and removal of
15331 -- ignored Ghost code.
15333 Mark_Ghost_Pragma (N, Entity (Pool));
15337 ("default storage pool must be a variable", Arg1);
15341 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15342 -- access type will use this information to set the appropriate
15343 -- attributes of the access type. If the pragma appears in a
15344 -- generic unit it is ignored, given that it may refer to a
15347 if not Inside_A_Generic then
15348 Default_Pool := Pool;
15351 end Default_Storage_Pool;
15357 -- pragma Depends (DEPENDENCY_RELATION);
15359 -- DEPENDENCY_RELATION ::=
15361 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15363 -- DEPENDENCY_CLAUSE ::=
15364 -- OUTPUT_LIST =>[+] INPUT_LIST
15365 -- | NULL_DEPENDENCY_CLAUSE
15367 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15369 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15371 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15373 -- OUTPUT ::= NAME | FUNCTION_RESULT
15376 -- where FUNCTION_RESULT is a function Result attribute_reference
15378 -- Characteristics:
15380 -- * Analysis - The annotation undergoes initial checks to verify
15381 -- the legal placement and context. Secondary checks fully analyze
15382 -- the dependency clauses in:
15384 -- Analyze_Depends_In_Decl_Part
15386 -- * Expansion - None.
15388 -- * Template - The annotation utilizes the generic template of the
15389 -- related subprogram [body] when it is:
15391 -- aspect on subprogram declaration
15392 -- aspect on stand-alone subprogram body
15393 -- pragma on stand-alone subprogram body
15395 -- The annotation must prepare its own template when it is:
15397 -- pragma on subprogram declaration
15399 -- * Globals - Capture of global references must occur after full
15402 -- * Instance - The annotation is instantiated automatically when
15403 -- the related generic subprogram [body] is instantiated except for
15404 -- the "pragma on subprogram declaration" case. In that scenario
15405 -- the annotation must instantiate itself.
15407 when Pragma_Depends => Depends : declare
15409 Spec_Id : Entity_Id;
15410 Subp_Decl : Node_Id;
15413 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15417 -- Chain the pragma on the contract for further processing by
15418 -- Analyze_Depends_In_Decl_Part.
15420 Add_Contract_Item (N, Spec_Id);
15422 -- Fully analyze the pragma when it appears inside an entry
15423 -- or subprogram body because it cannot benefit from forward
15426 if Nkind (Subp_Decl) in N_Entry_Body
15427 | N_Subprogram_Body
15428 | N_Subprogram_Body_Stub
15430 -- The legality checks of pragmas Depends and Global are
15431 -- affected by the SPARK mode in effect and the volatility
15432 -- of the context. In addition these two pragmas are subject
15433 -- to an inherent order:
15438 -- Analyze all these pragmas in the order outlined above
15440 Analyze_If_Present (Pragma_SPARK_Mode);
15441 Analyze_If_Present (Pragma_Volatile_Function);
15442 Analyze_If_Present (Pragma_Global);
15443 Analyze_Depends_In_Decl_Part (N);
15448 ---------------------
15449 -- Detect_Blocking --
15450 ---------------------
15452 -- pragma Detect_Blocking;
15454 when Pragma_Detect_Blocking =>
15456 Check_Arg_Count (0);
15457 Check_Valid_Configuration_Pragma;
15458 Detect_Blocking := True;
15460 ------------------------------------
15461 -- Disable_Atomic_Synchronization --
15462 ------------------------------------
15464 -- pragma Disable_Atomic_Synchronization [(Entity)];
15466 when Pragma_Disable_Atomic_Synchronization =>
15468 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15470 -------------------
15471 -- Discard_Names --
15472 -------------------
15474 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15476 when Pragma_Discard_Names => Discard_Names : declare
15481 Check_Ada_83_Warning;
15483 -- Deal with configuration pragma case
15485 if Arg_Count = 0 and then Is_Configuration_Pragma then
15486 Global_Discard_Names := True;
15489 -- Otherwise, check correct appropriate context
15492 Check_Is_In_Decl_Part_Or_Package_Spec;
15494 if Arg_Count = 0 then
15496 -- If there is no parameter, then from now on this pragma
15497 -- applies to any enumeration, exception or tagged type
15498 -- defined in the current declarative part, and recursively
15499 -- to any nested scope.
15501 Set_Discard_Names (Current_Scope);
15505 Check_Arg_Count (1);
15506 Check_Optional_Identifier (Arg1, Name_On);
15507 Check_Arg_Is_Local_Name (Arg1);
15509 E_Id := Get_Pragma_Arg (Arg1);
15511 if Etype (E_Id) = Any_Type then
15515 E := Entity (E_Id);
15517 -- A pragma that applies to a Ghost entity becomes Ghost for
15518 -- the purposes of legality checks and removal of ignored
15521 Mark_Ghost_Pragma (N, E);
15523 if (Is_First_Subtype (E)
15525 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15526 or else Ekind (E) = E_Exception
15528 Set_Discard_Names (E);
15529 Record_Rep_Item (E, N);
15533 ("inappropriate entity for pragma%", Arg1);
15539 ------------------------
15540 -- Dispatching_Domain --
15541 ------------------------
15543 -- pragma Dispatching_Domain (EXPRESSION);
15545 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15546 P : constant Node_Id := Parent (N);
15552 Check_No_Identifiers;
15553 Check_Arg_Count (1);
15555 -- This pragma is born obsolete, but not the aspect
15557 if not From_Aspect_Specification (N) then
15559 (No_Obsolescent_Features, Pragma_Identifier (N));
15562 if Nkind (P) = N_Task_Definition then
15563 Arg := Get_Pragma_Arg (Arg1);
15564 Ent := Defining_Identifier (Parent (P));
15566 -- A pragma that applies to a Ghost entity becomes Ghost for
15567 -- the purposes of legality checks and removal of ignored Ghost
15570 Mark_Ghost_Pragma (N, Ent);
15572 -- The expression must be analyzed in the special manner
15573 -- described in "Handling of Default and Per-Object
15574 -- Expressions" in sem.ads.
15576 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15578 -- Check duplicate pragma before we chain the pragma in the Rep
15579 -- Item chain of Ent.
15581 Check_Duplicate_Pragma (Ent);
15582 Record_Rep_Item (Ent, N);
15584 -- Anything else is incorrect
15589 end Dispatching_Domain;
15595 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15597 when Pragma_Elaborate => Elaborate : declare
15602 -- Pragma must be in context items list of a compilation unit
15604 if not Is_In_Context_Clause then
15608 -- Must be at least one argument
15610 if Arg_Count = 0 then
15611 Error_Pragma ("pragma% requires at least one argument");
15614 -- In Ada 83 mode, there can be no items following it in the
15615 -- context list except other pragmas and implicit with clauses
15616 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15617 -- placement rule does not apply.
15619 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15621 while Present (Citem) loop
15622 if Nkind (Citem) = N_Pragma
15623 or else (Nkind (Citem) = N_With_Clause
15624 and then Implicit_With (Citem))
15629 ("(Ada 83) pragma% must be at end of context clause");
15636 -- Finally, the arguments must all be units mentioned in a with
15637 -- clause in the same context clause. Note we already checked (in
15638 -- Par.Prag) that the arguments are all identifiers or selected
15642 Outer : while Present (Arg) loop
15643 Citem := First (List_Containing (N));
15644 Inner : while Citem /= N loop
15645 if Nkind (Citem) = N_With_Clause
15646 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15648 Set_Elaborate_Present (Citem, True);
15649 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15651 -- With the pragma present, elaboration calls on
15652 -- subprograms from the named unit need no further
15653 -- checks, as long as the pragma appears in the current
15654 -- compilation unit. If the pragma appears in some unit
15655 -- in the context, there might still be a need for an
15656 -- Elaborate_All_Desirable from the current compilation
15657 -- to the named unit, so we keep the check enabled. This
15658 -- does not apply in SPARK mode, where we allow pragma
15659 -- Elaborate, but we don't trust it to be right so we
15660 -- will still insist on the Elaborate_All.
15662 if Legacy_Elaboration_Checks
15663 and then In_Extended_Main_Source_Unit (N)
15664 and then SPARK_Mode /= On
15666 Set_Suppress_Elaboration_Warnings
15667 (Entity (Name (Citem)));
15678 ("argument of pragma% is not withed unit", Arg);
15685 -------------------
15686 -- Elaborate_All --
15687 -------------------
15689 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15691 when Pragma_Elaborate_All => Elaborate_All : declare
15696 Check_Ada_83_Warning;
15698 -- Pragma must be in context items list of a compilation unit
15700 if not Is_In_Context_Clause then
15704 -- Must be at least one argument
15706 if Arg_Count = 0 then
15707 Error_Pragma ("pragma% requires at least one argument");
15710 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15711 -- have to appear at the end of the context clause, but may
15712 -- appear mixed in with other items, even in Ada 83 mode.
15714 -- Final check: the arguments must all be units mentioned in
15715 -- a with clause in the same context clause. Note that we
15716 -- already checked (in Par.Prag) that all the arguments are
15717 -- either identifiers or selected components.
15720 Outr : while Present (Arg) loop
15721 Citem := First (List_Containing (N));
15722 Innr : while Citem /= N loop
15723 if Nkind (Citem) = N_With_Clause
15724 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15726 Set_Elaborate_All_Present (Citem, True);
15727 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15729 -- Suppress warnings and elaboration checks on the named
15730 -- unit if the pragma is in the current compilation, as
15731 -- for pragma Elaborate.
15733 if Legacy_Elaboration_Checks
15734 and then In_Extended_Main_Source_Unit (N)
15736 Set_Suppress_Elaboration_Warnings
15737 (Entity (Name (Citem)));
15747 Set_Error_Posted (N);
15749 ("argument of pragma% is not withed unit", Arg);
15756 --------------------
15757 -- Elaborate_Body --
15758 --------------------
15760 -- pragma Elaborate_Body [( library_unit_NAME )];
15762 when Pragma_Elaborate_Body => Elaborate_Body : declare
15763 Cunit_Node : Node_Id;
15764 Cunit_Ent : Entity_Id;
15767 Check_Ada_83_Warning;
15768 Check_Valid_Library_Unit_Pragma;
15770 Cunit_Node := Cunit (Current_Sem_Unit);
15771 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15773 -- A pragma that applies to a Ghost entity becomes Ghost for the
15774 -- purposes of legality checks and removal of ignored Ghost code.
15776 Mark_Ghost_Pragma (N, Cunit_Ent);
15778 if Nkind (Unit (Cunit_Node)) in
15779 N_Package_Body | N_Subprogram_Body
15781 Error_Pragma ("pragma% must refer to a spec, not a body");
15783 Set_Body_Required (Cunit_Node);
15784 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15786 -- If we are in dynamic elaboration mode, then we suppress
15787 -- elaboration warnings for the unit, since it is definitely
15788 -- fine NOT to do dynamic checks at the first level (and such
15789 -- checks will be suppressed because no elaboration boolean
15790 -- is created for Elaborate_Body packages).
15792 -- But in the static model of elaboration, Elaborate_Body is
15793 -- definitely NOT good enough to ensure elaboration safety on
15794 -- its own, since the body may WITH other units that are not
15795 -- safe from an elaboration point of view, so a client must
15796 -- still do an Elaborate_All on such units.
15798 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15799 -- Elaborate_Body always suppressed elab warnings.
15801 if Legacy_Elaboration_Checks
15802 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15804 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15807 end Elaborate_Body;
15809 ------------------------
15810 -- Elaboration_Checks --
15811 ------------------------
15813 -- pragma Elaboration_Checks (Static | Dynamic);
15815 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15816 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15817 -- Emit an error if the current context list already contains
15818 -- a previous Elaboration_Checks pragma. This routine raises
15819 -- Pragma_Exit if a duplicate is found.
15821 procedure Ignore_Elaboration_Checks_Pragma;
15822 -- Warn that the effects of the pragma are ignored. This routine
15823 -- raises Pragma_Exit.
15825 -----------------------------------------------
15826 -- Check_Duplicate_Elaboration_Checks_Pragma --
15827 -----------------------------------------------
15829 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15834 while Present (Item) loop
15835 if Nkind (Item) = N_Pragma
15836 and then Pragma_Name (Item) = Name_Elaboration_Checks
15846 end Check_Duplicate_Elaboration_Checks_Pragma;
15848 --------------------------------------
15849 -- Ignore_Elaboration_Checks_Pragma --
15850 --------------------------------------
15852 procedure Ignore_Elaboration_Checks_Pragma is
15854 Error_Msg_Name_1 := Pname;
15855 Error_Msg_N ("??effects of pragma % are ignored", N);
15857 ("\place pragma on initial declaration of library unit", N);
15860 end Ignore_Elaboration_Checks_Pragma;
15864 Context : constant Node_Id := Parent (N);
15867 -- Start of processing for Elaboration_Checks
15871 Check_Arg_Count (1);
15872 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15874 -- The pragma appears in a configuration file
15876 if No (Context) then
15877 Check_Valid_Configuration_Pragma;
15878 Check_Duplicate_Elaboration_Checks_Pragma;
15880 -- The pragma acts as a configuration pragma in a compilation unit
15882 -- pragma Elaboration_Checks (...);
15883 -- package Pack is ...;
15885 elsif Nkind (Context) = N_Compilation_Unit
15886 and then List_Containing (N) = Context_Items (Context)
15888 Check_Valid_Configuration_Pragma;
15889 Check_Duplicate_Elaboration_Checks_Pragma;
15891 Unt := Unit (Context);
15893 -- The pragma must appear on the initial declaration of a unit.
15894 -- If this is not the case, warn that the effects of the pragma
15897 if Nkind (Unt) = N_Package_Body then
15898 Ignore_Elaboration_Checks_Pragma;
15900 -- Check the Acts_As_Spec flag of the compilation units itself
15901 -- to determine whether the subprogram body completes since it
15902 -- has not been analyzed yet. This is safe because compilation
15903 -- units are not overloadable.
15905 elsif Nkind (Unt) = N_Subprogram_Body
15906 and then not Acts_As_Spec (Context)
15908 Ignore_Elaboration_Checks_Pragma;
15910 elsif Nkind (Unt) = N_Subunit then
15911 Ignore_Elaboration_Checks_Pragma;
15914 -- Otherwise the pragma does not appear at the configuration level
15921 -- At this point the pragma is not a duplicate, and appears in the
15922 -- proper context. Set the elaboration model in effect.
15924 Dynamic_Elaboration_Checks :=
15925 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15926 end Elaboration_Checks;
15932 -- pragma Eliminate (
15933 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15934 -- [Entity =>] IDENTIFIER |
15935 -- SELECTED_COMPONENT |
15937 -- [, Source_Location => SOURCE_TRACE]);
15939 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15940 -- SOURCE_TRACE ::= STRING_LITERAL
15942 when Pragma_Eliminate => Eliminate : declare
15943 Args : Args_List (1 .. 5);
15944 Names : constant Name_List (1 .. 5) := (
15947 Name_Parameter_Types,
15949 Name_Source_Location);
15951 -- Note : Parameter_Types and Result_Type are leftovers from
15952 -- prior implementations of the pragma. They are not generated
15953 -- by the gnatelim tool, and play no role in selecting which
15954 -- of a set of overloaded names is chosen for elimination.
15956 Unit_Name : Node_Id renames Args (1);
15957 Entity : Node_Id renames Args (2);
15958 Parameter_Types : Node_Id renames Args (3);
15959 Result_Type : Node_Id renames Args (4);
15960 Source_Location : Node_Id renames Args (5);
15964 Check_Valid_Configuration_Pragma;
15965 Gather_Associations (Names, Args);
15967 if No (Unit_Name) then
15968 Error_Pragma ("missing Unit_Name argument for pragma%");
15972 and then (Present (Parameter_Types)
15974 Present (Result_Type)
15976 Present (Source_Location))
15978 Error_Pragma ("missing Entity argument for pragma%");
15981 if (Present (Parameter_Types)
15983 Present (Result_Type))
15985 Present (Source_Location)
15988 ("parameter profile and source location cannot be used "
15989 & "together in pragma%");
15992 Process_Eliminate_Pragma
16001 -----------------------------------
16002 -- Enable_Atomic_Synchronization --
16003 -----------------------------------
16005 -- pragma Enable_Atomic_Synchronization [(Entity)];
16007 when Pragma_Enable_Atomic_Synchronization =>
16009 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16016 -- [ Convention =>] convention_IDENTIFIER,
16017 -- [ Entity =>] LOCAL_NAME
16018 -- [, [External_Name =>] static_string_EXPRESSION ]
16019 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16021 when Pragma_Export => Export : declare
16023 Def_Id : Entity_Id;
16025 pragma Warnings (Off, C);
16028 Check_Ada_83_Warning;
16032 Name_External_Name,
16035 Check_At_Least_N_Arguments (2);
16036 Check_At_Most_N_Arguments (4);
16038 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16039 -- pragma Export (Entity, "external name");
16041 if Relaxed_RM_Semantics
16042 and then Arg_Count = 2
16043 and then Nkind (Expression (Arg2)) = N_String_Literal
16046 Def_Id := Get_Pragma_Arg (Arg1);
16049 if not Is_Entity_Name (Def_Id) then
16050 Error_Pragma_Arg ("entity name required", Arg1);
16053 Def_Id := Entity (Def_Id);
16054 Set_Exported (Def_Id, Arg1);
16057 Process_Convention (C, Def_Id);
16059 -- A pragma that applies to a Ghost entity becomes Ghost for
16060 -- the purposes of legality checks and removal of ignored Ghost
16063 Mark_Ghost_Pragma (N, Def_Id);
16065 if Ekind (Def_Id) /= E_Constant then
16066 Note_Possible_Modification
16067 (Get_Pragma_Arg (Arg2), Sure => False);
16070 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16071 Set_Exported (Def_Id, Arg2);
16074 -- If the entity is a deferred constant, propagate the information
16075 -- to the full view, because gigi elaborates the full view only.
16077 if Ekind (Def_Id) = E_Constant
16078 and then Present (Full_View (Def_Id))
16081 Id2 : constant Entity_Id := Full_View (Def_Id);
16083 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16084 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16085 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16090 ---------------------
16091 -- Export_Function --
16092 ---------------------
16094 -- pragma Export_Function (
16095 -- [Internal =>] LOCAL_NAME
16096 -- [, [External =>] EXTERNAL_SYMBOL]
16097 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16098 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16099 -- [, [Mechanism =>] MECHANISM]
16100 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16102 -- EXTERNAL_SYMBOL ::=
16104 -- | static_string_EXPRESSION
16106 -- PARAMETER_TYPES ::=
16108 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16110 -- TYPE_DESIGNATOR ::=
16112 -- | subtype_Name ' Access
16116 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16118 -- MECHANISM_ASSOCIATION ::=
16119 -- [formal_parameter_NAME =>] MECHANISM_NAME
16121 -- MECHANISM_NAME ::=
16125 when Pragma_Export_Function => Export_Function : declare
16126 Args : Args_List (1 .. 6);
16127 Names : constant Name_List (1 .. 6) := (
16130 Name_Parameter_Types,
16133 Name_Result_Mechanism);
16135 Internal : Node_Id renames Args (1);
16136 External : Node_Id renames Args (2);
16137 Parameter_Types : Node_Id renames Args (3);
16138 Result_Type : Node_Id renames Args (4);
16139 Mechanism : Node_Id renames Args (5);
16140 Result_Mechanism : Node_Id renames Args (6);
16144 Gather_Associations (Names, Args);
16145 Process_Extended_Import_Export_Subprogram_Pragma (
16146 Arg_Internal => Internal,
16147 Arg_External => External,
16148 Arg_Parameter_Types => Parameter_Types,
16149 Arg_Result_Type => Result_Type,
16150 Arg_Mechanism => Mechanism,
16151 Arg_Result_Mechanism => Result_Mechanism);
16152 end Export_Function;
16154 -------------------
16155 -- Export_Object --
16156 -------------------
16158 -- pragma Export_Object (
16159 -- [Internal =>] LOCAL_NAME
16160 -- [, [External =>] EXTERNAL_SYMBOL]
16161 -- [, [Size =>] EXTERNAL_SYMBOL]);
16163 -- EXTERNAL_SYMBOL ::=
16165 -- | static_string_EXPRESSION
16167 -- PARAMETER_TYPES ::=
16169 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16171 -- TYPE_DESIGNATOR ::=
16173 -- | subtype_Name ' Access
16177 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16179 -- MECHANISM_ASSOCIATION ::=
16180 -- [formal_parameter_NAME =>] MECHANISM_NAME
16182 -- MECHANISM_NAME ::=
16186 when Pragma_Export_Object => Export_Object : declare
16187 Args : Args_List (1 .. 3);
16188 Names : constant Name_List (1 .. 3) := (
16193 Internal : Node_Id renames Args (1);
16194 External : Node_Id renames Args (2);
16195 Size : Node_Id renames Args (3);
16199 Gather_Associations (Names, Args);
16200 Process_Extended_Import_Export_Object_Pragma (
16201 Arg_Internal => Internal,
16202 Arg_External => External,
16206 ----------------------
16207 -- Export_Procedure --
16208 ----------------------
16210 -- pragma Export_Procedure (
16211 -- [Internal =>] LOCAL_NAME
16212 -- [, [External =>] EXTERNAL_SYMBOL]
16213 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16214 -- [, [Mechanism =>] MECHANISM]);
16216 -- EXTERNAL_SYMBOL ::=
16218 -- | static_string_EXPRESSION
16220 -- PARAMETER_TYPES ::=
16222 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16224 -- TYPE_DESIGNATOR ::=
16226 -- | subtype_Name ' Access
16230 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16232 -- MECHANISM_ASSOCIATION ::=
16233 -- [formal_parameter_NAME =>] MECHANISM_NAME
16235 -- MECHANISM_NAME ::=
16239 when Pragma_Export_Procedure => Export_Procedure : declare
16240 Args : Args_List (1 .. 4);
16241 Names : constant Name_List (1 .. 4) := (
16244 Name_Parameter_Types,
16247 Internal : Node_Id renames Args (1);
16248 External : Node_Id renames Args (2);
16249 Parameter_Types : Node_Id renames Args (3);
16250 Mechanism : Node_Id renames Args (4);
16254 Gather_Associations (Names, Args);
16255 Process_Extended_Import_Export_Subprogram_Pragma (
16256 Arg_Internal => Internal,
16257 Arg_External => External,
16258 Arg_Parameter_Types => Parameter_Types,
16259 Arg_Mechanism => Mechanism);
16260 end Export_Procedure;
16266 -- pragma Export_Value (
16267 -- [Value =>] static_integer_EXPRESSION,
16268 -- [Link_Name =>] static_string_EXPRESSION);
16270 when Pragma_Export_Value =>
16272 Check_Arg_Order ((Name_Value, Name_Link_Name));
16273 Check_Arg_Count (2);
16275 Check_Optional_Identifier (Arg1, Name_Value);
16276 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16278 Check_Optional_Identifier (Arg2, Name_Link_Name);
16279 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16281 -----------------------------
16282 -- Export_Valued_Procedure --
16283 -----------------------------
16285 -- pragma Export_Valued_Procedure (
16286 -- [Internal =>] LOCAL_NAME
16287 -- [, [External =>] EXTERNAL_SYMBOL,]
16288 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16289 -- [, [Mechanism =>] MECHANISM]);
16291 -- EXTERNAL_SYMBOL ::=
16293 -- | static_string_EXPRESSION
16295 -- PARAMETER_TYPES ::=
16297 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16299 -- TYPE_DESIGNATOR ::=
16301 -- | subtype_Name ' Access
16305 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16307 -- MECHANISM_ASSOCIATION ::=
16308 -- [formal_parameter_NAME =>] MECHANISM_NAME
16310 -- MECHANISM_NAME ::=
16314 when Pragma_Export_Valued_Procedure =>
16315 Export_Valued_Procedure : declare
16316 Args : Args_List (1 .. 4);
16317 Names : constant Name_List (1 .. 4) := (
16320 Name_Parameter_Types,
16323 Internal : Node_Id renames Args (1);
16324 External : Node_Id renames Args (2);
16325 Parameter_Types : Node_Id renames Args (3);
16326 Mechanism : Node_Id renames Args (4);
16330 Gather_Associations (Names, Args);
16331 Process_Extended_Import_Export_Subprogram_Pragma (
16332 Arg_Internal => Internal,
16333 Arg_External => External,
16334 Arg_Parameter_Types => Parameter_Types,
16335 Arg_Mechanism => Mechanism);
16336 end Export_Valued_Procedure;
16338 -------------------
16339 -- Extend_System --
16340 -------------------
16342 -- pragma Extend_System ([Name =>] Identifier);
16344 when Pragma_Extend_System =>
16346 Check_Valid_Configuration_Pragma;
16347 Check_Arg_Count (1);
16348 Check_Optional_Identifier (Arg1, Name_Name);
16349 Check_Arg_Is_Identifier (Arg1);
16351 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16354 and then Name_Buffer (1 .. 4) = "aux_"
16356 if Present (System_Extend_Pragma_Arg) then
16357 if Chars (Get_Pragma_Arg (Arg1)) =
16358 Chars (Expression (System_Extend_Pragma_Arg))
16362 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16363 Error_Pragma ("pragma% conflicts with that #");
16367 System_Extend_Pragma_Arg := Arg1;
16369 if not GNAT_Mode then
16370 System_Extend_Unit := Arg1;
16374 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16377 ------------------------
16378 -- Extensions_Allowed --
16379 ------------------------
16381 -- pragma Extensions_Allowed (ON | OFF);
16383 when Pragma_Extensions_Allowed =>
16385 Check_Arg_Count (1);
16386 Check_No_Identifiers;
16387 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16389 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16390 Extensions_Allowed := True;
16391 Ada_Version := Ada_Version_Type'Last;
16394 Extensions_Allowed := False;
16395 Ada_Version := Ada_Version_Explicit;
16396 Ada_Version_Pragma := Empty;
16399 ------------------------
16400 -- Extensions_Visible --
16401 ------------------------
16403 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16405 -- Characteristics:
16407 -- * Analysis - The annotation is fully analyzed immediately upon
16408 -- elaboration as its expression must be static.
16410 -- * Expansion - None.
16412 -- * Template - The annotation utilizes the generic template of the
16413 -- related subprogram [body] when it is:
16415 -- aspect on subprogram declaration
16416 -- aspect on stand-alone subprogram body
16417 -- pragma on stand-alone subprogram body
16419 -- The annotation must prepare its own template when it is:
16421 -- pragma on subprogram declaration
16423 -- * Globals - Capture of global references must occur after full
16426 -- * Instance - The annotation is instantiated automatically when
16427 -- the related generic subprogram [body] is instantiated except for
16428 -- the "pragma on subprogram declaration" case. In that scenario
16429 -- the annotation must instantiate itself.
16431 when Pragma_Extensions_Visible => Extensions_Visible : declare
16432 Formal : Entity_Id;
16433 Has_OK_Formal : Boolean := False;
16434 Spec_Id : Entity_Id;
16435 Subp_Decl : Node_Id;
16439 Check_No_Identifiers;
16440 Check_At_Most_N_Arguments (1);
16443 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16445 -- Abstract subprogram declaration
16447 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16450 -- Generic subprogram declaration
16452 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16455 -- Body acts as spec
16457 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16458 and then No (Corresponding_Spec (Subp_Decl))
16462 -- Body stub acts as spec
16464 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16465 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16469 -- Subprogram declaration
16471 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16474 -- Otherwise the pragma is associated with an illegal construct
16477 Error_Pragma ("pragma % must apply to a subprogram");
16481 -- Mark the pragma as Ghost if the related subprogram is also
16482 -- Ghost. This also ensures that any expansion performed further
16483 -- below will produce Ghost nodes.
16485 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16486 Mark_Ghost_Pragma (N, Spec_Id);
16488 -- Chain the pragma on the contract for completeness
16490 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16492 -- The legality checks of pragma Extension_Visible are affected
16493 -- by the SPARK mode in effect. Analyze all pragmas in specific
16496 Analyze_If_Present (Pragma_SPARK_Mode);
16498 -- Examine the formals of the related subprogram
16500 Formal := First_Formal (Spec_Id);
16501 while Present (Formal) loop
16503 -- At least one of the formals is of a specific tagged type,
16504 -- the pragma is legal.
16506 if Is_Specific_Tagged_Type (Etype (Formal)) then
16507 Has_OK_Formal := True;
16510 -- A generic subprogram with at least one formal of a private
16511 -- type ensures the legality of the pragma because the actual
16512 -- may be specifically tagged. Note that this is verified by
16513 -- the check above at instantiation time.
16515 elsif Is_Private_Type (Etype (Formal))
16516 and then Is_Generic_Type (Etype (Formal))
16518 Has_OK_Formal := True;
16522 Next_Formal (Formal);
16525 if not Has_OK_Formal then
16526 Error_Msg_Name_1 := Pname;
16527 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16529 ("\subprogram & lacks parameter of specific tagged or "
16530 & "generic private type", N, Spec_Id);
16535 -- Analyze the Boolean expression (if any)
16537 if Present (Arg1) then
16538 Check_Static_Boolean_Expression
16539 (Expression (Get_Argument (N, Spec_Id)));
16541 end Extensions_Visible;
16547 -- pragma External (
16548 -- [ Convention =>] convention_IDENTIFIER,
16549 -- [ Entity =>] LOCAL_NAME
16550 -- [, [External_Name =>] static_string_EXPRESSION ]
16551 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16553 when Pragma_External => External : declare
16556 pragma Warnings (Off, C);
16563 Name_External_Name,
16565 Check_At_Least_N_Arguments (2);
16566 Check_At_Most_N_Arguments (4);
16567 Process_Convention (C, E);
16569 -- A pragma that applies to a Ghost entity becomes Ghost for the
16570 -- purposes of legality checks and removal of ignored Ghost code.
16572 Mark_Ghost_Pragma (N, E);
16574 Note_Possible_Modification
16575 (Get_Pragma_Arg (Arg2), Sure => False);
16576 Process_Interface_Name (E, Arg3, Arg4, N);
16577 Set_Exported (E, Arg2);
16580 --------------------------
16581 -- External_Name_Casing --
16582 --------------------------
16584 -- pragma External_Name_Casing (
16585 -- UPPERCASE | LOWERCASE
16586 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16588 when Pragma_External_Name_Casing =>
16590 Check_No_Identifiers;
16592 if Arg_Count = 2 then
16593 Check_Arg_Is_One_Of
16594 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16596 case Chars (Get_Pragma_Arg (Arg2)) is
16598 Opt.External_Name_Exp_Casing := As_Is;
16600 when Name_Uppercase =>
16601 Opt.External_Name_Exp_Casing := Uppercase;
16603 when Name_Lowercase =>
16604 Opt.External_Name_Exp_Casing := Lowercase;
16611 Check_Arg_Count (1);
16614 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16616 case Chars (Get_Pragma_Arg (Arg1)) is
16617 when Name_Uppercase =>
16618 Opt.External_Name_Imp_Casing := Uppercase;
16620 when Name_Lowercase =>
16621 Opt.External_Name_Imp_Casing := Lowercase;
16631 -- pragma Fast_Math;
16633 when Pragma_Fast_Math =>
16635 Check_No_Identifiers;
16636 Check_Valid_Configuration_Pragma;
16639 --------------------------
16640 -- Favor_Top_Level --
16641 --------------------------
16643 -- pragma Favor_Top_Level (type_NAME);
16645 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16650 Check_No_Identifiers;
16651 Check_Arg_Count (1);
16652 Check_Arg_Is_Local_Name (Arg1);
16653 Typ := Entity (Get_Pragma_Arg (Arg1));
16655 -- A pragma that applies to a Ghost entity becomes Ghost for the
16656 -- purposes of legality checks and removal of ignored Ghost code.
16658 Mark_Ghost_Pragma (N, Typ);
16660 -- If it's an access-to-subprogram type (in particular, not a
16661 -- subtype), set the flag on that type.
16663 if Is_Access_Subprogram_Type (Typ) then
16664 Set_Can_Use_Internal_Rep (Typ, False);
16666 -- Otherwise it's an error (name denotes the wrong sort of entity)
16670 ("access-to-subprogram type expected",
16671 Get_Pragma_Arg (Arg1));
16673 end Favor_Top_Level;
16675 ---------------------------
16676 -- Finalize_Storage_Only --
16677 ---------------------------
16679 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16681 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16682 Assoc : constant Node_Id := Arg1;
16683 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16688 Check_No_Identifiers;
16689 Check_Arg_Count (1);
16690 Check_Arg_Is_Local_Name (Arg1);
16692 Find_Type (Type_Id);
16693 Typ := Entity (Type_Id);
16696 or else Rep_Item_Too_Early (Typ, N)
16700 Typ := Underlying_Type (Typ);
16703 if not Is_Controlled (Typ) then
16704 Error_Pragma ("pragma% must specify controlled type");
16707 Check_First_Subtype (Arg1);
16709 if Finalize_Storage_Only (Typ) then
16710 Error_Pragma ("duplicate pragma%, only one allowed");
16712 elsif not Rep_Item_Too_Late (Typ, N) then
16713 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16715 end Finalize_Storage;
16721 -- pragma Ghost [ (boolean_EXPRESSION) ];
16723 when Pragma_Ghost => Ghost : declare
16727 Orig_Stmt : Node_Id;
16728 Prev_Id : Entity_Id;
16733 Check_No_Identifiers;
16734 Check_At_Most_N_Arguments (1);
16738 while Present (Stmt) loop
16740 -- Skip prior pragmas, but check for duplicates
16742 if Nkind (Stmt) = N_Pragma then
16743 if Pragma_Name (Stmt) = Pname then
16750 -- Task unit declared without a definition cannot be subject to
16751 -- pragma Ghost (SPARK RM 6.9(19)).
16753 elsif Nkind (Stmt) in
16754 N_Single_Task_Declaration | N_Task_Type_Declaration
16756 Error_Pragma ("pragma % cannot apply to a task type");
16759 -- Skip internally generated code
16761 elsif not Comes_From_Source (Stmt) then
16762 Orig_Stmt := Original_Node (Stmt);
16764 -- When pragma Ghost applies to an untagged derivation, the
16765 -- derivation is transformed into a [sub]type declaration.
16768 N_Full_Type_Declaration | N_Subtype_Declaration
16769 and then Comes_From_Source (Orig_Stmt)
16770 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16771 and then Nkind (Type_Definition (Orig_Stmt)) =
16772 N_Derived_Type_Definition
16774 Id := Defining_Entity (Stmt);
16777 -- When pragma Ghost applies to an object declaration which
16778 -- is initialized by means of a function call that returns
16779 -- on the secondary stack, the object declaration becomes a
16782 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16783 and then Comes_From_Source (Orig_Stmt)
16784 and then Nkind (Orig_Stmt) = N_Object_Declaration
16786 Id := Defining_Entity (Stmt);
16789 -- When pragma Ghost applies to an expression function, the
16790 -- expression function is transformed into a subprogram.
16792 elsif Nkind (Stmt) = N_Subprogram_Declaration
16793 and then Comes_From_Source (Orig_Stmt)
16794 and then Nkind (Orig_Stmt) = N_Expression_Function
16796 Id := Defining_Entity (Stmt);
16800 -- The pragma applies to a legal construct, stop the traversal
16802 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
16803 | N_Full_Type_Declaration
16804 | N_Generic_Subprogram_Declaration
16805 | N_Object_Declaration
16806 | N_Private_Extension_Declaration
16807 | N_Private_Type_Declaration
16808 | N_Subprogram_Declaration
16809 | N_Subtype_Declaration
16811 Id := Defining_Entity (Stmt);
16814 -- The pragma does not apply to a legal construct, issue an
16815 -- error and stop the analysis.
16819 ("pragma % must apply to an object, package, subprogram "
16824 Stmt := Prev (Stmt);
16827 Context := Parent (N);
16829 -- Handle compilation units
16831 if Nkind (Context) = N_Compilation_Unit_Aux then
16832 Context := Unit (Parent (Context));
16835 -- Protected and task types cannot be subject to pragma Ghost
16836 -- (SPARK RM 6.9(19)).
16838 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
16840 Error_Pragma ("pragma % cannot apply to a protected type");
16843 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
16844 Error_Pragma ("pragma % cannot apply to a task type");
16850 -- When pragma Ghost is associated with a [generic] package, it
16851 -- appears in the visible declarations.
16853 if Nkind (Context) = N_Package_Specification
16854 and then Present (Visible_Declarations (Context))
16855 and then List_Containing (N) = Visible_Declarations (Context)
16857 Id := Defining_Entity (Context);
16859 -- Pragma Ghost applies to a stand-alone subprogram body
16861 elsif Nkind (Context) = N_Subprogram_Body
16862 and then No (Corresponding_Spec (Context))
16864 Id := Defining_Entity (Context);
16866 -- Pragma Ghost applies to a subprogram declaration that acts
16867 -- as a compilation unit.
16869 elsif Nkind (Context) = N_Subprogram_Declaration then
16870 Id := Defining_Entity (Context);
16872 -- Pragma Ghost applies to a generic subprogram
16874 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16875 Id := Defining_Entity (Specification (Context));
16881 ("pragma % must apply to an object, package, subprogram or "
16886 -- Handle completions of types and constants that are subject to
16889 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16890 Prev_Id := Incomplete_Or_Partial_View (Id);
16892 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16893 Error_Msg_Name_1 := Pname;
16895 -- The full declaration of a deferred constant cannot be
16896 -- subject to pragma Ghost unless the deferred declaration
16897 -- is also Ghost (SPARK RM 6.9(9)).
16899 if Ekind (Prev_Id) = E_Constant then
16900 Error_Msg_Name_1 := Pname;
16901 Error_Msg_NE (Fix_Error
16902 ("pragma % must apply to declaration of deferred "
16903 & "constant &"), N, Id);
16906 -- Pragma Ghost may appear on the full view of an incomplete
16907 -- type because the incomplete declaration lacks aspects and
16908 -- cannot be subject to pragma Ghost.
16910 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16913 -- The full declaration of a type cannot be subject to
16914 -- pragma Ghost unless the partial view is also Ghost
16915 -- (SPARK RM 6.9(9)).
16918 Error_Msg_NE (Fix_Error
16919 ("pragma % must apply to partial view of type &"),
16925 -- A synchronized object cannot be subject to pragma Ghost
16926 -- (SPARK RM 6.9(19)).
16928 elsif Ekind (Id) = E_Variable then
16929 if Is_Protected_Type (Etype (Id)) then
16930 Error_Pragma ("pragma % cannot apply to a protected object");
16933 elsif Is_Task_Type (Etype (Id)) then
16934 Error_Pragma ("pragma % cannot apply to a task object");
16939 -- Analyze the Boolean expression (if any)
16941 if Present (Arg1) then
16942 Expr := Get_Pragma_Arg (Arg1);
16944 Analyze_And_Resolve (Expr, Standard_Boolean);
16946 if Is_OK_Static_Expression (Expr) then
16948 -- "Ghostness" cannot be turned off once enabled within a
16949 -- region (SPARK RM 6.9(6)).
16951 if Is_False (Expr_Value (Expr))
16952 and then Ghost_Mode > None
16955 ("pragma % with value False cannot appear in enabled "
16960 -- Otherwise the expression is not static
16964 ("expression of pragma % must be static", Expr);
16969 Set_Is_Ghost_Entity (Id);
16976 -- pragma Global (GLOBAL_SPECIFICATION);
16978 -- GLOBAL_SPECIFICATION ::=
16981 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16983 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16985 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16986 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16987 -- GLOBAL_ITEM ::= NAME
16989 -- Characteristics:
16991 -- * Analysis - The annotation undergoes initial checks to verify
16992 -- the legal placement and context. Secondary checks fully analyze
16993 -- the dependency clauses in:
16995 -- Analyze_Global_In_Decl_Part
16997 -- * Expansion - None.
16999 -- * Template - The annotation utilizes the generic template of the
17000 -- related subprogram [body] when it is:
17002 -- aspect on subprogram declaration
17003 -- aspect on stand-alone subprogram body
17004 -- pragma on stand-alone subprogram body
17006 -- The annotation must prepare its own template when it is:
17008 -- pragma on subprogram declaration
17010 -- * Globals - Capture of global references must occur after full
17013 -- * Instance - The annotation is instantiated automatically when
17014 -- the related generic subprogram [body] is instantiated except for
17015 -- the "pragma on subprogram declaration" case. In that scenario
17016 -- the annotation must instantiate itself.
17018 when Pragma_Global => Global : declare
17020 Spec_Id : Entity_Id;
17021 Subp_Decl : Node_Id;
17024 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17028 -- Chain the pragma on the contract for further processing by
17029 -- Analyze_Global_In_Decl_Part.
17031 Add_Contract_Item (N, Spec_Id);
17033 -- Fully analyze the pragma when it appears inside an entry
17034 -- or subprogram body because it cannot benefit from forward
17037 if Nkind (Subp_Decl) in N_Entry_Body
17038 | N_Subprogram_Body
17039 | N_Subprogram_Body_Stub
17041 -- The legality checks of pragmas Depends and Global are
17042 -- affected by the SPARK mode in effect and the volatility
17043 -- of the context. In addition these two pragmas are subject
17044 -- to an inherent order:
17049 -- Analyze all these pragmas in the order outlined above
17051 Analyze_If_Present (Pragma_SPARK_Mode);
17052 Analyze_If_Present (Pragma_Volatile_Function);
17053 Analyze_Global_In_Decl_Part (N);
17054 Analyze_If_Present (Pragma_Depends);
17063 -- pragma Ident (static_string_EXPRESSION)
17065 -- Note: pragma Comment shares this processing. Pragma Ident is
17066 -- identical in effect to pragma Commment.
17068 when Pragma_Comment
17076 Check_Arg_Count (1);
17077 Check_No_Identifiers;
17078 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17081 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17088 GP := Parent (Parent (N));
17091 N_Package_Declaration | N_Generic_Package_Declaration
17096 -- If we have a compilation unit, then record the ident value,
17097 -- checking for improper duplication.
17099 if Nkind (GP) = N_Compilation_Unit then
17100 CS := Ident_String (Current_Sem_Unit);
17102 if Present (CS) then
17104 -- If we have multiple instances, concatenate them.
17106 Start_String (Strval (CS));
17107 Store_String_Char (' ');
17108 Store_String_Chars (Strval (Str));
17109 Set_Strval (CS, End_String);
17112 Set_Ident_String (Current_Sem_Unit, Str);
17115 -- For subunits, we just ignore the Ident, since in GNAT these
17116 -- are not separate object files, and hence not separate units
17117 -- in the unit table.
17119 elsif Nkind (GP) = N_Subunit then
17125 -------------------
17126 -- Ignore_Pragma --
17127 -------------------
17129 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17131 -- Entirely handled in the parser, nothing to do here
17133 when Pragma_Ignore_Pragma =>
17136 ----------------------------
17137 -- Implementation_Defined --
17138 ----------------------------
17140 -- pragma Implementation_Defined (LOCAL_NAME);
17142 -- Marks previously declared entity as implementation defined. For
17143 -- an overloaded entity, applies to the most recent homonym.
17145 -- pragma Implementation_Defined;
17147 -- The form with no arguments appears anywhere within a scope, most
17148 -- typically a package spec, and indicates that all entities that are
17149 -- defined within the package spec are Implementation_Defined.
17151 when Pragma_Implementation_Defined => Implementation_Defined : declare
17156 Check_No_Identifiers;
17158 -- Form with no arguments
17160 if Arg_Count = 0 then
17161 Set_Is_Implementation_Defined (Current_Scope);
17163 -- Form with one argument
17166 Check_Arg_Count (1);
17167 Check_Arg_Is_Local_Name (Arg1);
17168 Ent := Entity (Get_Pragma_Arg (Arg1));
17169 Set_Is_Implementation_Defined (Ent);
17171 end Implementation_Defined;
17177 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17179 -- IMPLEMENTATION_KIND ::=
17180 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17182 -- "By_Any" and "Optional" are treated as synonyms in order to
17183 -- support Ada 2012 aspect Synchronization.
17185 when Pragma_Implemented => Implemented : declare
17186 Proc_Id : Entity_Id;
17191 Check_Arg_Count (2);
17192 Check_No_Identifiers;
17193 Check_Arg_Is_Identifier (Arg1);
17194 Check_Arg_Is_Local_Name (Arg1);
17195 Check_Arg_Is_One_Of (Arg2,
17198 Name_By_Protected_Procedure,
17201 -- Extract the name of the local procedure
17203 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17205 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17206 -- primitive procedure of a synchronized tagged type.
17208 if Ekind (Proc_Id) = E_Procedure
17209 and then Is_Primitive (Proc_Id)
17210 and then Present (First_Formal (Proc_Id))
17212 Typ := Etype (First_Formal (Proc_Id));
17214 if Is_Tagged_Type (Typ)
17217 -- Check for a protected, a synchronized or a task interface
17219 ((Is_Interface (Typ)
17220 and then Is_Synchronized_Interface (Typ))
17222 -- Check for a protected type or a task type that implements
17226 (Is_Concurrent_Record_Type (Typ)
17227 and then Present (Interfaces (Typ)))
17229 -- In analysis-only mode, examine original protected type
17232 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17233 and then Present (Interface_List (Parent (Typ))))
17235 -- Check for a private record extension with keyword
17239 (Ekind (Typ) in E_Record_Type_With_Private
17240 | E_Record_Subtype_With_Private
17241 and then Synchronized_Present (Parent (Typ))))
17246 ("controlling formal must be of synchronized tagged type",
17251 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17252 -- By_Protected_Procedure to the primitive procedure of a task
17255 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17256 and then Is_Interface (Typ)
17257 and then Is_Task_Interface (Typ)
17260 ("implementation kind By_Protected_Procedure cannot be "
17261 & "applied to a task interface primitive", Arg2);
17265 -- Procedures declared inside a protected type must be accepted
17267 elsif Ekind (Proc_Id) = E_Procedure
17268 and then Is_Protected_Type (Scope (Proc_Id))
17272 -- The first argument is not a primitive procedure
17276 ("pragma % must be applied to a primitive procedure", Arg1);
17280 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17281 -- By_Protected_Procedure to a procedure that has aspect Yield
17283 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17284 and then Has_Yield_Aspect (Proc_Id)
17287 ("implementation kind By_Protected_Procedure cannot be "
17288 & "applied to entities with aspect 'Yield", Arg2);
17292 Record_Rep_Item (Proc_Id, N);
17295 ----------------------
17296 -- Implicit_Packing --
17297 ----------------------
17299 -- pragma Implicit_Packing;
17301 when Pragma_Implicit_Packing =>
17303 Check_Arg_Count (0);
17304 Implicit_Packing := True;
17311 -- [Convention =>] convention_IDENTIFIER,
17312 -- [Entity =>] LOCAL_NAME
17313 -- [, [External_Name =>] static_string_EXPRESSION ]
17314 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17316 when Pragma_Import =>
17317 Check_Ada_83_Warning;
17321 Name_External_Name,
17324 Check_At_Least_N_Arguments (2);
17325 Check_At_Most_N_Arguments (4);
17326 Process_Import_Or_Interface;
17328 ---------------------
17329 -- Import_Function --
17330 ---------------------
17332 -- pragma Import_Function (
17333 -- [Internal =>] LOCAL_NAME,
17334 -- [, [External =>] EXTERNAL_SYMBOL]
17335 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17336 -- [, [Result_Type =>] SUBTYPE_MARK]
17337 -- [, [Mechanism =>] MECHANISM]
17338 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17340 -- EXTERNAL_SYMBOL ::=
17342 -- | static_string_EXPRESSION
17344 -- PARAMETER_TYPES ::=
17346 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17348 -- TYPE_DESIGNATOR ::=
17350 -- | subtype_Name ' Access
17354 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17356 -- MECHANISM_ASSOCIATION ::=
17357 -- [formal_parameter_NAME =>] MECHANISM_NAME
17359 -- MECHANISM_NAME ::=
17363 when Pragma_Import_Function => Import_Function : declare
17364 Args : Args_List (1 .. 6);
17365 Names : constant Name_List (1 .. 6) := (
17368 Name_Parameter_Types,
17371 Name_Result_Mechanism);
17373 Internal : Node_Id renames Args (1);
17374 External : Node_Id renames Args (2);
17375 Parameter_Types : Node_Id renames Args (3);
17376 Result_Type : Node_Id renames Args (4);
17377 Mechanism : Node_Id renames Args (5);
17378 Result_Mechanism : Node_Id renames Args (6);
17382 Gather_Associations (Names, Args);
17383 Process_Extended_Import_Export_Subprogram_Pragma (
17384 Arg_Internal => Internal,
17385 Arg_External => External,
17386 Arg_Parameter_Types => Parameter_Types,
17387 Arg_Result_Type => Result_Type,
17388 Arg_Mechanism => Mechanism,
17389 Arg_Result_Mechanism => Result_Mechanism);
17390 end Import_Function;
17392 -------------------
17393 -- Import_Object --
17394 -------------------
17396 -- pragma Import_Object (
17397 -- [Internal =>] LOCAL_NAME
17398 -- [, [External =>] EXTERNAL_SYMBOL]
17399 -- [, [Size =>] EXTERNAL_SYMBOL]);
17401 -- EXTERNAL_SYMBOL ::=
17403 -- | static_string_EXPRESSION
17405 when Pragma_Import_Object => Import_Object : declare
17406 Args : Args_List (1 .. 3);
17407 Names : constant Name_List (1 .. 3) := (
17412 Internal : Node_Id renames Args (1);
17413 External : Node_Id renames Args (2);
17414 Size : Node_Id renames Args (3);
17418 Gather_Associations (Names, Args);
17419 Process_Extended_Import_Export_Object_Pragma (
17420 Arg_Internal => Internal,
17421 Arg_External => External,
17425 ----------------------
17426 -- Import_Procedure --
17427 ----------------------
17429 -- pragma Import_Procedure (
17430 -- [Internal =>] LOCAL_NAME
17431 -- [, [External =>] EXTERNAL_SYMBOL]
17432 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17433 -- [, [Mechanism =>] MECHANISM]);
17435 -- EXTERNAL_SYMBOL ::=
17437 -- | static_string_EXPRESSION
17439 -- PARAMETER_TYPES ::=
17441 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17443 -- TYPE_DESIGNATOR ::=
17445 -- | subtype_Name ' Access
17449 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17451 -- MECHANISM_ASSOCIATION ::=
17452 -- [formal_parameter_NAME =>] MECHANISM_NAME
17454 -- MECHANISM_NAME ::=
17458 when Pragma_Import_Procedure => Import_Procedure : declare
17459 Args : Args_List (1 .. 4);
17460 Names : constant Name_List (1 .. 4) := (
17463 Name_Parameter_Types,
17466 Internal : Node_Id renames Args (1);
17467 External : Node_Id renames Args (2);
17468 Parameter_Types : Node_Id renames Args (3);
17469 Mechanism : Node_Id renames Args (4);
17473 Gather_Associations (Names, Args);
17474 Process_Extended_Import_Export_Subprogram_Pragma (
17475 Arg_Internal => Internal,
17476 Arg_External => External,
17477 Arg_Parameter_Types => Parameter_Types,
17478 Arg_Mechanism => Mechanism);
17479 end Import_Procedure;
17481 -----------------------------
17482 -- Import_Valued_Procedure --
17483 -----------------------------
17485 -- pragma Import_Valued_Procedure (
17486 -- [Internal =>] LOCAL_NAME
17487 -- [, [External =>] EXTERNAL_SYMBOL]
17488 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17489 -- [, [Mechanism =>] MECHANISM]);
17491 -- EXTERNAL_SYMBOL ::=
17493 -- | static_string_EXPRESSION
17495 -- PARAMETER_TYPES ::=
17497 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17499 -- TYPE_DESIGNATOR ::=
17501 -- | subtype_Name ' Access
17505 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17507 -- MECHANISM_ASSOCIATION ::=
17508 -- [formal_parameter_NAME =>] MECHANISM_NAME
17510 -- MECHANISM_NAME ::=
17514 when Pragma_Import_Valued_Procedure =>
17515 Import_Valued_Procedure : declare
17516 Args : Args_List (1 .. 4);
17517 Names : constant Name_List (1 .. 4) := (
17520 Name_Parameter_Types,
17523 Internal : Node_Id renames Args (1);
17524 External : Node_Id renames Args (2);
17525 Parameter_Types : Node_Id renames Args (3);
17526 Mechanism : Node_Id renames Args (4);
17530 Gather_Associations (Names, Args);
17531 Process_Extended_Import_Export_Subprogram_Pragma (
17532 Arg_Internal => Internal,
17533 Arg_External => External,
17534 Arg_Parameter_Types => Parameter_Types,
17535 Arg_Mechanism => Mechanism);
17536 end Import_Valued_Procedure;
17542 -- pragma Independent (LOCAL_NAME);
17544 when Pragma_Independent =>
17545 Process_Atomic_Independent_Shared_Volatile;
17547 ----------------------------
17548 -- Independent_Components --
17549 ----------------------------
17551 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17553 when Pragma_Independent_Components => Independent_Components : declare
17560 Check_Ada_83_Warning;
17562 Check_No_Identifiers;
17563 Check_Arg_Count (1);
17564 Check_Arg_Is_Local_Name (Arg1);
17565 E_Id := Get_Pragma_Arg (Arg1);
17567 if Etype (E_Id) = Any_Type then
17571 E := Entity (E_Id);
17573 -- A record type with a self-referential component of anonymous
17574 -- access type is given an incomplete view in order to handle the
17577 -- type Rec is record
17578 -- Self : access Rec;
17584 -- type Ptr is access Rec;
17585 -- type Rec is record
17589 -- Since the incomplete view is now the initial view of the type,
17590 -- the argument of the pragma will reference the incomplete view,
17591 -- but this view is illegal according to the semantics of the
17594 -- Obtain the full view of an internally-generated incomplete type
17595 -- only. This way an attempt to associate the pragma with a source
17596 -- incomplete type is still caught.
17598 if Ekind (E) = E_Incomplete_Type
17599 and then not Comes_From_Source (E)
17600 and then Present (Full_View (E))
17602 E := Full_View (E);
17605 -- A pragma that applies to a Ghost entity becomes Ghost for the
17606 -- purposes of legality checks and removal of ignored Ghost code.
17608 Mark_Ghost_Pragma (N, E);
17610 -- Check duplicate before we chain ourselves
17612 Check_Duplicate_Pragma (E);
17614 -- Check appropriate entity
17616 if Rep_Item_Too_Early (E, N)
17618 Rep_Item_Too_Late (E, N)
17623 D := Declaration_Node (E);
17625 -- The flag is set on the base type, or on the object
17627 if Nkind (D) = N_Full_Type_Declaration
17628 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17630 Set_Has_Independent_Components (Base_Type (E));
17631 Record_Independence_Check (N, Base_Type (E));
17633 -- For record type, set all components independent
17635 if Is_Record_Type (E) then
17636 C := First_Component (E);
17637 while Present (C) loop
17638 Set_Is_Independent (C);
17639 Next_Component (C);
17643 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17644 and then Nkind (D) = N_Object_Declaration
17645 and then Nkind (Object_Definition (D)) =
17646 N_Constrained_Array_Definition
17648 Set_Has_Independent_Components (E);
17649 Record_Independence_Check (N, E);
17652 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17654 end Independent_Components;
17656 -----------------------
17657 -- Initial_Condition --
17658 -----------------------
17660 -- pragma Initial_Condition (boolean_EXPRESSION);
17662 -- Characteristics:
17664 -- * Analysis - The annotation undergoes initial checks to verify
17665 -- the legal placement and context. Secondary checks preanalyze the
17668 -- Analyze_Initial_Condition_In_Decl_Part
17670 -- * Expansion - The annotation is expanded during the expansion of
17671 -- the package body whose declaration is subject to the annotation
17674 -- Expand_Pragma_Initial_Condition
17676 -- * Template - The annotation utilizes the generic template of the
17677 -- related package declaration.
17679 -- * Globals - Capture of global references must occur after full
17682 -- * Instance - The annotation is instantiated automatically when
17683 -- the related generic package is instantiated.
17685 when Pragma_Initial_Condition => Initial_Condition : declare
17686 Pack_Decl : Node_Id;
17687 Pack_Id : Entity_Id;
17691 Check_No_Identifiers;
17692 Check_Arg_Count (1);
17694 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17696 if Nkind (Pack_Decl) not in
17697 N_Generic_Package_Declaration | N_Package_Declaration
17703 Pack_Id := Defining_Entity (Pack_Decl);
17705 -- A pragma that applies to a Ghost entity becomes Ghost for the
17706 -- purposes of legality checks and removal of ignored Ghost code.
17708 Mark_Ghost_Pragma (N, Pack_Id);
17710 -- Chain the pragma on the contract for further processing by
17711 -- Analyze_Initial_Condition_In_Decl_Part.
17713 Add_Contract_Item (N, Pack_Id);
17715 -- The legality checks of pragmas Abstract_State, Initializes, and
17716 -- Initial_Condition are affected by the SPARK mode in effect. In
17717 -- addition, these three pragmas are subject to an inherent order:
17719 -- 1) Abstract_State
17721 -- 3) Initial_Condition
17723 -- Analyze all these pragmas in the order outlined above
17725 Analyze_If_Present (Pragma_SPARK_Mode);
17726 Analyze_If_Present (Pragma_Abstract_State);
17727 Analyze_If_Present (Pragma_Initializes);
17728 end Initial_Condition;
17730 ------------------------
17731 -- Initialize_Scalars --
17732 ------------------------
17734 -- pragma Initialize_Scalars
17735 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17737 -- TYPE_VALUE_PAIR ::=
17738 -- SCALAR_TYPE => static_EXPRESSION
17744 -- | Long_Long_Float
17756 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17757 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17758 -- This collection holds the individual pairs which specify the
17759 -- invalid values of their respective scalar types.
17761 procedure Analyze_Float_Value
17762 (Scal_Typ : Float_Scalar_Id;
17763 Val_Expr : Node_Id);
17764 -- Analyze a type value pair associated with float type Scal_Typ
17765 -- and expression Val_Expr.
17767 procedure Analyze_Integer_Value
17768 (Scal_Typ : Integer_Scalar_Id;
17769 Val_Expr : Node_Id);
17770 -- Analyze a type value pair associated with integer type Scal_Typ
17771 -- and expression Val_Expr.
17773 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17774 -- Analyze type value pair Pair
17776 -------------------------
17777 -- Analyze_Float_Value --
17778 -------------------------
17780 procedure Analyze_Float_Value
17781 (Scal_Typ : Float_Scalar_Id;
17782 Val_Expr : Node_Id)
17785 Analyze_And_Resolve (Val_Expr, Any_Real);
17787 if Is_OK_Static_Expression (Val_Expr) then
17788 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17791 Error_Msg_Name_1 := Scal_Typ;
17792 Error_Msg_N ("value for type % must be static", Val_Expr);
17794 end Analyze_Float_Value;
17796 ---------------------------
17797 -- Analyze_Integer_Value --
17798 ---------------------------
17800 procedure Analyze_Integer_Value
17801 (Scal_Typ : Integer_Scalar_Id;
17802 Val_Expr : Node_Id)
17805 Analyze_And_Resolve (Val_Expr, Any_Integer);
17807 if (Scal_Typ = Name_Signed_128
17808 or else Scal_Typ = Name_Unsigned_128)
17809 and then Ttypes.System_Max_Integer_Size < 128
17811 Error_Msg_Name_1 := Scal_Typ;
17812 Error_Msg_N ("value cannot be set for type %", Val_Expr);
17814 elsif Is_OK_Static_Expression (Val_Expr) then
17815 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17818 Error_Msg_Name_1 := Scal_Typ;
17819 Error_Msg_N ("value for type % must be static", Val_Expr);
17821 end Analyze_Integer_Value;
17823 -----------------------------
17824 -- Analyze_Type_Value_Pair --
17825 -----------------------------
17827 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17828 Scal_Typ : constant Name_Id := Chars (Pair);
17829 Val_Expr : constant Node_Id := Expression (Pair);
17830 Prev_Pair : Node_Id;
17833 if Scal_Typ in Scalar_Id then
17834 Prev_Pair := Seen (Scal_Typ);
17836 -- Prevent multiple attempts to set a value for a scalar
17839 if Present (Prev_Pair) then
17840 Error_Msg_Name_1 := Scal_Typ;
17842 ("cannot specify multiple invalid values for type %",
17845 Error_Msg_Sloc := Sloc (Prev_Pair);
17846 Error_Msg_N ("previous value set #", Pair);
17848 -- Ignore the effects of the pair, but do not halt the
17849 -- analysis of the pragma altogether.
17853 -- Otherwise capture the first pair for this scalar type
17856 Seen (Scal_Typ) := Pair;
17859 if Scal_Typ in Float_Scalar_Id then
17860 Analyze_Float_Value (Scal_Typ, Val_Expr);
17862 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17863 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17866 -- Otherwise the scalar family is illegal
17869 Error_Msg_Name_1 := Pname;
17871 ("argument of pragma % must denote valid scalar family",
17874 end Analyze_Type_Value_Pair;
17878 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17881 -- Start of processing for Do_Initialize_Scalars
17885 Check_Valid_Configuration_Pragma;
17886 Check_Restriction (No_Initialize_Scalars, N);
17888 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17891 if Restriction_Active (No_Initialize_Scalars) then
17894 -- Initialize_Scalars creates false positives in CodePeer, and
17895 -- incorrect negative results in GNATprove mode, so ignore this
17896 -- pragma in these modes.
17898 elsif CodePeer_Mode or GNATprove_Mode then
17901 -- Otherwise analyze the pragma
17904 if Present (Pairs) then
17906 -- Install Standard in order to provide access to primitive
17907 -- types in case the expressions contain attributes such as
17910 Push_Scope (Standard_Standard);
17912 Pair := First (Pairs);
17913 while Present (Pair) loop
17914 Analyze_Type_Value_Pair (Pair);
17923 Init_Or_Norm_Scalars := True;
17924 Initialize_Scalars := True;
17926 end Do_Initialize_Scalars;
17932 -- pragma Initializes (INITIALIZATION_LIST);
17934 -- INITIALIZATION_LIST ::=
17936 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17938 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17943 -- | (INPUT {, INPUT})
17947 -- Characteristics:
17949 -- * Analysis - The annotation undergoes initial checks to verify
17950 -- the legal placement and context. Secondary checks preanalyze the
17953 -- Analyze_Initializes_In_Decl_Part
17955 -- * Expansion - None.
17957 -- * Template - The annotation utilizes the generic template of the
17958 -- related package declaration.
17960 -- * Globals - Capture of global references must occur after full
17963 -- * Instance - The annotation is instantiated automatically when
17964 -- the related generic package is instantiated.
17966 when Pragma_Initializes => Initializes : declare
17967 Pack_Decl : Node_Id;
17968 Pack_Id : Entity_Id;
17972 Check_No_Identifiers;
17973 Check_Arg_Count (1);
17975 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17977 if Nkind (Pack_Decl) not in
17978 N_Generic_Package_Declaration | N_Package_Declaration
17984 Pack_Id := Defining_Entity (Pack_Decl);
17986 -- A pragma that applies to a Ghost entity becomes Ghost for the
17987 -- purposes of legality checks and removal of ignored Ghost code.
17989 Mark_Ghost_Pragma (N, Pack_Id);
17990 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
17992 -- Chain the pragma on the contract for further processing by
17993 -- Analyze_Initializes_In_Decl_Part.
17995 Add_Contract_Item (N, Pack_Id);
17997 -- The legality checks of pragmas Abstract_State, Initializes, and
17998 -- Initial_Condition are affected by the SPARK mode in effect. In
17999 -- addition, these three pragmas are subject to an inherent order:
18001 -- 1) Abstract_State
18003 -- 3) Initial_Condition
18005 -- Analyze all these pragmas in the order outlined above
18007 Analyze_If_Present (Pragma_SPARK_Mode);
18008 Analyze_If_Present (Pragma_Abstract_State);
18009 Analyze_If_Present (Pragma_Initial_Condition);
18016 -- pragma Inline ( NAME {, NAME} );
18018 when Pragma_Inline =>
18020 -- Pragma always active unless in GNATprove mode. It is disabled
18021 -- in GNATprove mode because frontend inlining is applied
18022 -- independently of pragmas Inline and Inline_Always for
18023 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18026 if not GNATprove_Mode then
18028 -- Inline status is Enabled if option -gnatn is specified.
18029 -- However this status determines only the value of the
18030 -- Is_Inlined flag on the subprogram and does not prevent
18031 -- the pragma itself from being recorded for later use,
18032 -- in particular for a later modification of Is_Inlined
18033 -- independently of the -gnatn option.
18035 -- In other words, if -gnatn is specified for a unit, then
18036 -- all Inline pragmas processed for the compilation of this
18037 -- unit, including those in the spec of other units, are
18038 -- activated, so subprograms will be inlined across units.
18040 -- If -gnatn is not specified, no Inline pragma is activated
18041 -- here, which means that subprograms will not be inlined
18042 -- across units. The Is_Inlined flag will nevertheless be
18043 -- set later when bodies are analyzed, so subprograms will
18044 -- be inlined within the unit.
18046 if Inline_Active then
18047 Process_Inline (Enabled);
18049 Process_Inline (Disabled);
18053 -------------------
18054 -- Inline_Always --
18055 -------------------
18057 -- pragma Inline_Always ( NAME {, NAME} );
18059 when Pragma_Inline_Always =>
18062 -- Pragma always active unless in CodePeer mode or GNATprove
18063 -- mode. It is disabled in CodePeer mode because inlining is
18064 -- not helpful, and enabling it caused walk order issues. It
18065 -- is disabled in GNATprove mode because frontend inlining is
18066 -- applied independently of pragmas Inline and Inline_Always for
18067 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18070 if not CodePeer_Mode and not GNATprove_Mode then
18071 Process_Inline (Enabled);
18074 --------------------
18075 -- Inline_Generic --
18076 --------------------
18078 -- pragma Inline_Generic (NAME {, NAME});
18080 when Pragma_Inline_Generic =>
18082 Process_Generic_List;
18084 ----------------------
18085 -- Inspection_Point --
18086 ----------------------
18088 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18090 when Pragma_Inspection_Point => Inspection_Point : declare
18097 if Arg_Count > 0 then
18100 Exp := Get_Pragma_Arg (Arg);
18103 if not Is_Entity_Name (Exp)
18104 or else not Is_Object (Entity (Exp))
18106 Error_Pragma_Arg ("object name required", Arg);
18110 exit when No (Arg);
18113 end Inspection_Point;
18119 -- pragma Interface (
18120 -- [ Convention =>] convention_IDENTIFIER,
18121 -- [ Entity =>] LOCAL_NAME
18122 -- [, [External_Name =>] static_string_EXPRESSION ]
18123 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18125 when Pragma_Interface =>
18130 Name_External_Name,
18132 Check_At_Least_N_Arguments (2);
18133 Check_At_Most_N_Arguments (4);
18134 Process_Import_Or_Interface;
18136 -- In Ada 2005, the permission to use Interface (a reserved word)
18137 -- as a pragma name is considered an obsolescent feature, and this
18138 -- pragma was already obsolescent in Ada 95.
18140 if Ada_Version >= Ada_95 then
18142 (No_Obsolescent_Features, Pragma_Identifier (N));
18144 if Warn_On_Obsolescent_Feature then
18146 ("pragma Interface is an obsolescent feature?j?", N);
18148 ("|use pragma Import instead?j?", N);
18152 --------------------
18153 -- Interface_Name --
18154 --------------------
18156 -- pragma Interface_Name (
18157 -- [ Entity =>] LOCAL_NAME
18158 -- [,[External_Name =>] static_string_EXPRESSION ]
18159 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18161 when Pragma_Interface_Name => Interface_Name : declare
18163 Def_Id : Entity_Id;
18164 Hom_Id : Entity_Id;
18170 ((Name_Entity, Name_External_Name, Name_Link_Name));
18171 Check_At_Least_N_Arguments (2);
18172 Check_At_Most_N_Arguments (3);
18173 Id := Get_Pragma_Arg (Arg1);
18176 -- This is obsolete from Ada 95 on, but it is an implementation
18177 -- defined pragma, so we do not consider that it violates the
18178 -- restriction (No_Obsolescent_Features).
18180 if Ada_Version >= Ada_95 then
18181 if Warn_On_Obsolescent_Feature then
18183 ("pragma Interface_Name is an obsolescent feature?j?", N);
18185 ("|use pragma Import instead?j?", N);
18189 if not Is_Entity_Name (Id) then
18191 ("first argument for pragma% must be entity name", Arg1);
18192 elsif Etype (Id) = Any_Type then
18195 Def_Id := Entity (Id);
18198 -- Special DEC-compatible processing for the object case, forces
18199 -- object to be imported.
18201 if Ekind (Def_Id) = E_Variable then
18202 Kill_Size_Check_Code (Def_Id);
18203 Note_Possible_Modification (Id, Sure => False);
18205 -- Initialization is not allowed for imported variable
18207 if Present (Expression (Parent (Def_Id)))
18208 and then Comes_From_Source (Expression (Parent (Def_Id)))
18210 Error_Msg_Sloc := Sloc (Def_Id);
18212 ("no initialization allowed for declaration of& #",
18216 -- For compatibility, support VADS usage of providing both
18217 -- pragmas Interface and Interface_Name to obtain the effect
18218 -- of a single Import pragma.
18220 if Is_Imported (Def_Id)
18221 and then Present (First_Rep_Item (Def_Id))
18222 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18223 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18228 Set_Imported (Def_Id);
18231 Set_Is_Public (Def_Id);
18232 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18235 -- Otherwise must be subprogram
18237 elsif not Is_Subprogram (Def_Id) then
18239 ("argument of pragma% is not subprogram", Arg1);
18242 Check_At_Most_N_Arguments (3);
18246 -- Loop through homonyms
18249 Def_Id := Get_Base_Subprogram (Hom_Id);
18251 if Is_Imported (Def_Id) then
18252 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18256 exit when From_Aspect_Specification (N);
18257 Hom_Id := Homonym (Hom_Id);
18259 exit when No (Hom_Id)
18260 or else Scope (Hom_Id) /= Current_Scope;
18265 ("argument of pragma% is not imported subprogram",
18269 end Interface_Name;
18271 -----------------------
18272 -- Interrupt_Handler --
18273 -----------------------
18275 -- pragma Interrupt_Handler (handler_NAME);
18277 when Pragma_Interrupt_Handler =>
18278 Check_Ada_83_Warning;
18279 Check_Arg_Count (1);
18280 Check_No_Identifiers;
18282 if No_Run_Time_Mode then
18283 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18285 Check_Interrupt_Or_Attach_Handler;
18286 Process_Interrupt_Or_Attach_Handler;
18289 ------------------------
18290 -- Interrupt_Priority --
18291 ------------------------
18293 -- pragma Interrupt_Priority [(EXPRESSION)];
18295 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18296 P : constant Node_Id := Parent (N);
18301 Check_Ada_83_Warning;
18303 if Arg_Count /= 0 then
18304 Arg := Get_Pragma_Arg (Arg1);
18305 Check_Arg_Count (1);
18306 Check_No_Identifiers;
18308 -- The expression must be analyzed in the special manner
18309 -- described in "Handling of Default and Per-Object
18310 -- Expressions" in sem.ads.
18312 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18315 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
18320 Ent := Defining_Identifier (Parent (P));
18322 -- Check duplicate pragma before we chain the pragma in the Rep
18323 -- Item chain of Ent.
18325 Check_Duplicate_Pragma (Ent);
18326 Record_Rep_Item (Ent, N);
18328 -- Check the No_Task_At_Interrupt_Priority restriction
18330 if Nkind (P) = N_Task_Definition then
18331 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18334 end Interrupt_Priority;
18336 ---------------------
18337 -- Interrupt_State --
18338 ---------------------
18340 -- pragma Interrupt_State (
18341 -- [Name =>] INTERRUPT_ID,
18342 -- [State =>] INTERRUPT_STATE);
18344 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18345 -- INTERRUPT_STATE => System | Runtime | User
18347 -- Note: if the interrupt id is given as an identifier, then it must
18348 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18349 -- given as a static integer expression which must be in the range of
18350 -- Ada.Interrupts.Interrupt_ID.
18352 when Pragma_Interrupt_State => Interrupt_State : declare
18353 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18354 -- This is the entity Ada.Interrupts.Interrupt_ID;
18356 State_Type : Character;
18357 -- Set to 's'/'r'/'u' for System/Runtime/User
18360 -- Index to entry in Interrupt_States table
18363 -- Value of interrupt
18365 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18366 -- The first argument to the pragma
18368 Int_Ent : Entity_Id;
18369 -- Interrupt entity in Ada.Interrupts.Names
18373 Check_Arg_Order ((Name_Name, Name_State));
18374 Check_Arg_Count (2);
18376 Check_Optional_Identifier (Arg1, Name_Name);
18377 Check_Optional_Identifier (Arg2, Name_State);
18378 Check_Arg_Is_Identifier (Arg2);
18380 -- First argument is identifier
18382 if Nkind (Arg1X) = N_Identifier then
18384 -- Search list of names in Ada.Interrupts.Names
18386 Int_Ent := First_Entity (RTE (RE_Names));
18388 if No (Int_Ent) then
18389 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18391 elsif Chars (Int_Ent) = Chars (Arg1X) then
18392 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18396 Next_Entity (Int_Ent);
18399 -- First argument is not an identifier, so it must be a static
18400 -- expression of type Ada.Interrupts.Interrupt_ID.
18403 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18404 Int_Val := Expr_Value (Arg1X);
18406 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18408 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18411 ("value not in range of type "
18412 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18418 case Chars (Get_Pragma_Arg (Arg2)) is
18419 when Name_Runtime => State_Type := 'r';
18420 when Name_System => State_Type := 's';
18421 when Name_User => State_Type := 'u';
18424 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18427 -- Check if entry is already stored
18429 IST_Num := Interrupt_States.First;
18431 -- If entry not found, add it
18433 if IST_Num > Interrupt_States.Last then
18434 Interrupt_States.Append
18435 ((Interrupt_Number => UI_To_Int (Int_Val),
18436 Interrupt_State => State_Type,
18437 Pragma_Loc => Loc));
18440 -- Case of entry for the same entry
18442 elsif Int_Val = Interrupt_States.Table (IST_Num).
18445 -- If state matches, done, no need to make redundant entry
18448 State_Type = Interrupt_States.Table (IST_Num).
18451 -- Otherwise if state does not match, error
18454 Interrupt_States.Table (IST_Num).Pragma_Loc;
18456 ("state conflicts with that given #", Arg2);
18460 IST_Num := IST_Num + 1;
18462 end Interrupt_State;
18468 -- pragma Invariant
18469 -- ([Entity =>] type_LOCAL_NAME,
18470 -- [Check =>] EXPRESSION
18471 -- [,[Message =>] String_Expression]);
18473 when Pragma_Invariant => Invariant : declare
18480 Check_At_Least_N_Arguments (2);
18481 Check_At_Most_N_Arguments (3);
18482 Check_Optional_Identifier (Arg1, Name_Entity);
18483 Check_Optional_Identifier (Arg2, Name_Check);
18485 if Arg_Count = 3 then
18486 Check_Optional_Identifier (Arg3, Name_Message);
18487 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18490 Check_Arg_Is_Local_Name (Arg1);
18492 Typ_Arg := Get_Pragma_Arg (Arg1);
18493 Find_Type (Typ_Arg);
18494 Typ := Entity (Typ_Arg);
18496 -- Nothing to do of the related type is erroneous in some way
18498 if Typ = Any_Type then
18501 -- AI12-0041: Invariants are allowed in interface types
18503 elsif Is_Interface (Typ) then
18506 -- An invariant must apply to a private type, or appear in the
18507 -- private part of a package spec and apply to a completion.
18508 -- a class-wide invariant can only appear on a private declaration
18509 -- or private extension, not a completion.
18511 -- A [class-wide] invariant may be associated a [limited] private
18512 -- type or a private extension.
18514 elsif Ekind (Typ) in E_Limited_Private_Type
18516 | E_Record_Type_With_Private
18520 -- A non-class-wide invariant may be associated with the full view
18521 -- of a [limited] private type or a private extension.
18523 elsif Has_Private_Declaration (Typ)
18524 and then not Class_Present (N)
18528 -- A class-wide invariant may appear on the partial view only
18530 elsif Class_Present (N) then
18532 ("pragma % only allowed for private type", Arg1);
18535 -- A regular invariant may appear on both views
18539 ("pragma % only allowed for private type or corresponding "
18540 & "full view", Arg1);
18544 -- An invariant associated with an abstract type (this includes
18545 -- interfaces) must be class-wide.
18547 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18549 ("pragma % not allowed for abstract type", Arg1);
18553 -- A pragma that applies to a Ghost entity becomes Ghost for the
18554 -- purposes of legality checks and removal of ignored Ghost code.
18556 Mark_Ghost_Pragma (N, Typ);
18558 -- The pragma defines a type-specific invariant, the type is said
18559 -- to have invariants of its "own".
18561 Set_Has_Own_Invariants (Base_Type (Typ));
18563 -- If the invariant is class-wide, then it can be inherited by
18564 -- derived or interface implementing types. The type is said to
18565 -- have "inheritable" invariants.
18567 if Class_Present (N) then
18568 Set_Has_Inheritable_Invariants (Typ);
18571 -- Chain the pragma on to the rep item chain, for processing when
18572 -- the type is frozen.
18574 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18576 -- Create the declaration of the invariant procedure that will
18577 -- verify the invariant at run time. Interfaces are treated as the
18578 -- partial view of a private type in order to achieve uniformity
18579 -- with the general case. As a result, an interface receives only
18580 -- a "partial" invariant procedure, which is never called.
18582 Build_Invariant_Procedure_Declaration
18584 Partial_Invariant => Is_Interface (Typ));
18591 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18593 when Pragma_Keep_Names => Keep_Names : declare
18598 Check_Arg_Count (1);
18599 Check_Optional_Identifier (Arg1, Name_On);
18600 Check_Arg_Is_Local_Name (Arg1);
18602 Arg := Get_Pragma_Arg (Arg1);
18605 if Etype (Arg) = Any_Type then
18609 if not Is_Entity_Name (Arg)
18610 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18613 ("pragma% requires a local enumeration type", Arg1);
18616 Set_Discard_Names (Entity (Arg), False);
18623 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18625 when Pragma_License =>
18628 -- Do not analyze pragma any further in CodePeer mode, to avoid
18629 -- extraneous errors in this implementation-dependent pragma,
18630 -- which has a different profile on other compilers.
18632 if CodePeer_Mode then
18636 Check_Arg_Count (1);
18637 Check_No_Identifiers;
18638 Check_Valid_Configuration_Pragma;
18639 Check_Arg_Is_Identifier (Arg1);
18642 Sind : constant Source_File_Index :=
18643 Source_Index (Current_Sem_Unit);
18646 case Chars (Get_Pragma_Arg (Arg1)) is
18648 Set_License (Sind, GPL);
18650 when Name_Modified_GPL =>
18651 Set_License (Sind, Modified_GPL);
18653 when Name_Restricted =>
18654 Set_License (Sind, Restricted);
18656 when Name_Unrestricted =>
18657 Set_License (Sind, Unrestricted);
18660 Error_Pragma_Arg ("invalid license name", Arg1);
18668 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18670 when Pragma_Link_With => Link_With : declare
18676 if Operating_Mode = Generate_Code
18677 and then In_Extended_Main_Source_Unit (N)
18679 Check_At_Least_N_Arguments (1);
18680 Check_No_Identifiers;
18681 Check_Is_In_Decl_Part_Or_Package_Spec;
18682 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18686 while Present (Arg) loop
18687 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18689 -- Store argument, converting sequences of spaces to a
18690 -- single null character (this is one of the differences
18691 -- in processing between Link_With and Linker_Options).
18693 Arg_Store : declare
18694 C : constant Char_Code := Get_Char_Code (' ');
18695 S : constant String_Id :=
18696 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18697 L : constant Nat := String_Length (S);
18700 procedure Skip_Spaces;
18701 -- Advance F past any spaces
18707 procedure Skip_Spaces is
18709 while F <= L and then Get_String_Char (S, F) = C loop
18714 -- Start of processing for Arg_Store
18717 Skip_Spaces; -- skip leading spaces
18719 -- Loop through characters, changing any embedded
18720 -- sequence of spaces to a single null character (this
18721 -- is how Link_With/Linker_Options differ)
18724 if Get_String_Char (S, F) = C then
18727 Store_String_Char (ASCII.NUL);
18730 Store_String_Char (Get_String_Char (S, F));
18738 if Present (Arg) then
18739 Store_String_Char (ASCII.NUL);
18743 Store_Linker_Option_String (End_String);
18751 -- pragma Linker_Alias (
18752 -- [Entity =>] LOCAL_NAME
18753 -- [Target =>] static_string_EXPRESSION);
18755 when Pragma_Linker_Alias =>
18757 Check_Arg_Order ((Name_Entity, Name_Target));
18758 Check_Arg_Count (2);
18759 Check_Optional_Identifier (Arg1, Name_Entity);
18760 Check_Optional_Identifier (Arg2, Name_Target);
18761 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18762 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18764 -- The only processing required is to link this item on to the
18765 -- list of rep items for the given entity. This is accomplished
18766 -- by the call to Rep_Item_Too_Late (when no error is detected
18767 -- and False is returned).
18769 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18772 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18775 ------------------------
18776 -- Linker_Constructor --
18777 ------------------------
18779 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18781 -- Code is shared with Linker_Destructor
18783 -----------------------
18784 -- Linker_Destructor --
18785 -----------------------
18787 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18789 when Pragma_Linker_Constructor
18790 | Pragma_Linker_Destructor
18792 Linker_Constructor : declare
18798 Check_Arg_Count (1);
18799 Check_No_Identifiers;
18800 Check_Arg_Is_Local_Name (Arg1);
18801 Arg1_X := Get_Pragma_Arg (Arg1);
18803 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18805 if not Is_Library_Level_Entity (Proc) then
18807 ("argument for pragma% must be library level entity", Arg1);
18810 -- The only processing required is to link this item on to the
18811 -- list of rep items for the given entity. This is accomplished
18812 -- by the call to Rep_Item_Too_Late (when no error is detected
18813 -- and False is returned).
18815 if Rep_Item_Too_Late (Proc, N) then
18818 Set_Has_Gigi_Rep_Item (Proc);
18820 end Linker_Constructor;
18822 --------------------
18823 -- Linker_Options --
18824 --------------------
18826 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18828 when Pragma_Linker_Options => Linker_Options : declare
18832 Check_Ada_83_Warning;
18833 Check_No_Identifiers;
18834 Check_Arg_Count (1);
18835 Check_Is_In_Decl_Part_Or_Package_Spec;
18836 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18837 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18840 while Present (Arg) loop
18841 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18842 Store_String_Char (ASCII.NUL);
18844 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18848 if Operating_Mode = Generate_Code
18849 and then In_Extended_Main_Source_Unit (N)
18851 Store_Linker_Option_String (End_String);
18853 end Linker_Options;
18855 --------------------
18856 -- Linker_Section --
18857 --------------------
18859 -- pragma Linker_Section (
18860 -- [Entity =>] LOCAL_NAME
18861 -- [Section =>] static_string_EXPRESSION);
18863 when Pragma_Linker_Section => Linker_Section : declare
18868 Ghost_Error_Posted : Boolean := False;
18869 -- Flag set when an error concerning the illegal mix of Ghost and
18870 -- non-Ghost subprograms is emitted.
18872 Ghost_Id : Entity_Id := Empty;
18873 -- The entity of the first Ghost subprogram encountered while
18874 -- processing the arguments of the pragma.
18878 Check_Arg_Order ((Name_Entity, Name_Section));
18879 Check_Arg_Count (2);
18880 Check_Optional_Identifier (Arg1, Name_Entity);
18881 Check_Optional_Identifier (Arg2, Name_Section);
18882 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18883 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18885 -- Check kind of entity
18887 Arg := Get_Pragma_Arg (Arg1);
18888 Ent := Entity (Arg);
18890 case Ekind (Ent) is
18892 -- Objects (constants and variables) and types. For these cases
18893 -- all we need to do is to set the Linker_Section_pragma field,
18894 -- checking that we do not have a duplicate.
18900 LPE := Linker_Section_Pragma (Ent);
18902 if Present (LPE) then
18903 Error_Msg_Sloc := Sloc (LPE);
18905 ("Linker_Section already specified for &#", Arg1, Ent);
18908 Set_Linker_Section_Pragma (Ent, N);
18910 -- A pragma that applies to a Ghost entity becomes Ghost for
18911 -- the purposes of legality checks and removal of ignored
18914 Mark_Ghost_Pragma (N, Ent);
18918 when Subprogram_Kind =>
18920 -- Aspect case, entity already set
18922 if From_Aspect_Specification (N) then
18923 Set_Linker_Section_Pragma
18924 (Entity (Corresponding_Aspect (N)), N);
18926 -- Propagate it to its ultimate aliased entity to
18927 -- facilitate the backend processing this attribute
18928 -- in instantiations of generic subprograms.
18930 if Present (Alias (Entity (Corresponding_Aspect (N))))
18932 Set_Linker_Section_Pragma
18934 (Entity (Corresponding_Aspect (N))), N);
18937 -- Pragma case, we must climb the homonym chain, but skip
18938 -- any for which the linker section is already set.
18942 if No (Linker_Section_Pragma (Ent)) then
18943 Set_Linker_Section_Pragma (Ent, N);
18945 -- Propagate it to its ultimate aliased entity to
18946 -- facilitate the backend processing this attribute
18947 -- in instantiations of generic subprograms.
18949 if Present (Alias (Ent)) then
18950 Set_Linker_Section_Pragma
18951 (Ultimate_Alias (Ent), N);
18954 -- A pragma that applies to a Ghost entity becomes
18955 -- Ghost for the purposes of legality checks and
18956 -- removal of ignored Ghost code.
18958 Mark_Ghost_Pragma (N, Ent);
18960 -- Capture the entity of the first Ghost subprogram
18961 -- being processed for error detection purposes.
18963 if Is_Ghost_Entity (Ent) then
18964 if No (Ghost_Id) then
18968 -- Otherwise the subprogram is non-Ghost. It is
18969 -- illegal to mix references to Ghost and non-Ghost
18970 -- entities (SPARK RM 6.9).
18972 elsif Present (Ghost_Id)
18973 and then not Ghost_Error_Posted
18975 Ghost_Error_Posted := True;
18977 Error_Msg_Name_1 := Pname;
18979 ("pragma % cannot mention ghost and "
18980 & "non-ghost subprograms", N);
18982 Error_Msg_Sloc := Sloc (Ghost_Id);
18984 ("\& # declared as ghost", N, Ghost_Id);
18986 Error_Msg_Sloc := Sloc (Ent);
18988 ("\& # declared as non-ghost", N, Ent);
18992 Ent := Homonym (Ent);
18994 or else Scope (Ent) /= Current_Scope;
18998 -- All other cases are illegal
19002 ("pragma% applies only to objects, subprograms, and types",
19005 end Linker_Section;
19011 -- pragma List (On | Off)
19013 -- There is nothing to do here, since we did all the processing for
19014 -- this pragma in Par.Prag (so that it works properly even in syntax
19017 when Pragma_List =>
19024 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19026 when Pragma_Lock_Free => Lock_Free : declare
19027 P : constant Node_Id := Parent (N);
19033 Check_No_Identifiers;
19034 Check_At_Most_N_Arguments (1);
19036 -- Protected definition case
19038 if Nkind (P) = N_Protected_Definition then
19039 Ent := Defining_Identifier (Parent (P));
19043 if Arg_Count = 1 then
19044 Arg := Get_Pragma_Arg (Arg1);
19045 Val := Is_True (Static_Boolean (Arg));
19047 -- No arguments (expression is considered to be True)
19053 -- Check duplicate pragma before we chain the pragma in the Rep
19054 -- Item chain of Ent.
19056 Check_Duplicate_Pragma (Ent);
19057 Record_Rep_Item (Ent, N);
19058 Set_Uses_Lock_Free (Ent, Val);
19060 -- Anything else is incorrect placement
19067 --------------------
19068 -- Locking_Policy --
19069 --------------------
19071 -- pragma Locking_Policy (policy_IDENTIFIER);
19073 when Pragma_Locking_Policy => declare
19074 subtype LP_Range is Name_Id
19075 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19080 Check_Ada_83_Warning;
19081 Check_Arg_Count (1);
19082 Check_No_Identifiers;
19083 Check_Arg_Is_Locking_Policy (Arg1);
19084 Check_Valid_Configuration_Pragma;
19085 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19088 when Name_Ceiling_Locking => LP := 'C';
19089 when Name_Concurrent_Readers_Locking => LP := 'R';
19090 when Name_Inheritance_Locking => LP := 'I';
19093 if Locking_Policy /= ' '
19094 and then Locking_Policy /= LP
19096 Error_Msg_Sloc := Locking_Policy_Sloc;
19097 Error_Pragma ("locking policy incompatible with policy#");
19099 -- Set new policy, but always preserve System_Location since we
19100 -- like the error message with the run time name.
19103 Locking_Policy := LP;
19105 if Locking_Policy_Sloc /= System_Location then
19106 Locking_Policy_Sloc := Loc;
19111 -------------------
19112 -- Loop_Optimize --
19113 -------------------
19115 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19117 -- OPTIMIZATION_HINT ::=
19118 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19120 when Pragma_Loop_Optimize => Loop_Optimize : declare
19125 Check_At_Least_N_Arguments (1);
19126 Check_No_Identifiers;
19128 Hint := First (Pragma_Argument_Associations (N));
19129 while Present (Hint) loop
19130 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19138 Check_Loop_Pragma_Placement;
19145 -- pragma Loop_Variant
19146 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19148 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19150 -- CHANGE_DIRECTION ::= Increases | Decreases
19152 when Pragma_Loop_Variant => Loop_Variant : declare
19157 Check_At_Least_N_Arguments (1);
19158 Check_Loop_Pragma_Placement;
19160 -- Process all increasing / decreasing expressions
19162 Variant := First (Pragma_Argument_Associations (N));
19163 while Present (Variant) loop
19164 if Chars (Variant) = No_Name then
19165 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19167 elsif Chars (Variant) not in Name_Decreases | Name_Increases
19170 Name : String := Get_Name_String (Chars (Variant));
19173 -- It is a common mistake to write "Increasing" for
19174 -- "Increases" or "Decreasing" for "Decreases". Recognize
19175 -- specially names starting with "incr" or "decr" to
19176 -- suggest the corresponding name.
19178 System.Case_Util.To_Lower (Name);
19180 if Name'Length >= 4
19181 and then Name (1 .. 4) = "incr"
19183 Error_Pragma_Arg_Ident
19184 ("expect name `Increases`", Variant);
19186 elsif Name'Length >= 4
19187 and then Name (1 .. 4) = "decr"
19189 Error_Pragma_Arg_Ident
19190 ("expect name `Decreases`", Variant);
19193 Error_Pragma_Arg_Ident
19194 ("expect name `Increases` or `Decreases`", Variant);
19199 Preanalyze_Assert_Expression
19200 (Expression (Variant), Any_Discrete);
19206 -----------------------
19207 -- Machine_Attribute --
19208 -----------------------
19210 -- pragma Machine_Attribute (
19211 -- [Entity =>] LOCAL_NAME,
19212 -- [Attribute_Name =>] static_string_EXPRESSION
19213 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19215 when Pragma_Machine_Attribute => Machine_Attribute : declare
19217 Def_Id : Entity_Id;
19221 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19223 if Arg_Count >= 3 then
19224 Check_Optional_Identifier (Arg3, Name_Info);
19226 while Present (Arg) loop
19227 Check_Arg_Is_OK_Static_Expression (Arg);
19231 Check_Arg_Count (2);
19234 Check_Optional_Identifier (Arg1, Name_Entity);
19235 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19236 Check_Arg_Is_Local_Name (Arg1);
19237 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19238 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19240 if Is_Access_Type (Def_Id) then
19241 Def_Id := Designated_Type (Def_Id);
19244 if Rep_Item_Too_Early (Def_Id, N) then
19248 Def_Id := Underlying_Type (Def_Id);
19250 -- The only processing required is to link this item on to the
19251 -- list of rep items for the given entity. This is accomplished
19252 -- by the call to Rep_Item_Too_Late (when no error is detected
19253 -- and False is returned).
19255 if Rep_Item_Too_Late (Def_Id, N) then
19258 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19260 end Machine_Attribute;
19267 -- (MAIN_OPTION [, MAIN_OPTION]);
19270 -- [STACK_SIZE =>] static_integer_EXPRESSION
19271 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19272 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19274 when Pragma_Main => Main : declare
19275 Args : Args_List (1 .. 3);
19276 Names : constant Name_List (1 .. 3) := (
19278 Name_Task_Stack_Size_Default,
19279 Name_Time_Slicing_Enabled);
19285 Gather_Associations (Names, Args);
19287 for J in 1 .. 2 loop
19288 if Present (Args (J)) then
19289 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19293 if Present (Args (3)) then
19294 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19298 while Present (Nod) loop
19299 if Nkind (Nod) = N_Pragma
19300 and then Pragma_Name (Nod) = Name_Main
19302 Error_Msg_Name_1 := Pname;
19303 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19314 -- pragma Main_Storage
19315 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19317 -- MAIN_STORAGE_OPTION ::=
19318 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19319 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19321 when Pragma_Main_Storage => Main_Storage : declare
19322 Args : Args_List (1 .. 2);
19323 Names : constant Name_List (1 .. 2) := (
19324 Name_Working_Storage,
19331 Gather_Associations (Names, Args);
19333 for J in 1 .. 2 loop
19334 if Present (Args (J)) then
19335 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19339 Check_In_Main_Program;
19342 while Present (Nod) loop
19343 if Nkind (Nod) = N_Pragma
19344 and then Pragma_Name (Nod) = Name_Main_Storage
19346 Error_Msg_Name_1 := Pname;
19347 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19354 ----------------------------
19355 -- Max_Entry_Queue_Length --
19356 ----------------------------
19358 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19360 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19361 -- Pragma_Max_Queue_Length.
19363 when Pragma_Max_Entry_Queue_Length
19364 | Pragma_Max_Entry_Queue_Depth
19365 | Pragma_Max_Queue_Length
19367 Max_Entry_Queue_Length : declare
19369 Entry_Decl : Node_Id;
19370 Entry_Id : Entity_Id;
19374 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19375 or else Prag_Id = Pragma_Max_Queue_Length
19380 Check_Arg_Count (1);
19383 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19385 -- Entry declaration
19387 if Nkind (Entry_Decl) = N_Entry_Declaration then
19389 -- Entry illegally within a task
19391 if Nkind (Parent (N)) = N_Task_Definition then
19392 Error_Pragma ("pragma % cannot apply to task entries");
19396 Entry_Id := Defining_Entity (Entry_Decl);
19398 -- Otherwise the pragma is associated with an illegal construct
19402 ("pragma % must apply to a protected entry declaration");
19406 -- Mark the pragma as Ghost if the related subprogram is also
19407 -- Ghost. This also ensures that any expansion performed further
19408 -- below will produce Ghost nodes.
19410 Mark_Ghost_Pragma (N, Entry_Id);
19412 -- Analyze the Integer expression
19414 Arg := Get_Pragma_Arg (Arg1);
19415 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19417 Val := Expr_Value (Arg);
19421 ("argument for pragma% cannot be less than -1", Arg1);
19423 elsif not UI_Is_In_Int_Range (Val) then
19425 ("argument for pragma% out of range of Integer", Arg1);
19429 Record_Rep_Item (Entry_Id, N);
19430 end Max_Entry_Queue_Length;
19436 -- pragma Memory_Size (NUMERIC_LITERAL)
19438 when Pragma_Memory_Size =>
19441 -- Memory size is simply ignored
19443 Check_No_Identifiers;
19444 Check_Arg_Count (1);
19445 Check_Arg_Is_Integer_Literal (Arg1);
19453 -- The only correct use of this pragma is on its own in a file, in
19454 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19455 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19456 -- check for a file containing nothing but a No_Body pragma). If we
19457 -- attempt to process it during normal semantics processing, it means
19458 -- it was misplaced.
19460 when Pragma_No_Body =>
19464 -----------------------------
19465 -- No_Elaboration_Code_All --
19466 -----------------------------
19468 -- pragma No_Elaboration_Code_All;
19470 when Pragma_No_Elaboration_Code_All =>
19472 Check_Valid_Library_Unit_Pragma;
19474 -- Must appear for a spec or generic spec
19476 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
19477 N_Generic_Package_Declaration |
19478 N_Generic_Subprogram_Declaration |
19479 N_Package_Declaration |
19480 N_Subprogram_Declaration
19484 ("pragma% can only occur for package "
19485 & "or subprogram spec"));
19488 -- Set flag in unit table
19490 Set_No_Elab_Code_All (Current_Sem_Unit);
19492 -- Set restriction No_Elaboration_Code if this is the main unit
19494 if Current_Sem_Unit = Main_Unit then
19495 Set_Restriction (No_Elaboration_Code, N);
19498 -- If we are in the main unit or in an extended main source unit,
19499 -- then we also add it to the configuration restrictions so that
19500 -- it will apply to all units in the extended main source.
19502 if Current_Sem_Unit = Main_Unit
19503 or else In_Extended_Main_Source_Unit (N)
19505 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19508 -- If in main extended unit, activate transitive with test
19510 if In_Extended_Main_Source_Unit (N) then
19511 Opt.No_Elab_Code_All_Pragma := N;
19514 -----------------------------
19515 -- No_Component_Reordering --
19516 -----------------------------
19518 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19520 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19526 Check_At_Most_N_Arguments (1);
19528 if Arg_Count = 0 then
19529 Check_Valid_Configuration_Pragma;
19530 Opt.No_Component_Reordering := True;
19533 Check_Optional_Identifier (Arg2, Name_Entity);
19534 Check_Arg_Is_Local_Name (Arg1);
19535 E_Id := Get_Pragma_Arg (Arg1);
19537 if Etype (E_Id) = Any_Type then
19541 E := Entity (E_Id);
19543 if not Is_Record_Type (E) then
19544 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19547 Set_No_Reordering (Base_Type (E));
19549 end No_Comp_Reordering;
19551 --------------------------
19552 -- No_Heap_Finalization --
19553 --------------------------
19555 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19557 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19558 Context : constant Node_Id := Parent (N);
19559 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19565 Check_No_Identifiers;
19567 -- The pragma appears in a configuration file
19569 if No (Context) then
19570 Check_Arg_Count (0);
19571 Check_Valid_Configuration_Pragma;
19573 -- Detect a duplicate pragma
19575 if Present (No_Heap_Finalization_Pragma) then
19578 Prev => No_Heap_Finalization_Pragma);
19582 No_Heap_Finalization_Pragma := N;
19584 -- Otherwise the pragma should be associated with a library-level
19585 -- named access-to-object type.
19588 Check_Arg_Count (1);
19589 Check_Arg_Is_Local_Name (Arg1);
19591 Find_Type (Typ_Arg);
19592 Typ := Entity (Typ_Arg);
19594 -- The type being subjected to the pragma is erroneous
19596 if Typ = Any_Type then
19597 Error_Pragma ("cannot find type referenced by pragma %");
19599 -- The pragma is applied to an incomplete or generic formal
19600 -- type way too early.
19602 elsif Rep_Item_Too_Early (Typ, N) then
19606 Typ := Underlying_Type (Typ);
19609 -- The pragma must apply to an access-to-object type
19611 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
19614 -- Give a detailed error message on all other access type kinds
19616 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19618 ("pragma % cannot apply to access protected subprogram "
19621 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19623 ("pragma % cannot apply to access subprogram type");
19625 elsif Is_Anonymous_Access_Type (Typ) then
19627 ("pragma % cannot apply to anonymous access type");
19629 -- Give a general error message in case the pragma applies to a
19630 -- non-access type.
19634 ("pragma % must apply to library level access type");
19637 -- At this point the argument denotes an access-to-object type.
19638 -- Ensure that the type is declared at the library level.
19640 if Is_Library_Level_Entity (Typ) then
19643 -- Quietly ignore an access-to-object type originally declared
19644 -- at the library level within a generic, but instantiated at
19645 -- a non-library level. As a result the access-to-object type
19646 -- "loses" its No_Heap_Finalization property.
19648 elsif In_Instance then
19653 ("pragma % must apply to library level access type");
19656 -- Detect a duplicate pragma
19658 if Present (No_Heap_Finalization_Pragma) then
19661 Prev => No_Heap_Finalization_Pragma);
19665 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19667 if Present (Prev) then
19675 Record_Rep_Item (Typ, N);
19677 end No_Heap_Finalization;
19683 -- pragma No_Inline ( NAME {, NAME} );
19685 when Pragma_No_Inline =>
19687 Process_Inline (Suppressed);
19693 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19695 when Pragma_No_Return => Prag_No_Return : declare
19697 function Check_No_Return
19699 N : Node_Id) return Boolean;
19700 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
19701 -- emit an error message and return False, otherwise return True.
19702 -- 6.5.1 Nonreturning procedures:
19703 -- 4/3 "Aspect No_Return shall not be specified for a null
19704 -- procedure nor an instance of a generic unit."
19706 ---------------------
19707 -- Check_No_Return --
19708 ---------------------
19710 function Check_No_Return
19712 N : Node_Id) return Boolean
19715 if Ekind (E) = E_Procedure then
19717 -- If E is a generic instance, marking it with No_Return
19718 -- is forbidden, but having it inherit the No_Return of
19719 -- the generic is allowed. We check if E is inheriting its
19720 -- No_Return flag from the generic by checking if No_Return
19723 if Is_Generic_Instance (E) and then not No_Return (E) then
19725 ("generic instance & is marked as No_Return", N, E);
19727 ("\generic procedure & must be marked No_Return",
19729 Generic_Parent (Parent (E)));
19732 elsif Null_Present (Subprogram_Specification (E)) then
19734 ("null procedure & cannot be marked No_Return", N, E);
19740 end Check_No_Return;
19747 Ghost_Error_Posted : Boolean := False;
19748 -- Flag set when an error concerning the illegal mix of Ghost and
19749 -- non-Ghost subprograms is emitted.
19751 Ghost_Id : Entity_Id := Empty;
19752 -- The entity of the first Ghost procedure encountered while
19753 -- processing the arguments of the pragma.
19757 Check_At_Least_N_Arguments (1);
19759 -- Loop through arguments of pragma
19762 while Present (Arg) loop
19763 Check_Arg_Is_Local_Name (Arg);
19764 Id := Get_Pragma_Arg (Arg);
19767 if not Is_Entity_Name (Id) then
19768 Error_Pragma_Arg ("entity name required", Arg);
19771 if Etype (Id) = Any_Type then
19775 -- Loop to find matching procedures or functions (Ada 2020)
19781 and then Scope (E) = Current_Scope
19783 -- Ada 2020 (AI12-0269): A function can be No_Return
19785 if Ekind (E) in E_Generic_Procedure | E_Procedure
19786 or else (Ada_Version >= Ada_2020
19788 Ekind (E) in E_Generic_Function | E_Function)
19790 -- Check that the pragma is not applied to a body.
19791 -- First check the specless body case, to give a
19792 -- different error message. These checks do not apply
19793 -- if Relaxed_RM_Semantics, to accommodate other Ada
19794 -- compilers. Disable these checks under -gnatd.J.
19796 if not Debug_Flag_Dot_JJ then
19797 if Nkind (Parent (Declaration_Node (E))) =
19799 and then not Relaxed_RM_Semantics
19802 ("pragma% requires separate spec and must come "
19806 -- Now the "specful" body case
19808 if Rep_Item_Too_Late (E, N) then
19813 if Check_No_Return (E, N) then
19817 -- A pragma that applies to a Ghost entity becomes Ghost
19818 -- for the purposes of legality checks and removal of
19819 -- ignored Ghost code.
19821 Mark_Ghost_Pragma (N, E);
19823 -- Capture the entity of the first Ghost procedure being
19824 -- processed for error detection purposes.
19826 if Is_Ghost_Entity (E) then
19827 if No (Ghost_Id) then
19831 -- Otherwise the subprogram is non-Ghost. It is illegal
19832 -- to mix references to Ghost and non-Ghost entities
19835 elsif Present (Ghost_Id)
19836 and then not Ghost_Error_Posted
19838 Ghost_Error_Posted := True;
19840 Error_Msg_Name_1 := Pname;
19842 ("pragma % cannot mention ghost and non-ghost "
19843 & "procedures", N);
19845 Error_Msg_Sloc := Sloc (Ghost_Id);
19846 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19848 Error_Msg_Sloc := Sloc (E);
19849 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19852 -- Set flag on any alias as well
19854 if Is_Overloadable (E)
19855 and then Present (Alias (E))
19856 and then Check_No_Return (Alias (E), N)
19858 Set_No_Return (Alias (E));
19864 exit when From_Aspect_Specification (N);
19868 -- If entity in not in current scope it may be the enclosing
19869 -- suprogram body to which the aspect applies.
19872 if Entity (Id) = Current_Scope
19873 and then From_Aspect_Specification (N)
19874 and then Check_No_Return (Entity (Id), N)
19876 Set_No_Return (Entity (Id));
19878 elsif Ada_Version >= Ada_2020 then
19880 ("no subprogram& found for pragma%", Arg);
19883 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19889 end Prag_No_Return;
19895 -- pragma No_Run_Time;
19897 -- Note: this pragma is retained for backwards compatibility. See
19898 -- body of Rtsfind for full details on its handling.
19900 when Pragma_No_Run_Time =>
19902 Check_Valid_Configuration_Pragma;
19903 Check_Arg_Count (0);
19905 -- Remove backward compatibility if Build_Type is FSF or GPL and
19906 -- generate a warning.
19909 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19912 Error_Pragma ("pragma% is ignored, has no effect??");
19914 No_Run_Time_Mode := True;
19915 Configurable_Run_Time_Mode := True;
19917 -- Set Duration to 32 bits if word size is 32
19919 if Ttypes.System_Word_Size = 32 then
19920 Duration_32_Bits_On_Target := True;
19923 -- Set appropriate restrictions
19925 Set_Restriction (No_Finalization, N);
19926 Set_Restriction (No_Exception_Handlers, N);
19927 Set_Restriction (Max_Tasks, N, 0);
19928 Set_Restriction (No_Tasking, N);
19932 -----------------------
19933 -- No_Tagged_Streams --
19934 -----------------------
19936 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19938 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19944 Check_At_Most_N_Arguments (1);
19946 -- One argument case
19948 if Arg_Count = 1 then
19949 Check_Optional_Identifier (Arg1, Name_Entity);
19950 Check_Arg_Is_Local_Name (Arg1);
19951 E_Id := Get_Pragma_Arg (Arg1);
19953 if Etype (E_Id) = Any_Type then
19957 E := Entity (E_Id);
19959 Check_Duplicate_Pragma (E);
19961 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19963 ("argument for pragma% must be root tagged type", Arg1);
19966 if Rep_Item_Too_Early (E, N)
19968 Rep_Item_Too_Late (E, N)
19972 Set_No_Tagged_Streams_Pragma (E, N);
19975 -- Zero argument case
19978 Check_Is_In_Decl_Part_Or_Package_Spec;
19979 No_Tagged_Streams := N;
19981 end No_Tagged_Strms;
19983 ------------------------
19984 -- No_Strict_Aliasing --
19985 ------------------------
19987 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19989 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
19995 Check_At_Most_N_Arguments (1);
19997 if Arg_Count = 0 then
19998 Check_Valid_Configuration_Pragma;
19999 Opt.No_Strict_Aliasing := True;
20002 Check_Optional_Identifier (Arg2, Name_Entity);
20003 Check_Arg_Is_Local_Name (Arg1);
20004 E_Id := Get_Pragma_Arg (Arg1);
20006 if Etype (E_Id) = Any_Type then
20010 E := Entity (E_Id);
20012 if not Is_Access_Type (E) then
20013 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20016 Set_No_Strict_Aliasing (Base_Type (E));
20018 end No_Strict_Aliasing;
20020 -----------------------
20021 -- Normalize_Scalars --
20022 -----------------------
20024 -- pragma Normalize_Scalars;
20026 when Pragma_Normalize_Scalars =>
20027 Check_Ada_83_Warning;
20028 Check_Arg_Count (0);
20029 Check_Valid_Configuration_Pragma;
20031 -- Normalize_Scalars creates false positives in CodePeer, and
20032 -- incorrect negative results in GNATprove mode, so ignore this
20033 -- pragma in these modes.
20035 if not (CodePeer_Mode or GNATprove_Mode) then
20036 Normalize_Scalars := True;
20037 Init_Or_Norm_Scalars := True;
20044 -- pragma Obsolescent;
20046 -- pragma Obsolescent (
20047 -- [Message =>] static_string_EXPRESSION
20048 -- [,[Version =>] Ada_05]]);
20050 -- pragma Obsolescent (
20051 -- [Entity =>] NAME
20052 -- [,[Message =>] static_string_EXPRESSION
20053 -- [,[Version =>] Ada_05]] );
20055 when Pragma_Obsolescent => Obsolescent : declare
20059 procedure Set_Obsolescent (E : Entity_Id);
20060 -- Given an entity Ent, mark it as obsolescent if appropriate
20062 ---------------------
20063 -- Set_Obsolescent --
20064 ---------------------
20066 procedure Set_Obsolescent (E : Entity_Id) is
20075 -- A pragma that applies to a Ghost entity becomes Ghost for
20076 -- the purposes of legality checks and removal of ignored Ghost
20079 Mark_Ghost_Pragma (N, E);
20081 -- Entity name was given
20083 if Present (Ename) then
20085 -- If entity name matches, we are fine.
20087 if Chars (Ename) = Chars (Ent) then
20088 Set_Entity (Ename, Ent);
20089 Generate_Reference (Ent, Ename);
20091 -- If entity name does not match, only possibility is an
20092 -- enumeration literal from an enumeration type declaration.
20094 elsif Ekind (Ent) /= E_Enumeration_Type then
20096 ("pragma % entity name does not match declaration");
20099 Ent := First_Literal (E);
20103 ("pragma % entity name does not match any "
20104 & "enumeration literal");
20106 elsif Chars (Ent) = Chars (Ename) then
20107 Set_Entity (Ename, Ent);
20108 Generate_Reference (Ent, Ename);
20112 Next_Literal (Ent);
20118 -- Ent points to entity to be marked
20120 if Arg_Count >= 1 then
20122 -- Deal with static string argument
20124 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20125 S := Strval (Get_Pragma_Arg (Arg1));
20127 for J in 1 .. String_Length (S) loop
20128 if not In_Character_Range (Get_String_Char (S, J)) then
20130 ("pragma% argument does not allow wide characters",
20135 Obsolescent_Warnings.Append
20136 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20138 -- Check for Ada_05 parameter
20140 if Arg_Count /= 1 then
20141 Check_Arg_Count (2);
20144 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20147 Check_Arg_Is_Identifier (Argx);
20149 if Chars (Argx) /= Name_Ada_05 then
20150 Error_Msg_Name_2 := Name_Ada_05;
20152 ("only allowed argument for pragma% is %", Argx);
20155 if Ada_Version_Explicit < Ada_2005
20156 or else not Warn_On_Ada_2005_Compatibility
20164 -- Set flag if pragma active
20167 Set_Is_Obsolescent (Ent);
20171 end Set_Obsolescent;
20173 -- Start of processing for pragma Obsolescent
20178 Check_At_Most_N_Arguments (3);
20180 -- See if first argument specifies an entity name
20184 (Chars (Arg1) = Name_Entity
20186 Nkind (Get_Pragma_Arg (Arg1)) in
20187 N_Character_Literal | N_Identifier | N_Operator_Symbol)
20189 Ename := Get_Pragma_Arg (Arg1);
20191 -- Eliminate first argument, so we can share processing
20195 Arg_Count := Arg_Count - 1;
20197 -- No Entity name argument given
20203 if Arg_Count >= 1 then
20204 Check_Optional_Identifier (Arg1, Name_Message);
20206 if Arg_Count = 2 then
20207 Check_Optional_Identifier (Arg2, Name_Version);
20211 -- Get immediately preceding declaration
20214 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20218 -- Cases where we do not follow anything other than another pragma
20222 -- First case: library level compilation unit declaration with
20223 -- the pragma immediately following the declaration.
20225 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20227 (Defining_Entity (Unit (Parent (Parent (N)))));
20230 -- Case 2: library unit placement for package
20234 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20236 if Is_Package_Or_Generic_Package (Ent) then
20237 Set_Obsolescent (Ent);
20243 -- Cases where we must follow a declaration, including an
20244 -- abstract subprogram declaration, which is not in the
20245 -- other node subtypes.
20248 if Nkind (Decl) not in N_Declaration
20249 and then Nkind (Decl) not in N_Later_Decl_Item
20250 and then Nkind (Decl) not in N_Generic_Declaration
20251 and then Nkind (Decl) not in N_Renaming_Declaration
20252 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20255 ("pragma% misplaced, "
20256 & "must immediately follow a declaration");
20259 Set_Obsolescent (Defining_Entity (Decl));
20269 -- pragma Optimize (Time | Space | Off);
20271 -- The actual check for optimize is done in Gigi. Note that this
20272 -- pragma does not actually change the optimization setting, it
20273 -- simply checks that it is consistent with the pragma.
20275 when Pragma_Optimize =>
20276 Check_No_Identifiers;
20277 Check_Arg_Count (1);
20278 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20280 ------------------------
20281 -- Optimize_Alignment --
20282 ------------------------
20284 -- pragma Optimize_Alignment (Time | Space | Off);
20286 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20288 Check_No_Identifiers;
20289 Check_Arg_Count (1);
20290 Check_Valid_Configuration_Pragma;
20293 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20296 when Name_Off => Opt.Optimize_Alignment := 'O';
20297 when Name_Space => Opt.Optimize_Alignment := 'S';
20298 when Name_Time => Opt.Optimize_Alignment := 'T';
20301 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20305 -- Set indication that mode is set locally. If we are in fact in a
20306 -- configuration pragma file, this setting is harmless since the
20307 -- switch will get reset anyway at the start of each unit.
20309 Optimize_Alignment_Local := True;
20310 end Optimize_Alignment;
20316 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20318 when Pragma_Ordered => Ordered : declare
20319 Assoc : constant Node_Id := Arg1;
20325 Check_No_Identifiers;
20326 Check_Arg_Count (1);
20327 Check_Arg_Is_Local_Name (Arg1);
20329 Type_Id := Get_Pragma_Arg (Assoc);
20330 Find_Type (Type_Id);
20331 Typ := Entity (Type_Id);
20333 if Typ = Any_Type then
20336 Typ := Underlying_Type (Typ);
20339 if not Is_Enumeration_Type (Typ) then
20340 Error_Pragma ("pragma% must specify enumeration type");
20343 Check_First_Subtype (Arg1);
20344 Set_Has_Pragma_Ordered (Base_Type (Typ));
20347 -------------------
20348 -- Overflow_Mode --
20349 -------------------
20351 -- pragma Overflow_Mode
20352 -- ([General => ] MODE [, [Assertions => ] MODE]);
20354 -- MODE := STRICT | MINIMIZED | ELIMINATED
20356 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20357 -- since System.Bignums makes this assumption. This is true of nearly
20358 -- all (all?) targets.
20360 when Pragma_Overflow_Mode => Overflow_Mode : declare
20361 function Get_Overflow_Mode
20363 Arg : Node_Id) return Overflow_Mode_Type;
20364 -- Function to process one pragma argument, Arg. If an identifier
20365 -- is present, it must be Name. Mode type is returned if a valid
20366 -- argument exists, otherwise an error is signalled.
20368 -----------------------
20369 -- Get_Overflow_Mode --
20370 -----------------------
20372 function Get_Overflow_Mode
20374 Arg : Node_Id) return Overflow_Mode_Type
20376 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20379 Check_Optional_Identifier (Arg, Name);
20380 Check_Arg_Is_Identifier (Argx);
20382 if Chars (Argx) = Name_Strict then
20385 elsif Chars (Argx) = Name_Minimized then
20388 elsif Chars (Argx) = Name_Eliminated then
20389 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20391 ("Eliminated not implemented on this target", Argx);
20397 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20399 end Get_Overflow_Mode;
20401 -- Start of processing for Overflow_Mode
20405 Check_At_Least_N_Arguments (1);
20406 Check_At_Most_N_Arguments (2);
20408 -- Process first argument
20410 Scope_Suppress.Overflow_Mode_General :=
20411 Get_Overflow_Mode (Name_General, Arg1);
20413 -- Case of only one argument
20415 if Arg_Count = 1 then
20416 Scope_Suppress.Overflow_Mode_Assertions :=
20417 Scope_Suppress.Overflow_Mode_General;
20419 -- Case of two arguments present
20422 Scope_Suppress.Overflow_Mode_Assertions :=
20423 Get_Overflow_Mode (Name_Assertions, Arg2);
20427 --------------------------
20428 -- Overriding Renamings --
20429 --------------------------
20431 -- pragma Overriding_Renamings;
20433 when Pragma_Overriding_Renamings =>
20435 Check_Arg_Count (0);
20436 Check_Valid_Configuration_Pragma;
20437 Overriding_Renamings := True;
20443 -- pragma Pack (first_subtype_LOCAL_NAME);
20445 when Pragma_Pack => Pack : declare
20446 Assoc : constant Node_Id := Arg1;
20448 Ignore : Boolean := False;
20453 Check_No_Identifiers;
20454 Check_Arg_Count (1);
20455 Check_Arg_Is_Local_Name (Arg1);
20456 Type_Id := Get_Pragma_Arg (Assoc);
20458 if not Is_Entity_Name (Type_Id)
20459 or else not Is_Type (Entity (Type_Id))
20462 ("argument for pragma% must be type or subtype", Arg1);
20465 Find_Type (Type_Id);
20466 Typ := Entity (Type_Id);
20469 or else Rep_Item_Too_Early (Typ, N)
20473 Typ := Underlying_Type (Typ);
20476 -- A pragma that applies to a Ghost entity becomes Ghost for the
20477 -- purposes of legality checks and removal of ignored Ghost code.
20479 Mark_Ghost_Pragma (N, Typ);
20481 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20482 Error_Pragma ("pragma% must specify array or record type");
20485 Check_First_Subtype (Arg1);
20486 Check_Duplicate_Pragma (Typ);
20490 if Is_Array_Type (Typ) then
20491 Ctyp := Component_Type (Typ);
20493 -- Ignore pack that does nothing
20495 if Known_Static_Esize (Ctyp)
20496 and then Known_Static_RM_Size (Ctyp)
20497 and then Esize (Ctyp) = RM_Size (Ctyp)
20498 and then Addressable (Esize (Ctyp))
20503 -- Process OK pragma Pack. Note that if there is a separate
20504 -- component clause present, the Pack will be cancelled. This
20505 -- processing is in Freeze.
20507 if not Rep_Item_Too_Late (Typ, N) then
20509 -- In CodePeer mode, we do not need complex front-end
20510 -- expansions related to pragma Pack, so disable handling
20513 if CodePeer_Mode then
20516 -- Normal case where we do the pack action
20520 Set_Is_Packed (Base_Type (Typ));
20521 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20524 Set_Has_Pragma_Pack (Base_Type (Typ));
20528 -- For record types, the pack is always effective
20530 else pragma Assert (Is_Record_Type (Typ));
20531 if not Rep_Item_Too_Late (Typ, N) then
20532 Set_Is_Packed (Base_Type (Typ));
20533 Set_Has_Pragma_Pack (Base_Type (Typ));
20534 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20545 -- There is nothing to do here, since we did all the processing for
20546 -- this pragma in Par.Prag (so that it works properly even in syntax
20549 when Pragma_Page =>
20556 -- pragma Part_Of (ABSTRACT_STATE);
20558 -- ABSTRACT_STATE ::= NAME
20560 when Pragma_Part_Of => Part_Of : declare
20561 procedure Propagate_Part_Of
20562 (Pack_Id : Entity_Id;
20563 State_Id : Entity_Id;
20564 Instance : Node_Id);
20565 -- Propagate the Part_Of indicator to all abstract states and
20566 -- objects declared in the visible state space of a package
20567 -- denoted by Pack_Id. State_Id is the encapsulating state.
20568 -- Instance is the package instantiation node.
20570 -----------------------
20571 -- Propagate_Part_Of --
20572 -----------------------
20574 procedure Propagate_Part_Of
20575 (Pack_Id : Entity_Id;
20576 State_Id : Entity_Id;
20577 Instance : Node_Id)
20579 Has_Item : Boolean := False;
20580 -- Flag set when the visible state space contains at least one
20581 -- abstract state or variable.
20583 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20584 -- Propagate the Part_Of indicator to all abstract states and
20585 -- objects declared in the visible state space of a package
20586 -- denoted by Pack_Id.
20588 -----------------------
20589 -- Propagate_Part_Of --
20590 -----------------------
20592 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20593 Constits : Elist_Id;
20594 Item_Id : Entity_Id;
20597 -- Traverse the entity chain of the package and set relevant
20598 -- attributes of abstract states and objects declared in the
20599 -- visible state space of the package.
20601 Item_Id := First_Entity (Pack_Id);
20602 while Present (Item_Id)
20603 and then not In_Private_Part (Item_Id)
20605 -- Do not consider internally generated items
20607 if not Comes_From_Source (Item_Id) then
20610 -- Do not consider generic formals or their corresponding
20611 -- actuals because they are not part of a visible state.
20612 -- Note that both entities are marked as hidden.
20614 elsif Is_Hidden (Item_Id) then
20617 -- The Part_Of indicator turns an abstract state or an
20618 -- object into a constituent of the encapsulating state.
20619 -- Note that constants are considered here even though
20620 -- they may not depend on variable input. This check is
20621 -- left to the SPARK prover.
20623 elsif Ekind (Item_Id) in
20624 E_Abstract_State | E_Constant | E_Variable
20627 Constits := Part_Of_Constituents (State_Id);
20629 if No (Constits) then
20630 Constits := New_Elmt_List;
20631 Set_Part_Of_Constituents (State_Id, Constits);
20634 Append_Elmt (Item_Id, Constits);
20635 Set_Encapsulating_State (Item_Id, State_Id);
20637 -- Recursively handle nested packages and instantiations
20639 elsif Ekind (Item_Id) = E_Package then
20640 Propagate_Part_Of (Item_Id);
20643 Next_Entity (Item_Id);
20645 end Propagate_Part_Of;
20647 -- Start of processing for Propagate_Part_Of
20650 Propagate_Part_Of (Pack_Id);
20652 -- Detect a package instantiation that is subject to a Part_Of
20653 -- indicator, but has no visible state.
20655 if not Has_Item then
20657 ("package instantiation & has Part_Of indicator but "
20658 & "lacks visible state", Instance, Pack_Id);
20660 end Propagate_Part_Of;
20664 Constits : Elist_Id;
20666 Encap_Id : Entity_Id;
20667 Item_Id : Entity_Id;
20671 -- Start of processing for Part_Of
20675 Check_No_Identifiers;
20676 Check_Arg_Count (1);
20678 Stmt := Find_Related_Context (N, Do_Checks => True);
20680 -- Object declaration
20682 if Nkind (Stmt) = N_Object_Declaration then
20685 -- Package instantiation
20687 elsif Nkind (Stmt) = N_Package_Instantiation then
20690 -- Single concurrent type declaration
20692 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20695 -- Otherwise the pragma is associated with an illegal construct
20702 -- Extract the entity of the related object declaration or package
20703 -- instantiation. In the case of the instantiation, use the entity
20704 -- of the instance spec.
20706 if Nkind (Stmt) = N_Package_Instantiation then
20707 Stmt := Instance_Spec (Stmt);
20710 Item_Id := Defining_Entity (Stmt);
20712 -- A pragma that applies to a Ghost entity becomes Ghost for the
20713 -- purposes of legality checks and removal of ignored Ghost code.
20715 Mark_Ghost_Pragma (N, Item_Id);
20717 -- Chain the pragma on the contract for further processing by
20718 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20720 Add_Contract_Item (N, Item_Id);
20722 -- A variable may act as constituent of a single concurrent type
20723 -- which in turn could be declared after the variable. Due to this
20724 -- discrepancy, the full analysis of indicator Part_Of is delayed
20725 -- until the end of the enclosing declarative region (see routine
20726 -- Analyze_Part_Of_In_Decl_Part).
20728 if Ekind (Item_Id) = E_Variable then
20731 -- Otherwise indicator Part_Of applies to a constant or a package
20735 Encap := Get_Pragma_Arg (Arg1);
20737 -- Detect any discrepancies between the placement of the
20738 -- constant or package instantiation with respect to state
20739 -- space and the encapsulating state.
20743 Item_Id => Item_Id,
20745 Encap_Id => Encap_Id,
20749 pragma Assert (Present (Encap_Id));
20751 if Ekind (Item_Id) = E_Constant then
20752 Constits := Part_Of_Constituents (Encap_Id);
20754 if No (Constits) then
20755 Constits := New_Elmt_List;
20756 Set_Part_Of_Constituents (Encap_Id, Constits);
20759 Append_Elmt (Item_Id, Constits);
20760 Set_Encapsulating_State (Item_Id, Encap_Id);
20762 -- Propagate the Part_Of indicator to the visible state
20763 -- space of the package instantiation.
20767 (Pack_Id => Item_Id,
20768 State_Id => Encap_Id,
20775 ----------------------------------
20776 -- Partition_Elaboration_Policy --
20777 ----------------------------------
20779 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20781 when Pragma_Partition_Elaboration_Policy => PEP : declare
20782 subtype PEP_Range is Name_Id
20783 range First_Partition_Elaboration_Policy_Name
20784 .. Last_Partition_Elaboration_Policy_Name;
20785 PEP_Val : PEP_Range;
20790 Check_Arg_Count (1);
20791 Check_No_Identifiers;
20792 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20793 Check_Valid_Configuration_Pragma;
20794 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20797 when Name_Concurrent => PEP := 'C';
20798 when Name_Sequential => PEP := 'S';
20801 if Partition_Elaboration_Policy /= ' '
20802 and then Partition_Elaboration_Policy /= PEP
20804 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20806 ("partition elaboration policy incompatible with policy#");
20808 -- Set new policy, but always preserve System_Location since we
20809 -- like the error message with the run time name.
20812 Partition_Elaboration_Policy := PEP;
20814 if Partition_Elaboration_Policy_Sloc /= System_Location then
20815 Partition_Elaboration_Policy_Sloc := Loc;
20824 -- pragma Passive [(PASSIVE_FORM)];
20826 -- PASSIVE_FORM ::= Semaphore | No
20828 when Pragma_Passive =>
20831 if Nkind (Parent (N)) /= N_Task_Definition then
20832 Error_Pragma ("pragma% must be within task definition");
20835 if Arg_Count /= 0 then
20836 Check_Arg_Count (1);
20837 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20840 ----------------------------------
20841 -- Preelaborable_Initialization --
20842 ----------------------------------
20844 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20846 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20851 Check_Arg_Count (1);
20852 Check_No_Identifiers;
20853 Check_Arg_Is_Identifier (Arg1);
20854 Check_Arg_Is_Local_Name (Arg1);
20855 Check_First_Subtype (Arg1);
20856 Ent := Entity (Get_Pragma_Arg (Arg1));
20858 -- A pragma that applies to a Ghost entity becomes Ghost for the
20859 -- purposes of legality checks and removal of ignored Ghost code.
20861 Mark_Ghost_Pragma (N, Ent);
20863 -- The pragma may come from an aspect on a private declaration,
20864 -- even if the freeze point at which this is analyzed in the
20865 -- private part after the full view.
20867 if Has_Private_Declaration (Ent)
20868 and then From_Aspect_Specification (N)
20872 -- Check appropriate type argument
20874 elsif Is_Private_Type (Ent)
20875 or else Is_Protected_Type (Ent)
20876 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20878 -- AI05-0028: The pragma applies to all composite types. Note
20879 -- that we apply this binding interpretation to earlier versions
20880 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20881 -- choice since there are other compilers that do the same.
20883 or else Is_Composite_Type (Ent)
20889 ("pragma % can only be applied to private, formal derived, "
20890 & "protected, or composite type", Arg1);
20893 -- Give an error if the pragma is applied to a protected type that
20894 -- does not qualify (due to having entries, or due to components
20895 -- that do not qualify).
20897 if Is_Protected_Type (Ent)
20898 and then not Has_Preelaborable_Initialization (Ent)
20901 ("protected type & does not have preelaborable "
20902 & "initialization", Ent);
20904 -- Otherwise mark the type as definitely having preelaborable
20908 Set_Known_To_Have_Preelab_Init (Ent);
20911 if Has_Pragma_Preelab_Init (Ent)
20912 and then Warn_On_Redundant_Constructs
20914 Error_Pragma ("?r?duplicate pragma%!");
20916 Set_Has_Pragma_Preelab_Init (Ent);
20920 --------------------
20921 -- Persistent_BSS --
20922 --------------------
20924 -- pragma Persistent_BSS [(object_NAME)];
20926 when Pragma_Persistent_BSS => Persistent_BSS : declare
20933 Check_At_Most_N_Arguments (1);
20935 -- Case of application to specific object (one argument)
20937 if Arg_Count = 1 then
20938 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20940 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20942 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
20943 E_Variable | E_Constant
20945 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20948 Ent := Entity (Get_Pragma_Arg (Arg1));
20950 -- A pragma that applies to a Ghost entity becomes Ghost for
20951 -- the purposes of legality checks and removal of ignored Ghost
20954 Mark_Ghost_Pragma (N, Ent);
20956 -- Check for duplication before inserting in list of
20957 -- representation items.
20959 Check_Duplicate_Pragma (Ent);
20961 if Rep_Item_Too_Late (Ent, N) then
20965 Decl := Parent (Ent);
20967 if Present (Expression (Decl)) then
20968 -- Variables in Persistent_BSS cannot be initialized, so
20969 -- turn off any initialization that might be caused by
20970 -- pragmas Initialize_Scalars or Normalize_Scalars.
20972 if Kill_Range_Check (Expression (Decl)) then
20975 Name_Suppress_Initialization,
20976 Pragma_Argument_Associations => New_List (
20977 Make_Pragma_Argument_Association (Loc,
20978 Expression => New_Occurrence_Of (Ent, Loc))));
20979 Insert_Before (N, Prag);
20984 ("object for pragma% cannot have initialization", Arg1);
20988 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
20990 ("object type for pragma% is not potentially persistent",
20995 Make_Linker_Section_Pragma
20996 (Ent, Loc, ".persistent.bss");
20997 Insert_After (N, Prag);
21000 -- Case of use as configuration pragma with no arguments
21003 Check_Valid_Configuration_Pragma;
21004 Persistent_BSS_Mode := True;
21006 end Persistent_BSS;
21008 --------------------
21009 -- Rename_Pragma --
21010 --------------------
21012 -- pragma Rename_Pragma (
21013 -- [New_Name =>] IDENTIFIER,
21014 -- [Renamed =>] pragma_IDENTIFIER);
21016 when Pragma_Rename_Pragma => Rename_Pragma : declare
21017 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21018 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21022 Check_Valid_Configuration_Pragma;
21023 Check_Arg_Count (2);
21024 Check_Optional_Identifier (Arg1, Name_New_Name);
21025 Check_Optional_Identifier (Arg2, Name_Renamed);
21027 if Nkind (New_Name) /= N_Identifier then
21028 Error_Pragma_Arg ("identifier expected", Arg1);
21031 if Nkind (Old_Name) /= N_Identifier then
21032 Error_Pragma_Arg ("identifier expected", Arg2);
21035 -- The New_Name arg should not be an existing pragma (but we allow
21036 -- it; it's just a warning). The Old_Name arg must be an existing
21039 if Is_Pragma_Name (Chars (New_Name)) then
21040 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21043 if not Is_Pragma_Name (Chars (Old_Name)) then
21044 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21047 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21050 -----------------------------------
21051 -- Post/Post_Class/Postcondition --
21052 -----------------------------------
21054 -- pragma Post (Boolean_EXPRESSION);
21055 -- pragma Post_Class (Boolean_EXPRESSION);
21056 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21057 -- [,[Message =>] String_EXPRESSION]);
21059 -- Characteristics:
21061 -- * Analysis - The annotation undergoes initial checks to verify
21062 -- the legal placement and context. Secondary checks preanalyze the
21065 -- Analyze_Pre_Post_Condition_In_Decl_Part
21067 -- * Expansion - The annotation is expanded during the expansion of
21068 -- the related subprogram [body] contract as performed in:
21070 -- Expand_Subprogram_Contract
21072 -- * Template - The annotation utilizes the generic template of the
21073 -- related subprogram [body] when it is:
21075 -- aspect on subprogram declaration
21076 -- aspect on stand-alone subprogram body
21077 -- pragma on stand-alone subprogram body
21079 -- The annotation must prepare its own template when it is:
21081 -- pragma on subprogram declaration
21083 -- * Globals - Capture of global references must occur after full
21086 -- * Instance - The annotation is instantiated automatically when
21087 -- the related generic subprogram [body] is instantiated except for
21088 -- the "pragma on subprogram declaration" case. In that scenario
21089 -- the annotation must instantiate itself.
21092 | Pragma_Post_Class
21093 | Pragma_Postcondition
21095 Analyze_Pre_Post_Condition;
21097 --------------------------------
21098 -- Pre/Pre_Class/Precondition --
21099 --------------------------------
21101 -- pragma Pre (Boolean_EXPRESSION);
21102 -- pragma Pre_Class (Boolean_EXPRESSION);
21103 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21104 -- [,[Message =>] String_EXPRESSION]);
21106 -- Characteristics:
21108 -- * Analysis - The annotation undergoes initial checks to verify
21109 -- the legal placement and context. Secondary checks preanalyze the
21112 -- Analyze_Pre_Post_Condition_In_Decl_Part
21114 -- * Expansion - The annotation is expanded during the expansion of
21115 -- the related subprogram [body] contract as performed in:
21117 -- Expand_Subprogram_Contract
21119 -- * Template - The annotation utilizes the generic template of the
21120 -- related subprogram [body] when it is:
21122 -- aspect on subprogram declaration
21123 -- aspect on stand-alone subprogram body
21124 -- pragma on stand-alone subprogram body
21126 -- The annotation must prepare its own template when it is:
21128 -- pragma on subprogram declaration
21130 -- * Globals - Capture of global references must occur after full
21133 -- * Instance - The annotation is instantiated automatically when
21134 -- the related generic subprogram [body] is instantiated except for
21135 -- the "pragma on subprogram declaration" case. In that scenario
21136 -- the annotation must instantiate itself.
21140 | Pragma_Precondition
21142 Analyze_Pre_Post_Condition;
21148 -- pragma Predicate
21149 -- ([Entity =>] type_LOCAL_NAME,
21150 -- [Check =>] boolean_EXPRESSION);
21152 when Pragma_Predicate => Predicate : declare
21159 Check_Arg_Count (2);
21160 Check_Optional_Identifier (Arg1, Name_Entity);
21161 Check_Optional_Identifier (Arg2, Name_Check);
21163 Check_Arg_Is_Local_Name (Arg1);
21165 Type_Id := Get_Pragma_Arg (Arg1);
21166 Find_Type (Type_Id);
21167 Typ := Entity (Type_Id);
21169 if Typ = Any_Type then
21173 -- A pragma that applies to a Ghost entity becomes Ghost for the
21174 -- purposes of legality checks and removal of ignored Ghost code.
21176 Mark_Ghost_Pragma (N, Typ);
21178 -- The remaining processing is simply to link the pragma on to
21179 -- the rep item chain, for processing when the type is frozen.
21180 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21181 -- mark the type as having predicates.
21183 -- If the current policy for predicate checking is Ignore mark the
21184 -- subtype accordingly. In the case of predicates we consider them
21185 -- enabled unless Ignore is specified (either directly or with a
21186 -- general Assertion_Policy pragma) to preserve existing warnings.
21188 Set_Has_Predicates (Typ);
21190 -- Indicate that the pragma must be processed at the point the
21191 -- type is frozen, as is done for the corresponding aspect.
21193 Set_Has_Delayed_Aspects (Typ);
21194 Set_Has_Delayed_Freeze (Typ);
21196 Set_Predicates_Ignored (Typ,
21197 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21198 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21201 -----------------------
21202 -- Predicate_Failure --
21203 -----------------------
21205 -- pragma Predicate_Failure
21206 -- ([Entity =>] type_LOCAL_NAME,
21207 -- [Message =>] string_EXPRESSION);
21209 when Pragma_Predicate_Failure => Predicate_Failure : declare
21216 Check_Arg_Count (2);
21217 Check_Optional_Identifier (Arg1, Name_Entity);
21218 Check_Optional_Identifier (Arg2, Name_Message);
21220 Check_Arg_Is_Local_Name (Arg1);
21222 Type_Id := Get_Pragma_Arg (Arg1);
21223 Find_Type (Type_Id);
21224 Typ := Entity (Type_Id);
21226 if Typ = Any_Type then
21230 -- A pragma that applies to a Ghost entity becomes Ghost for the
21231 -- purposes of legality checks and removal of ignored Ghost code.
21233 Mark_Ghost_Pragma (N, Typ);
21235 -- The remaining processing is simply to link the pragma on to
21236 -- the rep item chain, for processing when the type is frozen.
21237 -- This is accomplished by a call to Rep_Item_Too_Late.
21239 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21240 end Predicate_Failure;
21246 -- pragma Preelaborate [(library_unit_NAME)];
21248 -- Set the flag Is_Preelaborated of program unit name entity
21250 when Pragma_Preelaborate => Preelaborate : declare
21251 Pa : constant Node_Id := Parent (N);
21252 Pk : constant Node_Kind := Nkind (Pa);
21256 Check_Ada_83_Warning;
21257 Check_Valid_Library_Unit_Pragma;
21259 Ent := Find_Lib_Unit_Name;
21261 -- A pragma that applies to a Ghost entity becomes Ghost for the
21262 -- purposes of legality checks and removal of ignored Ghost code.
21264 Mark_Ghost_Pragma (N, Ent);
21265 Check_Duplicate_Pragma (Ent);
21267 -- This filters out pragmas inside generic parents that show up
21268 -- inside instantiations. Pragmas that come from aspects in the
21269 -- unit are not ignored.
21271 if Present (Ent) then
21272 if Pk = N_Package_Specification
21273 and then Present (Generic_Parent (Pa))
21274 and then not From_Aspect_Specification (N)
21279 if not Debug_Flag_U then
21280 Set_Is_Preelaborated (Ent);
21282 if Legacy_Elaboration_Checks then
21283 Set_Suppress_Elaboration_Warnings (Ent);
21290 -------------------------------
21291 -- Prefix_Exception_Messages --
21292 -------------------------------
21294 -- pragma Prefix_Exception_Messages;
21296 when Pragma_Prefix_Exception_Messages =>
21298 Check_Valid_Configuration_Pragma;
21299 Check_Arg_Count (0);
21300 Prefix_Exception_Messages := True;
21306 -- pragma Priority (EXPRESSION);
21308 when Pragma_Priority => Priority : declare
21309 P : constant Node_Id := Parent (N);
21314 Check_No_Identifiers;
21315 Check_Arg_Count (1);
21319 if Nkind (P) = N_Subprogram_Body then
21320 Check_In_Main_Program;
21322 Ent := Defining_Unit_Name (Specification (P));
21324 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21325 Ent := Defining_Identifier (Ent);
21328 Arg := Get_Pragma_Arg (Arg1);
21329 Analyze_And_Resolve (Arg, Standard_Integer);
21333 if not Is_OK_Static_Expression (Arg) then
21334 Flag_Non_Static_Expr
21335 ("main subprogram priority is not static!", Arg);
21338 -- If constraint error, then we already signalled an error
21340 elsif Raises_Constraint_Error (Arg) then
21343 -- Otherwise check in range except if Relaxed_RM_Semantics
21344 -- where we ignore the value if out of range.
21347 if not Relaxed_RM_Semantics
21348 and then not Is_In_Range (Arg, RTE (RE_Priority))
21351 ("main subprogram priority is out of range", Arg1);
21354 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21358 -- Load an arbitrary entity from System.Tasking.Stages or
21359 -- System.Tasking.Restricted.Stages (depending on the
21360 -- supported profile) to make sure that one of these packages
21361 -- is implicitly with'ed, since we need to have the tasking
21362 -- run time active for the pragma Priority to have any effect.
21363 -- Previously we with'ed the package System.Tasking, but this
21364 -- package does not trigger the required initialization of the
21365 -- run-time library.
21367 if Restricted_Profile then
21368 Discard_Node (RTE (RE_Activate_Restricted_Tasks));
21370 Discard_Node (RTE (RE_Activate_Tasks));
21373 -- Task or Protected, must be of type Integer
21375 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
21376 Arg := Get_Pragma_Arg (Arg1);
21377 Ent := Defining_Identifier (Parent (P));
21379 -- The expression must be analyzed in the special manner
21380 -- described in "Handling of Default and Per-Object
21381 -- Expressions" in sem.ads.
21383 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21385 if not Is_OK_Static_Expression (Arg) then
21386 Check_Restriction (Static_Priorities, Arg);
21389 -- Anything else is incorrect
21395 -- Check duplicate pragma before we chain the pragma in the Rep
21396 -- Item chain of Ent.
21398 Check_Duplicate_Pragma (Ent);
21399 Record_Rep_Item (Ent, N);
21402 -----------------------------------
21403 -- Priority_Specific_Dispatching --
21404 -----------------------------------
21406 -- pragma Priority_Specific_Dispatching (
21407 -- policy_IDENTIFIER,
21408 -- first_priority_EXPRESSION,
21409 -- last_priority_EXPRESSION);
21411 when Pragma_Priority_Specific_Dispatching =>
21412 Priority_Specific_Dispatching : declare
21413 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21414 -- This is the entity System.Any_Priority;
21417 Lower_Bound : Node_Id;
21418 Upper_Bound : Node_Id;
21424 Check_Arg_Count (3);
21425 Check_No_Identifiers;
21426 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21427 Check_Valid_Configuration_Pragma;
21428 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21429 DP := Fold_Upper (Name_Buffer (1));
21431 Lower_Bound := Get_Pragma_Arg (Arg2);
21432 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21433 Lower_Val := Expr_Value (Lower_Bound);
21435 Upper_Bound := Get_Pragma_Arg (Arg3);
21436 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21437 Upper_Val := Expr_Value (Upper_Bound);
21439 -- It is not allowed to use Task_Dispatching_Policy and
21440 -- Priority_Specific_Dispatching in the same partition.
21442 if Task_Dispatching_Policy /= ' ' then
21443 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21445 ("pragma% incompatible with Task_Dispatching_Policy#");
21447 -- Check lower bound in range
21449 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21451 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21454 ("first_priority is out of range", Arg2);
21456 -- Check upper bound in range
21458 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21460 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21463 ("last_priority is out of range", Arg3);
21465 -- Check that the priority range is valid
21467 elsif Lower_Val > Upper_Val then
21469 ("last_priority_expression must be greater than or equal to "
21470 & "first_priority_expression");
21472 -- Store the new policy, but always preserve System_Location since
21473 -- we like the error message with the run-time name.
21476 -- Check overlapping in the priority ranges specified in other
21477 -- Priority_Specific_Dispatching pragmas within the same
21478 -- partition. We can only check those we know about.
21481 Specific_Dispatching.First .. Specific_Dispatching.Last
21483 if Specific_Dispatching.Table (J).First_Priority in
21484 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21485 or else Specific_Dispatching.Table (J).Last_Priority in
21486 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21489 Specific_Dispatching.Table (J).Pragma_Loc;
21491 ("priority range overlaps with "
21492 & "Priority_Specific_Dispatching#");
21496 -- The use of Priority_Specific_Dispatching is incompatible
21497 -- with Task_Dispatching_Policy.
21499 if Task_Dispatching_Policy /= ' ' then
21500 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21502 ("Priority_Specific_Dispatching incompatible "
21503 & "with Task_Dispatching_Policy#");
21506 -- The use of Priority_Specific_Dispatching forces ceiling
21509 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21510 Error_Msg_Sloc := Locking_Policy_Sloc;
21512 ("Priority_Specific_Dispatching incompatible "
21513 & "with Locking_Policy#");
21515 -- Set the Ceiling_Locking policy, but preserve System_Location
21516 -- since we like the error message with the run time name.
21519 Locking_Policy := 'C';
21521 if Locking_Policy_Sloc /= System_Location then
21522 Locking_Policy_Sloc := Loc;
21526 -- Add entry in the table
21528 Specific_Dispatching.Append
21529 ((Dispatching_Policy => DP,
21530 First_Priority => UI_To_Int (Lower_Val),
21531 Last_Priority => UI_To_Int (Upper_Val),
21532 Pragma_Loc => Loc));
21534 end Priority_Specific_Dispatching;
21540 -- pragma Profile (profile_IDENTIFIER);
21542 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21544 when Pragma_Profile =>
21546 Check_Arg_Count (1);
21547 Check_Valid_Configuration_Pragma;
21548 Check_No_Identifiers;
21551 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21554 if Nkind (Argx) /= N_Identifier then
21556 ("argument of pragma Profile must be an identifier", N);
21558 elsif Chars (Argx) = Name_Ravenscar then
21559 Set_Ravenscar_Profile (Ravenscar, N);
21561 elsif Chars (Argx) = Name_Jorvik then
21562 Set_Ravenscar_Profile (Jorvik, N);
21564 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21565 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21567 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21568 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21570 elsif Chars (Argx) = Name_Restricted then
21571 Set_Profile_Restrictions
21573 N, Warn => Treat_Restrictions_As_Warnings);
21575 elsif Chars (Argx) = Name_Rational then
21576 Set_Rational_Profile;
21578 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21579 Set_Profile_Restrictions
21580 (No_Implementation_Extensions,
21581 N, Warn => Treat_Restrictions_As_Warnings);
21584 Error_Pragma_Arg ("& is not a valid profile", Argx);
21588 ----------------------
21589 -- Profile_Warnings --
21590 ----------------------
21592 -- pragma Profile_Warnings (profile_IDENTIFIER);
21594 -- profile_IDENTIFIER => Restricted | Ravenscar
21596 when Pragma_Profile_Warnings =>
21598 Check_Arg_Count (1);
21599 Check_Valid_Configuration_Pragma;
21600 Check_No_Identifiers;
21603 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21606 if Chars (Argx) = Name_Ravenscar then
21607 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21609 elsif Chars (Argx) = Name_Restricted then
21610 Set_Profile_Restrictions (Restricted, N, Warn => True);
21612 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21613 Set_Profile_Restrictions
21614 (No_Implementation_Extensions, N, Warn => True);
21617 Error_Pragma_Arg ("& is not a valid profile", Argx);
21621 --------------------------
21622 -- Propagate_Exceptions --
21623 --------------------------
21625 -- pragma Propagate_Exceptions;
21627 -- Note: this pragma is obsolete and has no effect
21629 when Pragma_Propagate_Exceptions =>
21631 Check_Arg_Count (0);
21633 if Warn_On_Obsolescent_Feature then
21635 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21636 "and has no effect?j?", N);
21639 -----------------------------
21640 -- Provide_Shift_Operators --
21641 -----------------------------
21643 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21645 when Pragma_Provide_Shift_Operators =>
21646 Provide_Shift_Operators : declare
21649 procedure Declare_Shift_Operator (Nam : Name_Id);
21650 -- Insert declaration and pragma Instrinsic for named shift op
21652 ----------------------------
21653 -- Declare_Shift_Operator --
21654 ----------------------------
21656 procedure Declare_Shift_Operator (Nam : Name_Id) is
21662 Make_Subprogram_Declaration (Loc,
21663 Make_Function_Specification (Loc,
21664 Defining_Unit_Name =>
21665 Make_Defining_Identifier (Loc, Chars => Nam),
21667 Result_Definition =>
21668 Make_Identifier (Loc, Chars => Chars (Ent)),
21670 Parameter_Specifications => New_List (
21671 Make_Parameter_Specification (Loc,
21672 Defining_Identifier =>
21673 Make_Defining_Identifier (Loc, Name_Value),
21675 Make_Identifier (Loc, Chars => Chars (Ent))),
21677 Make_Parameter_Specification (Loc,
21678 Defining_Identifier =>
21679 Make_Defining_Identifier (Loc, Name_Amount),
21681 New_Occurrence_Of (Standard_Natural, Loc)))));
21685 Chars => Name_Import,
21686 Pragma_Argument_Associations => New_List (
21687 Make_Pragma_Argument_Association (Loc,
21688 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21689 Make_Pragma_Argument_Association (Loc,
21690 Expression => Make_Identifier (Loc, Nam))));
21692 Insert_After (N, Import);
21693 Insert_After (N, Func);
21694 end Declare_Shift_Operator;
21696 -- Start of processing for Provide_Shift_Operators
21700 Check_Arg_Count (1);
21701 Check_Arg_Is_Local_Name (Arg1);
21703 Arg1 := Get_Pragma_Arg (Arg1);
21705 -- We must have an entity name
21707 if not Is_Entity_Name (Arg1) then
21709 ("pragma % must apply to integer first subtype", Arg1);
21712 -- If no Entity, means there was a prior error so ignore
21714 if Present (Entity (Arg1)) then
21715 Ent := Entity (Arg1);
21717 -- Apply error checks
21719 if not Is_First_Subtype (Ent) then
21721 ("cannot apply pragma %",
21722 "\& is not a first subtype",
21725 elsif not Is_Integer_Type (Ent) then
21727 ("cannot apply pragma %",
21728 "\& is not an integer type",
21731 elsif Has_Shift_Operator (Ent) then
21733 ("cannot apply pragma %",
21734 "\& already has declared shift operators",
21737 elsif Is_Frozen (Ent) then
21739 ("pragma % appears too late",
21740 "\& is already frozen",
21744 -- Now declare the operators. We do this during analysis rather
21745 -- than expansion, since we want the operators available if we
21746 -- are operating in -gnatc mode.
21748 Declare_Shift_Operator (Name_Rotate_Left);
21749 Declare_Shift_Operator (Name_Rotate_Right);
21750 Declare_Shift_Operator (Name_Shift_Left);
21751 Declare_Shift_Operator (Name_Shift_Right);
21752 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21754 end Provide_Shift_Operators;
21760 -- pragma Psect_Object (
21761 -- [Internal =>] LOCAL_NAME,
21762 -- [, [External =>] EXTERNAL_SYMBOL]
21763 -- [, [Size =>] EXTERNAL_SYMBOL]);
21765 when Pragma_Common_Object
21766 | Pragma_Psect_Object
21768 Psect_Object : declare
21769 Args : Args_List (1 .. 3);
21770 Names : constant Name_List (1 .. 3) := (
21775 Internal : Node_Id renames Args (1);
21776 External : Node_Id renames Args (2);
21777 Size : Node_Id renames Args (3);
21779 Def_Id : Entity_Id;
21781 procedure Check_Arg (Arg : Node_Id);
21782 -- Checks that argument is either a string literal or an
21783 -- identifier, and posts error message if not.
21789 procedure Check_Arg (Arg : Node_Id) is
21791 if Nkind (Original_Node (Arg)) not in
21792 N_String_Literal | N_Identifier
21795 ("inappropriate argument for pragma %", Arg);
21799 -- Start of processing for Common_Object/Psect_Object
21803 Gather_Associations (Names, Args);
21804 Process_Extended_Import_Export_Internal_Arg (Internal);
21806 Def_Id := Entity (Internal);
21808 if Ekind (Def_Id) not in E_Constant | E_Variable then
21810 ("pragma% must designate an object", Internal);
21813 Check_Arg (Internal);
21815 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21817 ("cannot use pragma% for imported/exported object",
21821 if Is_Concurrent_Type (Etype (Internal)) then
21823 ("cannot specify pragma % for task/protected object",
21827 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21829 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21831 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21834 if Ekind (Def_Id) = E_Constant then
21836 ("cannot specify pragma % for a constant", Internal);
21839 if Is_Record_Type (Etype (Internal)) then
21845 Ent := First_Entity (Etype (Internal));
21846 while Present (Ent) loop
21847 Decl := Declaration_Node (Ent);
21849 if Ekind (Ent) = E_Component
21850 and then Nkind (Decl) = N_Component_Declaration
21851 and then Present (Expression (Decl))
21852 and then Warn_On_Export_Import
21855 ("?x?object for pragma % has defaults", Internal);
21865 if Present (Size) then
21869 if Present (External) then
21870 Check_Arg_Is_External_Name (External);
21873 -- If all error tests pass, link pragma on to the rep item chain
21875 Record_Rep_Item (Def_Id, N);
21882 -- pragma Pure [(library_unit_NAME)];
21884 when Pragma_Pure => Pure : declare
21888 Check_Ada_83_Warning;
21890 -- If the pragma comes from a subprogram instantiation, nothing to
21891 -- check, this can happen at any level of nesting.
21893 if Is_Wrapper_Package (Current_Scope) then
21896 Check_Valid_Library_Unit_Pragma;
21899 Ent := Find_Lib_Unit_Name;
21901 -- A pragma that applies to a Ghost entity becomes Ghost for the
21902 -- purposes of legality checks and removal of ignored Ghost code.
21904 Mark_Ghost_Pragma (N, Ent);
21906 if not Debug_Flag_U then
21908 Set_Has_Pragma_Pure (Ent);
21910 if Legacy_Elaboration_Checks then
21911 Set_Suppress_Elaboration_Warnings (Ent);
21916 -------------------
21917 -- Pure_Function --
21918 -------------------
21920 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21922 when Pragma_Pure_Function => Pure_Function : declare
21923 Def_Id : Entity_Id;
21926 Effective : Boolean := False;
21927 Orig_Def : Entity_Id;
21928 Same_Decl : Boolean := False;
21932 Check_Arg_Count (1);
21933 Check_Optional_Identifier (Arg1, Name_Entity);
21934 Check_Arg_Is_Local_Name (Arg1);
21935 E_Id := Get_Pragma_Arg (Arg1);
21937 if Etype (E_Id) = Any_Type then
21941 -- Loop through homonyms (overloadings) of referenced entity
21943 E := Entity (E_Id);
21945 -- A pragma that applies to a Ghost entity becomes Ghost for the
21946 -- purposes of legality checks and removal of ignored Ghost code.
21948 Mark_Ghost_Pragma (N, E);
21950 if Present (E) then
21952 Def_Id := Get_Base_Subprogram (E);
21954 if Ekind (Def_Id) not in
21955 E_Function | E_Generic_Function | E_Operator
21958 ("pragma% requires a function name", Arg1);
21961 -- When we have a generic function we must jump up a level
21962 -- to the declaration of the wrapper package itself.
21964 Orig_Def := Def_Id;
21966 if Is_Generic_Instance (Def_Id) then
21967 while Nkind (Orig_Def) /= N_Package_Declaration loop
21968 Orig_Def := Parent (Orig_Def);
21972 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21974 Set_Is_Pure (Def_Id);
21976 if not Has_Pragma_Pure_Function (Def_Id) then
21977 Set_Has_Pragma_Pure_Function (Def_Id);
21982 exit when From_Aspect_Specification (N);
21984 exit when No (E) or else Scope (E) /= Current_Scope;
21988 and then Warn_On_Redundant_Constructs
21991 ("pragma Pure_Function on& is redundant?r?",
21994 elsif not Same_Decl then
21996 ("pragma% argument must be in same declarative part",
22002 --------------------
22003 -- Queuing_Policy --
22004 --------------------
22006 -- pragma Queuing_Policy (policy_IDENTIFIER);
22008 when Pragma_Queuing_Policy => declare
22012 Check_Ada_83_Warning;
22013 Check_Arg_Count (1);
22014 Check_No_Identifiers;
22015 Check_Arg_Is_Queuing_Policy (Arg1);
22016 Check_Valid_Configuration_Pragma;
22017 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22018 QP := Fold_Upper (Name_Buffer (1));
22020 if Queuing_Policy /= ' '
22021 and then Queuing_Policy /= QP
22023 Error_Msg_Sloc := Queuing_Policy_Sloc;
22024 Error_Pragma ("queuing policy incompatible with policy#");
22026 -- Set new policy, but always preserve System_Location since we
22027 -- like the error message with the run time name.
22030 Queuing_Policy := QP;
22032 if Queuing_Policy_Sloc /= System_Location then
22033 Queuing_Policy_Sloc := Loc;
22042 -- pragma Rational, for compatibility with foreign compiler
22044 when Pragma_Rational =>
22045 Set_Rational_Profile;
22047 ---------------------
22048 -- Refined_Depends --
22049 ---------------------
22051 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22053 -- DEPENDENCY_RELATION ::=
22055 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22057 -- DEPENDENCY_CLAUSE ::=
22058 -- OUTPUT_LIST =>[+] INPUT_LIST
22059 -- | NULL_DEPENDENCY_CLAUSE
22061 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22063 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22065 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22067 -- OUTPUT ::= NAME | FUNCTION_RESULT
22070 -- where FUNCTION_RESULT is a function Result attribute_reference
22072 -- Characteristics:
22074 -- * Analysis - The annotation undergoes initial checks to verify
22075 -- the legal placement and context. Secondary checks fully analyze
22076 -- the dependency clauses/global list in:
22078 -- Analyze_Refined_Depends_In_Decl_Part
22080 -- * Expansion - None.
22082 -- * Template - The annotation utilizes the generic template of the
22083 -- related subprogram body.
22085 -- * Globals - Capture of global references must occur after full
22088 -- * Instance - The annotation is instantiated automatically when
22089 -- the related generic subprogram body is instantiated.
22091 when Pragma_Refined_Depends => Refined_Depends : declare
22092 Body_Id : Entity_Id;
22094 Spec_Id : Entity_Id;
22097 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22101 -- Chain the pragma on the contract for further processing by
22102 -- Analyze_Refined_Depends_In_Decl_Part.
22104 Add_Contract_Item (N, Body_Id);
22106 -- The legality checks of pragmas Refined_Depends and
22107 -- Refined_Global are affected by the SPARK mode in effect and
22108 -- the volatility of the context. In addition these two pragmas
22109 -- are subject to an inherent order:
22111 -- 1) Refined_Global
22112 -- 2) Refined_Depends
22114 -- Analyze all these pragmas in the order outlined above
22116 Analyze_If_Present (Pragma_SPARK_Mode);
22117 Analyze_If_Present (Pragma_Volatile_Function);
22118 Analyze_If_Present (Pragma_Refined_Global);
22119 Analyze_Refined_Depends_In_Decl_Part (N);
22121 end Refined_Depends;
22123 --------------------
22124 -- Refined_Global --
22125 --------------------
22127 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22129 -- GLOBAL_SPECIFICATION ::=
22132 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22134 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22136 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22137 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22138 -- GLOBAL_ITEM ::= NAME
22140 -- Characteristics:
22142 -- * Analysis - The annotation undergoes initial checks to verify
22143 -- the legal placement and context. Secondary checks fully analyze
22144 -- the dependency clauses/global list in:
22146 -- Analyze_Refined_Global_In_Decl_Part
22148 -- * Expansion - None.
22150 -- * Template - The annotation utilizes the generic template of the
22151 -- related subprogram body.
22153 -- * Globals - Capture of global references must occur after full
22156 -- * Instance - The annotation is instantiated automatically when
22157 -- the related generic subprogram body is instantiated.
22159 when Pragma_Refined_Global => Refined_Global : declare
22160 Body_Id : Entity_Id;
22162 Spec_Id : Entity_Id;
22165 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22169 -- Chain the pragma on the contract for further processing by
22170 -- Analyze_Refined_Global_In_Decl_Part.
22172 Add_Contract_Item (N, Body_Id);
22174 -- The legality checks of pragmas Refined_Depends and
22175 -- Refined_Global are affected by the SPARK mode in effect and
22176 -- the volatility of the context. In addition these two pragmas
22177 -- are subject to an inherent order:
22179 -- 1) Refined_Global
22180 -- 2) Refined_Depends
22182 -- Analyze all these pragmas in the order outlined above
22184 Analyze_If_Present (Pragma_SPARK_Mode);
22185 Analyze_If_Present (Pragma_Volatile_Function);
22186 Analyze_Refined_Global_In_Decl_Part (N);
22187 Analyze_If_Present (Pragma_Refined_Depends);
22189 end Refined_Global;
22195 -- pragma Refined_Post (boolean_EXPRESSION);
22197 -- Characteristics:
22199 -- * Analysis - The annotation is fully analyzed immediately upon
22200 -- elaboration as it cannot forward reference entities.
22202 -- * Expansion - The annotation is expanded during the expansion of
22203 -- the related subprogram body contract as performed in:
22205 -- Expand_Subprogram_Contract
22207 -- * Template - The annotation utilizes the generic template of the
22208 -- related subprogram body.
22210 -- * Globals - Capture of global references must occur after full
22213 -- * Instance - The annotation is instantiated automatically when
22214 -- the related generic subprogram body is instantiated.
22216 when Pragma_Refined_Post => Refined_Post : declare
22217 Body_Id : Entity_Id;
22219 Spec_Id : Entity_Id;
22222 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22224 -- Fully analyze the pragma when it appears inside a subprogram
22225 -- body because it cannot benefit from forward references.
22229 -- Chain the pragma on the contract for completeness
22231 Add_Contract_Item (N, Body_Id);
22233 -- The legality checks of pragma Refined_Post are affected by
22234 -- the SPARK mode in effect and the volatility of the context.
22235 -- Analyze all pragmas in a specific order.
22237 Analyze_If_Present (Pragma_SPARK_Mode);
22238 Analyze_If_Present (Pragma_Volatile_Function);
22239 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22241 -- Currently it is not possible to inline pre/postconditions on
22242 -- a subprogram subject to pragma Inline_Always.
22244 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22248 -------------------
22249 -- Refined_State --
22250 -------------------
22252 -- pragma Refined_State (REFINEMENT_LIST);
22254 -- REFINEMENT_LIST ::=
22255 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22257 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22259 -- CONSTITUENT_LIST ::=
22262 -- | (CONSTITUENT {, CONSTITUENT})
22264 -- CONSTITUENT ::= object_NAME | state_NAME
22266 -- Characteristics:
22268 -- * Analysis - The annotation undergoes initial checks to verify
22269 -- the legal placement and context. Secondary checks preanalyze the
22270 -- refinement clauses in:
22272 -- Analyze_Refined_State_In_Decl_Part
22274 -- * Expansion - None.
22276 -- * Template - The annotation utilizes the template of the related
22279 -- * Globals - Capture of global references must occur after full
22282 -- * Instance - The annotation is instantiated automatically when
22283 -- the related generic package body is instantiated.
22285 when Pragma_Refined_State => Refined_State : declare
22286 Pack_Decl : Node_Id;
22287 Spec_Id : Entity_Id;
22291 Check_No_Identifiers;
22292 Check_Arg_Count (1);
22294 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22296 if Nkind (Pack_Decl) /= N_Package_Body then
22301 Spec_Id := Corresponding_Spec (Pack_Decl);
22303 -- A pragma that applies to a Ghost entity becomes Ghost for the
22304 -- purposes of legality checks and removal of ignored Ghost code.
22306 Mark_Ghost_Pragma (N, Spec_Id);
22308 -- Chain the pragma on the contract for further processing by
22309 -- Analyze_Refined_State_In_Decl_Part.
22311 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22313 -- The legality checks of pragma Refined_State are affected by the
22314 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22316 Analyze_If_Present (Pragma_SPARK_Mode);
22318 -- State refinement is allowed only when the corresponding package
22319 -- declaration has non-null pragma Abstract_State. Refinement not
22320 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22322 if SPARK_Mode /= Off
22324 (No (Abstract_States (Spec_Id))
22325 or else Has_Null_Abstract_State (Spec_Id))
22328 ("useless refinement, package & does not define abstract "
22329 & "states", N, Spec_Id);
22334 -----------------------
22335 -- Relative_Deadline --
22336 -----------------------
22338 -- pragma Relative_Deadline (time_span_EXPRESSION);
22340 when Pragma_Relative_Deadline => Relative_Deadline : declare
22341 P : constant Node_Id := Parent (N);
22346 Check_No_Identifiers;
22347 Check_Arg_Count (1);
22349 Arg := Get_Pragma_Arg (Arg1);
22351 -- The expression must be analyzed in the special manner described
22352 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22354 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22358 if Nkind (P) = N_Subprogram_Body then
22359 Check_In_Main_Program;
22361 -- Only Task and subprogram cases allowed
22363 elsif Nkind (P) /= N_Task_Definition then
22367 -- Check duplicate pragma before we set the corresponding flag
22369 if Has_Relative_Deadline_Pragma (P) then
22370 Error_Pragma ("duplicate pragma% not allowed");
22373 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22374 -- Relative_Deadline pragma node cannot be inserted in the Rep
22375 -- Item chain of Ent since it is rewritten by the expander as a
22376 -- procedure call statement that will break the chain.
22378 Set_Has_Relative_Deadline_Pragma (P);
22379 end Relative_Deadline;
22381 ------------------------
22382 -- Remote_Access_Type --
22383 ------------------------
22385 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22387 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22392 Check_Arg_Count (1);
22393 Check_Optional_Identifier (Arg1, Name_Entity);
22394 Check_Arg_Is_Local_Name (Arg1);
22396 E := Entity (Get_Pragma_Arg (Arg1));
22398 -- A pragma that applies to a Ghost entity becomes Ghost for the
22399 -- purposes of legality checks and removal of ignored Ghost code.
22401 Mark_Ghost_Pragma (N, E);
22403 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22404 and then Ekind (E) = E_General_Access_Type
22405 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22406 and then Scope (Root_Type (Directly_Designated_Type (E)))
22408 and then Is_Valid_Remote_Object_Type
22409 (Root_Type (Directly_Designated_Type (E)))
22411 Set_Is_Remote_Types (E);
22415 ("pragma% applies only to formal access-to-class-wide types",
22418 end Remote_Access_Type;
22420 ---------------------------
22421 -- Remote_Call_Interface --
22422 ---------------------------
22424 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22426 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22427 Cunit_Node : Node_Id;
22428 Cunit_Ent : Entity_Id;
22432 Check_Ada_83_Warning;
22433 Check_Valid_Library_Unit_Pragma;
22435 Cunit_Node := Cunit (Current_Sem_Unit);
22436 K := Nkind (Unit (Cunit_Node));
22437 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22439 -- A pragma that applies to a Ghost entity becomes Ghost for the
22440 -- purposes of legality checks and removal of ignored Ghost code.
22442 Mark_Ghost_Pragma (N, Cunit_Ent);
22444 if K = N_Package_Declaration
22445 or else K = N_Generic_Package_Declaration
22446 or else K = N_Subprogram_Declaration
22447 or else K = N_Generic_Subprogram_Declaration
22448 or else (K = N_Subprogram_Body
22449 and then Acts_As_Spec (Unit (Cunit_Node)))
22454 "pragma% must apply to package or subprogram declaration");
22457 Set_Is_Remote_Call_Interface (Cunit_Ent);
22458 end Remote_Call_Interface;
22464 -- pragma Remote_Types [(library_unit_NAME)];
22466 when Pragma_Remote_Types => Remote_Types : declare
22467 Cunit_Node : Node_Id;
22468 Cunit_Ent : Entity_Id;
22471 Check_Ada_83_Warning;
22472 Check_Valid_Library_Unit_Pragma;
22474 Cunit_Node := Cunit (Current_Sem_Unit);
22475 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22477 -- A pragma that applies to a Ghost entity becomes Ghost for the
22478 -- purposes of legality checks and removal of ignored Ghost code.
22480 Mark_Ghost_Pragma (N, Cunit_Ent);
22482 if Nkind (Unit (Cunit_Node)) not in
22483 N_Package_Declaration | N_Generic_Package_Declaration
22486 ("pragma% can only apply to a package declaration");
22489 Set_Is_Remote_Types (Cunit_Ent);
22496 -- pragma Ravenscar;
22498 when Pragma_Ravenscar =>
22500 Check_Arg_Count (0);
22501 Check_Valid_Configuration_Pragma;
22502 Set_Ravenscar_Profile (Ravenscar, N);
22504 if Warn_On_Obsolescent_Feature then
22506 ("pragma Ravenscar is an obsolescent feature?j?", N);
22508 ("|use pragma Profile (Ravenscar) instead?j?", N);
22511 -------------------------
22512 -- Restricted_Run_Time --
22513 -------------------------
22515 -- pragma Restricted_Run_Time;
22517 when Pragma_Restricted_Run_Time =>
22519 Check_Arg_Count (0);
22520 Check_Valid_Configuration_Pragma;
22521 Set_Profile_Restrictions
22522 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22524 if Warn_On_Obsolescent_Feature then
22526 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22529 ("|use pragma Profile (Restricted) instead?j?", N);
22536 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22539 -- restriction_IDENTIFIER
22540 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22542 when Pragma_Restrictions =>
22543 Process_Restrictions_Or_Restriction_Warnings
22544 (Warn => Treat_Restrictions_As_Warnings);
22546 --------------------------
22547 -- Restriction_Warnings --
22548 --------------------------
22550 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22553 -- restriction_IDENTIFIER
22554 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22556 when Pragma_Restriction_Warnings =>
22558 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22564 -- pragma Reviewable;
22566 when Pragma_Reviewable =>
22567 Check_Ada_83_Warning;
22568 Check_Arg_Count (0);
22570 -- Call dummy debugging function rv. This is done to assist front
22571 -- end debugging. By placing a Reviewable pragma in the source
22572 -- program, a breakpoint on rv catches this place in the source,
22573 -- allowing convenient stepping to the point of interest.
22577 --------------------------
22578 -- Secondary_Stack_Size --
22579 --------------------------
22581 -- pragma Secondary_Stack_Size (EXPRESSION);
22583 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22584 P : constant Node_Id := Parent (N);
22590 Check_No_Identifiers;
22591 Check_Arg_Count (1);
22593 if Nkind (P) = N_Task_Definition then
22594 Arg := Get_Pragma_Arg (Arg1);
22595 Ent := Defining_Identifier (Parent (P));
22597 -- The expression must be analyzed in the special manner
22598 -- described in "Handling of Default Expressions" in sem.ads.
22600 Preanalyze_Spec_Expression (Arg, Any_Integer);
22602 -- The pragma cannot appear if the No_Secondary_Stack
22603 -- restriction is in effect.
22605 Check_Restriction (No_Secondary_Stack, Arg);
22607 -- Anything else is incorrect
22613 -- Check duplicate pragma before we chain the pragma in the Rep
22614 -- Item chain of Ent.
22616 Check_Duplicate_Pragma (Ent);
22617 Record_Rep_Item (Ent, N);
22618 end Secondary_Stack_Size;
22620 --------------------------
22621 -- Short_Circuit_And_Or --
22622 --------------------------
22624 -- pragma Short_Circuit_And_Or;
22626 when Pragma_Short_Circuit_And_Or =>
22628 Check_Arg_Count (0);
22629 Check_Valid_Configuration_Pragma;
22630 Short_Circuit_And_Or := True;
22632 -------------------
22633 -- Share_Generic --
22634 -------------------
22636 -- pragma Share_Generic (GNAME {, GNAME});
22638 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22640 when Pragma_Share_Generic =>
22642 Process_Generic_List;
22648 -- pragma Shared (LOCAL_NAME);
22650 when Pragma_Shared =>
22652 Process_Atomic_Independent_Shared_Volatile;
22654 --------------------
22655 -- Shared_Passive --
22656 --------------------
22658 -- pragma Shared_Passive [(library_unit_NAME)];
22660 -- Set the flag Is_Shared_Passive of program unit name entity
22662 when Pragma_Shared_Passive => Shared_Passive : declare
22663 Cunit_Node : Node_Id;
22664 Cunit_Ent : Entity_Id;
22667 Check_Ada_83_Warning;
22668 Check_Valid_Library_Unit_Pragma;
22670 Cunit_Node := Cunit (Current_Sem_Unit);
22671 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22673 -- A pragma that applies to a Ghost entity becomes Ghost for the
22674 -- purposes of legality checks and removal of ignored Ghost code.
22676 Mark_Ghost_Pragma (N, Cunit_Ent);
22678 if Nkind (Unit (Cunit_Node)) not in
22679 N_Package_Declaration | N_Generic_Package_Declaration
22682 ("pragma% can only apply to a package declaration");
22685 Set_Is_Shared_Passive (Cunit_Ent);
22686 end Shared_Passive;
22688 -----------------------
22689 -- Short_Descriptors --
22690 -----------------------
22692 -- pragma Short_Descriptors;
22694 -- Recognize and validate, but otherwise ignore
22696 when Pragma_Short_Descriptors =>
22698 Check_Arg_Count (0);
22699 Check_Valid_Configuration_Pragma;
22701 ------------------------------
22702 -- Simple_Storage_Pool_Type --
22703 ------------------------------
22705 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22707 when Pragma_Simple_Storage_Pool_Type =>
22708 Simple_Storage_Pool_Type : declare
22714 Check_Arg_Count (1);
22715 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22717 Type_Id := Get_Pragma_Arg (Arg1);
22718 Find_Type (Type_Id);
22719 Typ := Entity (Type_Id);
22721 if Typ = Any_Type then
22725 -- A pragma that applies to a Ghost entity becomes Ghost for the
22726 -- purposes of legality checks and removal of ignored Ghost code.
22728 Mark_Ghost_Pragma (N, Typ);
22730 -- We require the pragma to apply to a type declared in a package
22731 -- declaration, but not (immediately) within a package body.
22733 if Ekind (Current_Scope) /= E_Package
22734 or else In_Package_Body (Current_Scope)
22737 ("pragma% can only apply to type declared immediately "
22738 & "within a package declaration");
22741 -- A simple storage pool type must be an immutably limited record
22742 -- or private type. If the pragma is given for a private type,
22743 -- the full type is similarly restricted (which is checked later
22744 -- in Freeze_Entity).
22746 if Is_Record_Type (Typ)
22747 and then not Is_Limited_View (Typ)
22750 ("pragma% can only apply to explicitly limited record type");
22752 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22754 ("pragma% can only apply to a private type that is limited");
22756 elsif not Is_Record_Type (Typ)
22757 and then not Is_Private_Type (Typ)
22760 ("pragma% can only apply to limited record or private type");
22763 Record_Rep_Item (Typ, N);
22764 end Simple_Storage_Pool_Type;
22766 ----------------------
22767 -- Source_File_Name --
22768 ----------------------
22770 -- There are five forms for this pragma:
22772 -- pragma Source_File_Name (
22773 -- [UNIT_NAME =>] unit_NAME,
22774 -- BODY_FILE_NAME => STRING_LITERAL
22775 -- [, [INDEX =>] INTEGER_LITERAL]);
22777 -- pragma Source_File_Name (
22778 -- [UNIT_NAME =>] unit_NAME,
22779 -- SPEC_FILE_NAME => STRING_LITERAL
22780 -- [, [INDEX =>] INTEGER_LITERAL]);
22782 -- pragma Source_File_Name (
22783 -- BODY_FILE_NAME => STRING_LITERAL
22784 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22785 -- [, CASING => CASING_SPEC]);
22787 -- pragma Source_File_Name (
22788 -- SPEC_FILE_NAME => STRING_LITERAL
22789 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22790 -- [, CASING => CASING_SPEC]);
22792 -- pragma Source_File_Name (
22793 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22794 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22795 -- [, CASING => CASING_SPEC]);
22797 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22799 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22800 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22801 -- only be used when no project file is used, while SFNP can only be
22802 -- used when a project file is used.
22804 -- No processing here. Processing was completed during parsing, since
22805 -- we need to have file names set as early as possible. Units are
22806 -- loaded well before semantic processing starts.
22808 -- The only processing we defer to this point is the check for
22809 -- correct placement.
22811 when Pragma_Source_File_Name =>
22813 Check_Valid_Configuration_Pragma;
22815 ------------------------------
22816 -- Source_File_Name_Project --
22817 ------------------------------
22819 -- See Source_File_Name for syntax
22821 -- No processing here. Processing was completed during parsing, since
22822 -- we need to have file names set as early as possible. Units are
22823 -- loaded well before semantic processing starts.
22825 -- The only processing we defer to this point is the check for
22826 -- correct placement.
22828 when Pragma_Source_File_Name_Project =>
22830 Check_Valid_Configuration_Pragma;
22832 -- Check that a pragma Source_File_Name_Project is used only in a
22833 -- configuration pragmas file.
22835 -- Pragmas Source_File_Name_Project should only be generated by
22836 -- the Project Manager in configuration pragmas files.
22838 -- This is really an ugly test. It seems to depend on some
22839 -- accidental and undocumented property. At the very least it
22840 -- needs to be documented, but it would be better to have a
22841 -- clean way of testing if we are in a configuration file???
22843 if Present (Parent (N)) then
22845 ("pragma% can only appear in a configuration pragmas file");
22848 ----------------------
22849 -- Source_Reference --
22850 ----------------------
22852 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22854 -- Nothing to do, all processing completed in Par.Prag, since we need
22855 -- the information for possible parser messages that are output.
22857 when Pragma_Source_Reference =>
22864 -- pragma SPARK_Mode [(On | Off)];
22866 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22867 Mode_Id : SPARK_Mode_Type;
22869 procedure Check_Pragma_Conformance
22870 (Context_Pragma : Node_Id;
22871 Entity : Entity_Id;
22872 Entity_Pragma : Node_Id);
22873 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22874 -- conformance of pragma N depending the following scenarios:
22876 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22877 -- compatible with the pragma Context_Pragma that was inherited
22878 -- from the context:
22879 -- * If the mode of Context_Pragma is ON, then the new mode can
22881 -- * If the mode of Context_Pragma is OFF, then the only allowed
22882 -- new mode is also OFF. Emit error if this is not the case.
22884 -- If Entity is not Empty, verify that pragma N is compatible with
22885 -- pragma Entity_Pragma that belongs to Entity.
22886 -- * If Entity_Pragma is Empty, always issue an error as this
22887 -- corresponds to the case where a previous section of Entity
22888 -- has no SPARK_Mode set.
22889 -- * If the mode of Entity_Pragma is ON, then the new mode can
22891 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22892 -- new mode is also OFF. Emit error if this is not the case.
22894 procedure Check_Library_Level_Entity (E : Entity_Id);
22895 -- Subsidiary to routines Process_xxx. Verify that the related
22896 -- entity E subject to pragma SPARK_Mode is library-level.
22898 procedure Process_Body (Decl : Node_Id);
22899 -- Verify the legality of pragma SPARK_Mode when it appears as the
22900 -- top of the body declarations of entry, package, protected unit,
22901 -- subprogram or task unit body denoted by Decl.
22903 procedure Process_Overloadable (Decl : Node_Id);
22904 -- Verify the legality of pragma SPARK_Mode when it applies to an
22905 -- entry or [generic] subprogram declaration denoted by Decl.
22907 procedure Process_Private_Part (Decl : Node_Id);
22908 -- Verify the legality of pragma SPARK_Mode when it appears at the
22909 -- top of the private declarations of a package spec, protected or
22910 -- task unit declaration denoted by Decl.
22912 procedure Process_Statement_Part (Decl : Node_Id);
22913 -- Verify the legality of pragma SPARK_Mode when it appears at the
22914 -- top of the statement sequence of a package body denoted by node
22917 procedure Process_Visible_Part (Decl : Node_Id);
22918 -- Verify the legality of pragma SPARK_Mode when it appears at the
22919 -- top of the visible declarations of a package spec, protected or
22920 -- task unit declaration denoted by Decl. The routine is also used
22921 -- on protected or task units declared without a definition.
22923 procedure Set_SPARK_Context;
22924 -- Subsidiary to routines Process_xxx. Set the global variables
22925 -- which represent the mode of the context from pragma N. Ensure
22926 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22928 ------------------------------
22929 -- Check_Pragma_Conformance --
22930 ------------------------------
22932 procedure Check_Pragma_Conformance
22933 (Context_Pragma : Node_Id;
22934 Entity : Entity_Id;
22935 Entity_Pragma : Node_Id)
22937 Err_Id : Entity_Id;
22941 -- The current pragma may appear without an argument. If this
22942 -- is the case, associate all error messages with the pragma
22945 if Present (Arg1) then
22951 -- The mode of the current pragma is compared against that of
22952 -- an enclosing context.
22954 if Present (Context_Pragma) then
22955 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22957 -- Issue an error if the new mode is less restrictive than
22958 -- that of the context.
22960 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22961 and then Get_SPARK_Mode_From_Annotation (N) = On
22964 ("cannot change SPARK_Mode from Off to On", Err_N);
22965 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22966 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22971 -- The mode of the current pragma is compared against that of
22972 -- an initial package, protected type, subprogram or task type
22975 if Present (Entity) then
22977 -- A simple protected or task type is transformed into an
22978 -- anonymous type whose name cannot be used to issue error
22979 -- messages. Recover the original entity of the type.
22981 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
22984 (Original_Node (Unit_Declaration_Node (Entity)));
22989 -- Both the initial declaration and the completion carry
22990 -- SPARK_Mode pragmas.
22992 if Present (Entity_Pragma) then
22993 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
22995 -- Issue an error if the new mode is less restrictive
22996 -- than that of the initial declaration.
22998 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
22999 and then Get_SPARK_Mode_From_Annotation (N) = On
23001 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23002 Error_Msg_Sloc := Sloc (Entity_Pragma);
23004 ("\value Off was set for SPARK_Mode on&#",
23009 -- Otherwise the initial declaration lacks a SPARK_Mode
23010 -- pragma in which case the current pragma is illegal as
23011 -- it cannot "complete".
23013 elsif Get_SPARK_Mode_From_Annotation (N) = Off
23014 and then (Is_Generic_Unit (Entity) or else In_Instance)
23019 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23020 Error_Msg_Sloc := Sloc (Err_Id);
23022 ("\no value was set for SPARK_Mode on&#",
23027 end Check_Pragma_Conformance;
23029 --------------------------------
23030 -- Check_Library_Level_Entity --
23031 --------------------------------
23033 procedure Check_Library_Level_Entity (E : Entity_Id) is
23034 procedure Add_Entity_To_Name_Buffer;
23035 -- Add the E_Kind of entity E to the name buffer
23037 -------------------------------
23038 -- Add_Entity_To_Name_Buffer --
23039 -------------------------------
23041 procedure Add_Entity_To_Name_Buffer is
23043 if Ekind (E) in E_Entry | E_Entry_Family then
23044 Add_Str_To_Name_Buffer ("entry");
23046 elsif Ekind (E) in E_Generic_Package
23050 Add_Str_To_Name_Buffer ("package");
23052 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
23053 Add_Str_To_Name_Buffer ("protected type");
23055 elsif Ekind (E) in E_Function
23056 | E_Generic_Function
23057 | E_Generic_Procedure
23059 | E_Subprogram_Body
23061 Add_Str_To_Name_Buffer ("subprogram");
23064 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
23065 Add_Str_To_Name_Buffer ("task type");
23067 end Add_Entity_To_Name_Buffer;
23071 Msg_1 : constant String := "incorrect placement of pragma%";
23074 -- Start of processing for Check_Library_Level_Entity
23077 -- A SPARK_Mode of On shall only apply to library-level
23078 -- entities, except for those in generic instances, which are
23079 -- ignored (even if the entity gets SPARK_Mode pragma attached
23080 -- in the AST, its effect is not taken into account unless the
23081 -- context already provides SPARK_Mode of On in GNATprove).
23083 if Get_SPARK_Mode_From_Annotation (N) = On
23084 and then not Is_Library_Level_Entity (E)
23085 and then Instantiation_Location (Sloc (N)) = No_Location
23087 Error_Msg_Name_1 := Pname;
23088 Error_Msg_N (Fix_Error (Msg_1), N);
23091 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23092 Add_Entity_To_Name_Buffer;
23094 Msg_2 := Name_Find;
23095 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23099 end Check_Library_Level_Entity;
23105 procedure Process_Body (Decl : Node_Id) is
23106 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23107 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23110 -- Ignore pragma when applied to the special body created for
23111 -- inlining, recognized by its internal name _Parent.
23113 if Chars (Body_Id) = Name_uParent then
23117 Check_Library_Level_Entity (Body_Id);
23119 -- For entry bodies, verify the legality against:
23120 -- * The mode of the context
23121 -- * The mode of the spec (if any)
23123 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
23125 -- A stand-alone subprogram body
23127 if Body_Id = Spec_Id then
23128 Check_Pragma_Conformance
23129 (Context_Pragma => SPARK_Pragma (Body_Id),
23131 Entity_Pragma => Empty);
23133 -- An entry or subprogram body that completes a previous
23137 Check_Pragma_Conformance
23138 (Context_Pragma => SPARK_Pragma (Body_Id),
23140 Entity_Pragma => SPARK_Pragma (Spec_Id));
23144 Set_SPARK_Pragma (Body_Id, N);
23145 Set_SPARK_Pragma_Inherited (Body_Id, False);
23147 -- For package bodies, verify the legality against:
23148 -- * The mode of the context
23149 -- * The mode of the private part
23151 -- This case is separated from protected and task bodies
23152 -- because the statement part of the package body inherits
23153 -- the mode of the body declarations.
23155 elsif Nkind (Decl) = N_Package_Body then
23156 Check_Pragma_Conformance
23157 (Context_Pragma => SPARK_Pragma (Body_Id),
23159 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23162 Set_SPARK_Pragma (Body_Id, N);
23163 Set_SPARK_Pragma_Inherited (Body_Id, False);
23164 Set_SPARK_Aux_Pragma (Body_Id, N);
23165 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23167 -- For protected and task bodies, verify the legality against:
23168 -- * The mode of the context
23169 -- * The mode of the private part
23173 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
23175 Check_Pragma_Conformance
23176 (Context_Pragma => SPARK_Pragma (Body_Id),
23178 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23181 Set_SPARK_Pragma (Body_Id, N);
23182 Set_SPARK_Pragma_Inherited (Body_Id, False);
23186 --------------------------
23187 -- Process_Overloadable --
23188 --------------------------
23190 procedure Process_Overloadable (Decl : Node_Id) is
23191 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23192 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23195 Check_Library_Level_Entity (Spec_Id);
23197 -- Verify the legality against:
23198 -- * The mode of the context
23200 Check_Pragma_Conformance
23201 (Context_Pragma => SPARK_Pragma (Spec_Id),
23203 Entity_Pragma => Empty);
23205 Set_SPARK_Pragma (Spec_Id, N);
23206 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23208 -- When the pragma applies to the anonymous object created for
23209 -- a single task type, decorate the type as well. This scenario
23210 -- arises when the single task type lacks a task definition,
23211 -- therefore there is no issue with respect to a potential
23212 -- pragma SPARK_Mode in the private part.
23214 -- task type Anon_Task_Typ;
23215 -- Obj : Anon_Task_Typ;
23216 -- pragma SPARK_Mode ...;
23218 if Is_Single_Task_Object (Spec_Id) then
23219 Set_SPARK_Pragma (Spec_Typ, N);
23220 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23221 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23222 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23224 end Process_Overloadable;
23226 --------------------------
23227 -- Process_Private_Part --
23228 --------------------------
23230 procedure Process_Private_Part (Decl : Node_Id) is
23231 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23234 Check_Library_Level_Entity (Spec_Id);
23236 -- Verify the legality against:
23237 -- * The mode of the visible declarations
23239 Check_Pragma_Conformance
23240 (Context_Pragma => Empty,
23242 Entity_Pragma => SPARK_Pragma (Spec_Id));
23245 Set_SPARK_Aux_Pragma (Spec_Id, N);
23246 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23247 end Process_Private_Part;
23249 ----------------------------
23250 -- Process_Statement_Part --
23251 ----------------------------
23253 procedure Process_Statement_Part (Decl : Node_Id) is
23254 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23257 Check_Library_Level_Entity (Body_Id);
23259 -- Verify the legality against:
23260 -- * The mode of the body declarations
23262 Check_Pragma_Conformance
23263 (Context_Pragma => Empty,
23265 Entity_Pragma => SPARK_Pragma (Body_Id));
23268 Set_SPARK_Aux_Pragma (Body_Id, N);
23269 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23270 end Process_Statement_Part;
23272 --------------------------
23273 -- Process_Visible_Part --
23274 --------------------------
23276 procedure Process_Visible_Part (Decl : Node_Id) is
23277 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23278 Obj_Id : Entity_Id;
23281 Check_Library_Level_Entity (Spec_Id);
23283 -- Verify the legality against:
23284 -- * The mode of the context
23286 Check_Pragma_Conformance
23287 (Context_Pragma => SPARK_Pragma (Spec_Id),
23289 Entity_Pragma => Empty);
23291 -- A task unit declared without a definition does not set the
23292 -- SPARK_Mode of the context because the task does not have any
23293 -- entries that could inherit the mode.
23295 if Nkind (Decl) not in
23296 N_Single_Task_Declaration | N_Task_Type_Declaration
23301 Set_SPARK_Pragma (Spec_Id, N);
23302 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23303 Set_SPARK_Aux_Pragma (Spec_Id, N);
23304 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23306 -- When the pragma applies to a single protected or task type,
23307 -- decorate the corresponding anonymous object as well.
23309 -- protected Anon_Prot_Typ is
23310 -- pragma SPARK_Mode ...;
23312 -- end Anon_Prot_Typ;
23314 -- Obj : Anon_Prot_Typ;
23316 if Is_Single_Concurrent_Type (Spec_Id) then
23317 Obj_Id := Anonymous_Object (Spec_Id);
23319 Set_SPARK_Pragma (Obj_Id, N);
23320 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23322 end Process_Visible_Part;
23324 -----------------------
23325 -- Set_SPARK_Context --
23326 -----------------------
23328 procedure Set_SPARK_Context is
23330 SPARK_Mode := Mode_Id;
23331 SPARK_Mode_Pragma := N;
23332 end Set_SPARK_Context;
23340 -- Start of processing for Do_SPARK_Mode
23344 Check_No_Identifiers;
23345 Check_At_Most_N_Arguments (1);
23347 -- Check the legality of the mode (no argument = ON)
23349 if Arg_Count = 1 then
23350 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23351 Mode := Chars (Get_Pragma_Arg (Arg1));
23356 Mode_Id := Get_SPARK_Mode_Type (Mode);
23357 Context := Parent (N);
23359 -- When a SPARK_Mode pragma appears inside an instantiation whose
23360 -- enclosing context has SPARK_Mode set to "off", the pragma has
23361 -- no semantic effect.
23363 if Ignore_SPARK_Mode_Pragmas_In_Instance
23364 and then Mode_Id /= Off
23366 Rewrite (N, Make_Null_Statement (Loc));
23371 -- The pragma appears in a configuration file
23373 if No (Context) then
23374 Check_Valid_Configuration_Pragma;
23376 if Present (SPARK_Mode_Pragma) then
23379 Prev => SPARK_Mode_Pragma);
23385 -- The pragma acts as a configuration pragma in a compilation unit
23387 -- pragma SPARK_Mode ...;
23388 -- package Pack is ...;
23390 elsif Nkind (Context) = N_Compilation_Unit
23391 and then List_Containing (N) = Context_Items (Context)
23393 Check_Valid_Configuration_Pragma;
23396 -- Otherwise the placement of the pragma within the tree dictates
23397 -- its associated construct. Inspect the declarative list where
23398 -- the pragma resides to find a potential construct.
23402 while Present (Stmt) loop
23404 -- Skip prior pragmas, but check for duplicates. Note that
23405 -- this also takes care of pragmas generated for aspects.
23407 if Nkind (Stmt) = N_Pragma then
23408 if Pragma_Name (Stmt) = Pname then
23415 -- The pragma applies to an expression function that has
23416 -- already been rewritten into a subprogram declaration.
23418 -- function Expr_Func return ... is (...);
23419 -- pragma SPARK_Mode ...;
23421 elsif Nkind (Stmt) = N_Subprogram_Declaration
23422 and then Nkind (Original_Node (Stmt)) =
23423 N_Expression_Function
23425 Process_Overloadable (Stmt);
23428 -- The pragma applies to the anonymous object created for a
23429 -- single concurrent type.
23431 -- protected type Anon_Prot_Typ ...;
23432 -- Obj : Anon_Prot_Typ;
23433 -- pragma SPARK_Mode ...;
23435 elsif Nkind (Stmt) = N_Object_Declaration
23436 and then Is_Single_Concurrent_Object
23437 (Defining_Entity (Stmt))
23439 Process_Overloadable (Stmt);
23442 -- Skip internally generated code
23444 elsif not Comes_From_Source (Stmt) then
23447 -- The pragma applies to an entry or [generic] subprogram
23451 -- pragma SPARK_Mode ...;
23454 -- procedure Proc ...;
23455 -- pragma SPARK_Mode ...;
23457 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
23458 | N_Subprogram_Declaration
23459 or else (Nkind (Stmt) = N_Entry_Declaration
23460 and then Is_Protected_Type
23461 (Scope (Defining_Entity (Stmt))))
23463 Process_Overloadable (Stmt);
23466 -- Otherwise the pragma does not apply to a legal construct
23467 -- or it does not appear at the top of a declarative or a
23468 -- statement list. Issue an error and stop the analysis.
23478 -- The pragma applies to a package or a subprogram that acts as
23479 -- a compilation unit.
23481 -- procedure Proc ...;
23482 -- pragma SPARK_Mode ...;
23484 if Nkind (Context) = N_Compilation_Unit_Aux then
23485 Context := Unit (Parent (Context));
23488 -- The pragma appears at the top of entry, package, protected
23489 -- unit, subprogram or task unit body declarations.
23491 -- entry Ent when ... is
23492 -- pragma SPARK_Mode ...;
23494 -- package body Pack is
23495 -- pragma SPARK_Mode ...;
23497 -- procedure Proc ... is
23498 -- pragma SPARK_Mode;
23500 -- protected body Prot is
23501 -- pragma SPARK_Mode ...;
23503 if Nkind (Context) in N_Entry_Body
23506 | N_Subprogram_Body
23509 Process_Body (Context);
23511 -- The pragma appears at the top of the visible or private
23512 -- declaration of a package spec, protected or task unit.
23515 -- pragma SPARK_Mode ...;
23517 -- pragma SPARK_Mode ...;
23519 -- protected [type] Prot is
23520 -- pragma SPARK_Mode ...;
23522 -- pragma SPARK_Mode ...;
23524 elsif Nkind (Context) in N_Package_Specification
23525 | N_Protected_Definition
23526 | N_Task_Definition
23528 if List_Containing (N) = Visible_Declarations (Context) then
23529 Process_Visible_Part (Parent (Context));
23531 Process_Private_Part (Parent (Context));
23534 -- The pragma appears at the top of package body statements
23536 -- package body Pack is
23538 -- pragma SPARK_Mode;
23540 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23541 and then Nkind (Parent (Context)) = N_Package_Body
23543 Process_Statement_Part (Parent (Context));
23545 -- The pragma appeared as an aspect of a [generic] subprogram
23546 -- declaration that acts as a compilation unit.
23549 -- procedure Proc ...;
23550 -- pragma SPARK_Mode ...;
23552 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
23553 | N_Subprogram_Declaration
23555 Process_Overloadable (Context);
23557 -- The pragma does not apply to a legal construct, issue error
23565 --------------------------------
23566 -- Static_Elaboration_Desired --
23567 --------------------------------
23569 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23571 when Pragma_Static_Elaboration_Desired =>
23573 Check_At_Most_N_Arguments (1);
23575 if Is_Compilation_Unit (Current_Scope)
23576 and then Ekind (Current_Scope) = E_Package
23578 Set_Static_Elaboration_Desired (Current_Scope, True);
23580 Error_Pragma ("pragma% must apply to a library-level package");
23587 -- pragma Storage_Size (EXPRESSION);
23589 when Pragma_Storage_Size => Storage_Size : declare
23590 P : constant Node_Id := Parent (N);
23594 Check_No_Identifiers;
23595 Check_Arg_Count (1);
23597 -- The expression must be analyzed in the special manner described
23598 -- in "Handling of Default Expressions" in sem.ads.
23600 Arg := Get_Pragma_Arg (Arg1);
23601 Preanalyze_Spec_Expression (Arg, Any_Integer);
23603 if not Is_OK_Static_Expression (Arg) then
23604 Check_Restriction (Static_Storage_Size, Arg);
23607 if Nkind (P) /= N_Task_Definition then
23612 if Has_Storage_Size_Pragma (P) then
23613 Error_Pragma ("duplicate pragma% not allowed");
23615 Set_Has_Storage_Size_Pragma (P, True);
23618 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23626 -- pragma Storage_Unit (NUMERIC_LITERAL);
23628 -- Only permitted argument is System'Storage_Unit value
23630 when Pragma_Storage_Unit =>
23631 Check_No_Identifiers;
23632 Check_Arg_Count (1);
23633 Check_Arg_Is_Integer_Literal (Arg1);
23635 if Intval (Get_Pragma_Arg (Arg1)) /=
23636 UI_From_Int (Ttypes.System_Storage_Unit)
23638 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23640 ("the only allowed argument for pragma% is ^", Arg1);
23643 --------------------
23644 -- Stream_Convert --
23645 --------------------
23647 -- pragma Stream_Convert (
23648 -- [Entity =>] type_LOCAL_NAME,
23649 -- [Read =>] function_NAME,
23650 -- [Write =>] function NAME);
23652 when Pragma_Stream_Convert => Stream_Convert : declare
23653 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23654 -- Check that the given argument is the name of a local function
23655 -- of one argument that is not overloaded earlier in the current
23656 -- local scope. A check is also made that the argument is a
23657 -- function with one parameter.
23659 --------------------------------------
23660 -- Check_OK_Stream_Convert_Function --
23661 --------------------------------------
23663 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23667 Check_Arg_Is_Local_Name (Arg);
23668 Ent := Entity (Get_Pragma_Arg (Arg));
23670 if Has_Homonym (Ent) then
23672 ("argument for pragma% may not be overloaded", Arg);
23675 if Ekind (Ent) /= E_Function
23676 or else No (First_Formal (Ent))
23677 or else Present (Next_Formal (First_Formal (Ent)))
23680 ("argument for pragma% must be function of one argument",
23682 elsif Is_Abstract_Subprogram (Ent) then
23684 ("argument for pragma% cannot be abstract", Arg);
23686 end Check_OK_Stream_Convert_Function;
23688 -- Start of processing for Stream_Convert
23692 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23693 Check_Arg_Count (3);
23694 Check_Optional_Identifier (Arg1, Name_Entity);
23695 Check_Optional_Identifier (Arg2, Name_Read);
23696 Check_Optional_Identifier (Arg3, Name_Write);
23697 Check_Arg_Is_Local_Name (Arg1);
23698 Check_OK_Stream_Convert_Function (Arg2);
23699 Check_OK_Stream_Convert_Function (Arg3);
23702 Typ : constant Entity_Id :=
23703 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23704 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23705 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23708 Check_First_Subtype (Arg1);
23710 -- Check for too early or too late. Note that we don't enforce
23711 -- the rule about primitive operations in this case, since, as
23712 -- is the case for explicit stream attributes themselves, these
23713 -- restrictions are not appropriate. Note that the chaining of
23714 -- the pragma by Rep_Item_Too_Late is actually the critical
23715 -- processing done for this pragma.
23717 if Rep_Item_Too_Early (Typ, N)
23719 Rep_Item_Too_Late (Typ, N, FOnly => True)
23724 -- Return if previous error
23726 if Etype (Typ) = Any_Type
23728 Etype (Read) = Any_Type
23730 Etype (Write) = Any_Type
23737 if Underlying_Type (Etype (Read)) /= Typ then
23739 ("incorrect return type for function&", Arg2);
23742 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23744 ("incorrect parameter type for function&", Arg3);
23747 if Underlying_Type (Etype (First_Formal (Read))) /=
23748 Underlying_Type (Etype (Write))
23751 ("result type of & does not match Read parameter type",
23755 end Stream_Convert;
23761 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23763 -- This is processed by the parser since some of the style checks
23764 -- take place during source scanning and parsing. This means that
23765 -- we don't need to issue error messages here.
23767 when Pragma_Style_Checks => Style_Checks : declare
23768 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23774 Check_No_Identifiers;
23776 -- Two argument form
23778 if Arg_Count = 2 then
23779 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23786 E_Id := Get_Pragma_Arg (Arg2);
23789 if not Is_Entity_Name (E_Id) then
23791 ("second argument of pragma% must be entity name",
23795 E := Entity (E_Id);
23797 if not Ignore_Style_Checks_Pragmas then
23802 Set_Suppress_Style_Checks
23803 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23804 exit when No (Homonym (E));
23811 -- One argument form
23814 Check_Arg_Count (1);
23816 if Nkind (A) = N_String_Literal then
23820 Slen : constant Natural := Natural (String_Length (S));
23821 Options : String (1 .. Slen);
23827 C := Get_String_Char (S, Pos (J));
23828 exit when not In_Character_Range (C);
23829 Options (J) := Get_Character (C);
23831 -- If at end of string, set options. As per discussion
23832 -- above, no need to check for errors, since we issued
23833 -- them in the parser.
23836 if not Ignore_Style_Checks_Pragmas then
23837 Set_Style_Check_Options (Options);
23847 elsif Nkind (A) = N_Identifier then
23848 if Chars (A) = Name_All_Checks then
23849 if not Ignore_Style_Checks_Pragmas then
23851 Set_GNAT_Style_Check_Options;
23853 Set_Default_Style_Check_Options;
23857 elsif Chars (A) = Name_On then
23858 if not Ignore_Style_Checks_Pragmas then
23859 Style_Check := True;
23862 elsif Chars (A) = Name_Off then
23863 if not Ignore_Style_Checks_Pragmas then
23864 Style_Check := False;
23871 ------------------------
23872 -- Subprogram_Variant --
23873 ------------------------
23875 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM
23876 -- {, SUBPROGRAM_VARIANT_ITEM } );
23878 -- SUBPROGRAM_VARIANT_ITEM ::=
23879 -- CHANGE_DIRECTION => discrete_EXPRESSION
23881 -- CHANGE_DIRECTION ::= Increases | Decreases
23883 -- Characteristics:
23885 -- * Analysis - The annotation undergoes initial checks to verify
23886 -- the legal placement and context. Secondary checks preanalyze the
23889 -- Analyze_Subprogram_Variant_In_Decl_Part
23891 -- * Expansion - The annotation is expanded during the expansion of
23892 -- the related subprogram [body] contract as performed in:
23894 -- Expand_Subprogram_Contract
23896 -- * Template - The annotation utilizes the generic template of the
23897 -- related subprogram [body] when it is:
23899 -- aspect on subprogram declaration
23900 -- aspect on stand-alone subprogram body
23901 -- pragma on stand-alone subprogram body
23903 -- The annotation must prepare its own template when it is:
23905 -- pragma on subprogram declaration
23907 -- * Globals - Capture of global references must occur after full
23910 -- * Instance - The annotation is instantiated automatically when
23911 -- the related generic subprogram [body] is instantiated except for
23912 -- the "pragma on subprogram declaration" case. In that scenario
23913 -- the annotation must instantiate itself.
23915 when Pragma_Subprogram_Variant => Subprogram_Variant : declare
23916 Spec_Id : Entity_Id;
23917 Subp_Decl : Node_Id;
23918 Subp_Spec : Node_Id;
23922 Check_No_Identifiers;
23923 Check_Arg_Count (1);
23925 -- Ensure the proper placement of the pragma. Subprogram_Variant
23926 -- must be associated with a subprogram declaration or a body that
23930 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23932 -- Generic subprogram
23934 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23937 -- Body acts as spec
23939 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23940 and then No (Corresponding_Spec (Subp_Decl))
23944 -- Body stub acts as spec
23946 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23947 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23953 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23954 Subp_Spec := Specification (Subp_Decl);
23956 -- Pragma Subprogram_Variant is forbidden on null procedures,
23957 -- as this may lead to potential ambiguities in behavior when
23958 -- interface null procedures are involved. Also, it just
23959 -- wouldn't make sense, because null procedure is not
23962 if Nkind (Subp_Spec) = N_Procedure_Specification
23963 and then Null_Present (Subp_Spec)
23965 Error_Msg_N (Fix_Error
23966 ("pragma % cannot apply to null procedure"), N);
23975 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23977 -- A pragma that applies to a Ghost entity becomes Ghost for the
23978 -- purposes of legality checks and removal of ignored Ghost code.
23980 Mark_Ghost_Pragma (N, Spec_Id);
23981 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
23983 -- Chain the pragma on the contract for further processing by
23984 -- Analyze_Subprogram_Variant_In_Decl_Part.
23986 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
23988 -- Fully analyze the pragma when it appears inside a subprogram
23989 -- body because it cannot benefit from forward references.
23991 if Nkind (Subp_Decl) in N_Subprogram_Body
23992 | N_Subprogram_Body_Stub
23994 -- The legality checks of pragma Subprogram_Variant are
23995 -- affected by the SPARK mode in effect and the volatility
23996 -- of the context. Analyze all pragmas in a specific order.
23998 Analyze_If_Present (Pragma_SPARK_Mode);
23999 Analyze_If_Present (Pragma_Volatile_Function);
24000 Analyze_Subprogram_Variant_In_Decl_Part (N);
24002 end Subprogram_Variant;
24008 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24010 when Pragma_Subtitle =>
24012 Check_Arg_Count (1);
24013 Check_Optional_Identifier (Arg1, Name_Subtitle);
24014 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24021 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24023 when Pragma_Suppress =>
24024 Process_Suppress_Unsuppress (Suppress_Case => True);
24030 -- pragma Suppress_All;
24032 -- The only check made here is that the pragma has no arguments.
24033 -- There are no placement rules, and the processing required (setting
24034 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24035 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24036 -- then creates and inserts a pragma Suppress (All_Checks).
24038 when Pragma_Suppress_All =>
24040 Check_Arg_Count (0);
24042 -------------------------
24043 -- Suppress_Debug_Info --
24044 -------------------------
24046 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24048 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24049 Nam_Id : Entity_Id;
24053 Check_Arg_Count (1);
24054 Check_Optional_Identifier (Arg1, Name_Entity);
24055 Check_Arg_Is_Local_Name (Arg1);
24057 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24059 -- A pragma that applies to a Ghost entity becomes Ghost for the
24060 -- purposes of legality checks and removal of ignored Ghost code.
24062 Mark_Ghost_Pragma (N, Nam_Id);
24063 Set_Debug_Info_Off (Nam_Id);
24064 end Suppress_Debug_Info;
24066 ----------------------------------
24067 -- Suppress_Exception_Locations --
24068 ----------------------------------
24070 -- pragma Suppress_Exception_Locations;
24072 when Pragma_Suppress_Exception_Locations =>
24074 Check_Arg_Count (0);
24075 Check_Valid_Configuration_Pragma;
24076 Exception_Locations_Suppressed := True;
24078 -----------------------------
24079 -- Suppress_Initialization --
24080 -----------------------------
24082 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24084 when Pragma_Suppress_Initialization => Suppress_Init : declare
24090 Check_Arg_Count (1);
24091 Check_Optional_Identifier (Arg1, Name_Entity);
24092 Check_Arg_Is_Local_Name (Arg1);
24094 E_Id := Get_Pragma_Arg (Arg1);
24096 if Etype (E_Id) = Any_Type then
24100 E := Entity (E_Id);
24102 -- A pragma that applies to a Ghost entity becomes Ghost for the
24103 -- purposes of legality checks and removal of ignored Ghost code.
24105 Mark_Ghost_Pragma (N, E);
24107 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24109 ("pragma% requires variable, type or subtype", Arg1);
24112 if Rep_Item_Too_Early (E, N)
24114 Rep_Item_Too_Late (E, N, FOnly => True)
24119 -- For incomplete/private type, set flag on full view
24121 if Is_Incomplete_Or_Private_Type (E) then
24122 if No (Full_View (Base_Type (E))) then
24124 ("argument of pragma% cannot be an incomplete type", Arg1);
24126 Set_Suppress_Initialization (Full_View (E));
24129 -- For first subtype, set flag on base type
24131 elsif Is_First_Subtype (E) then
24132 Set_Suppress_Initialization (Base_Type (E));
24134 -- For other than first subtype, set flag on subtype or variable
24137 Set_Suppress_Initialization (E);
24145 -- pragma System_Name (DIRECT_NAME);
24147 -- Syntax check: one argument, which must be the identifier GNAT or
24148 -- the identifier GCC, no other identifiers are acceptable.
24150 when Pragma_System_Name =>
24152 Check_No_Identifiers;
24153 Check_Arg_Count (1);
24154 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24156 -----------------------------
24157 -- Task_Dispatching_Policy --
24158 -----------------------------
24160 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24162 when Pragma_Task_Dispatching_Policy => declare
24166 Check_Ada_83_Warning;
24167 Check_Arg_Count (1);
24168 Check_No_Identifiers;
24169 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24170 Check_Valid_Configuration_Pragma;
24171 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24172 DP := Fold_Upper (Name_Buffer (1));
24174 if Task_Dispatching_Policy /= ' '
24175 and then Task_Dispatching_Policy /= DP
24177 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24179 ("task dispatching policy incompatible with policy#");
24181 -- Set new policy, but always preserve System_Location since we
24182 -- like the error message with the run time name.
24185 Task_Dispatching_Policy := DP;
24187 if Task_Dispatching_Policy_Sloc /= System_Location then
24188 Task_Dispatching_Policy_Sloc := Loc;
24197 -- pragma Task_Info (EXPRESSION);
24199 when Pragma_Task_Info => Task_Info : declare
24200 P : constant Node_Id := Parent (N);
24206 if Warn_On_Obsolescent_Feature then
24208 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24209 & "instead?j?", N);
24212 if Nkind (P) /= N_Task_Definition then
24213 Error_Pragma ("pragma% must appear in task definition");
24216 Check_No_Identifiers;
24217 Check_Arg_Count (1);
24219 Analyze_And_Resolve
24220 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24222 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24226 Ent := Defining_Identifier (Parent (P));
24228 -- Check duplicate pragma before we chain the pragma in the Rep
24229 -- Item chain of Ent.
24232 (Ent, Name_Task_Info, Check_Parents => False)
24234 Error_Pragma ("duplicate pragma% not allowed");
24237 Record_Rep_Item (Ent, N);
24244 -- pragma Task_Name (string_EXPRESSION);
24246 when Pragma_Task_Name => Task_Name : declare
24247 P : constant Node_Id := Parent (N);
24252 Check_No_Identifiers;
24253 Check_Arg_Count (1);
24255 Arg := Get_Pragma_Arg (Arg1);
24257 -- The expression is used in the call to Create_Task, and must be
24258 -- expanded there, not in the context of the current spec. It must
24259 -- however be analyzed to capture global references, in case it
24260 -- appears in a generic context.
24262 Preanalyze_And_Resolve (Arg, Standard_String);
24264 if Nkind (P) /= N_Task_Definition then
24268 Ent := Defining_Identifier (Parent (P));
24270 -- Check duplicate pragma before we chain the pragma in the Rep
24271 -- Item chain of Ent.
24274 (Ent, Name_Task_Name, Check_Parents => False)
24276 Error_Pragma ("duplicate pragma% not allowed");
24279 Record_Rep_Item (Ent, N);
24286 -- pragma Task_Storage (
24287 -- [Task_Type =>] LOCAL_NAME,
24288 -- [Top_Guard =>] static_integer_EXPRESSION);
24290 when Pragma_Task_Storage => Task_Storage : declare
24291 Args : Args_List (1 .. 2);
24292 Names : constant Name_List (1 .. 2) := (
24296 Task_Type : Node_Id renames Args (1);
24297 Top_Guard : Node_Id renames Args (2);
24303 Gather_Associations (Names, Args);
24305 if No (Task_Type) then
24307 ("missing task_type argument for pragma%");
24310 Check_Arg_Is_Local_Name (Task_Type);
24312 Ent := Entity (Task_Type);
24314 if not Is_Task_Type (Ent) then
24316 ("argument for pragma% must be task type", Task_Type);
24319 if No (Top_Guard) then
24321 ("pragma% takes two arguments", Task_Type);
24323 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24326 Check_First_Subtype (Task_Type);
24328 if Rep_Item_Too_Late (Ent, N) then
24337 -- pragma Test_Case
24338 -- ([Name =>] Static_String_EXPRESSION
24339 -- ,[Mode =>] MODE_TYPE
24340 -- [, Requires => Boolean_EXPRESSION]
24341 -- [, Ensures => Boolean_EXPRESSION]);
24343 -- MODE_TYPE ::= Nominal | Robustness
24345 -- Characteristics:
24347 -- * Analysis - The annotation undergoes initial checks to verify
24348 -- the legal placement and context. Secondary checks preanalyze the
24351 -- Analyze_Test_Case_In_Decl_Part
24353 -- * Expansion - None.
24355 -- * Template - The annotation utilizes the generic template of the
24356 -- related subprogram when it is:
24358 -- aspect on subprogram declaration
24360 -- The annotation must prepare its own template when it is:
24362 -- pragma on subprogram declaration
24364 -- * Globals - Capture of global references must occur after full
24367 -- * Instance - The annotation is instantiated automatically when
24368 -- the related generic subprogram is instantiated except for the
24369 -- "pragma on subprogram declaration" case. In that scenario the
24370 -- annotation must instantiate itself.
24372 when Pragma_Test_Case => Test_Case : declare
24373 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24374 -- Ensure that the contract of subprogram Subp_Id does not contain
24375 -- another Test_Case pragma with the same Name as the current one.
24377 -------------------------
24378 -- Check_Distinct_Name --
24379 -------------------------
24381 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24382 Items : constant Node_Id := Contract (Subp_Id);
24383 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24387 -- Inspect all Test_Case pragma of the related subprogram
24388 -- looking for one with a duplicate "Name" argument.
24390 if Present (Items) then
24391 Prag := Contract_Test_Cases (Items);
24392 while Present (Prag) loop
24393 if Pragma_Name (Prag) = Name_Test_Case
24395 and then String_Equal
24396 (Name, Get_Name_From_CTC_Pragma (Prag))
24398 Error_Msg_Sloc := Sloc (Prag);
24399 Error_Pragma ("name for pragma % is already used #");
24402 Prag := Next_Pragma (Prag);
24405 end Check_Distinct_Name;
24409 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24412 Subp_Decl : Node_Id;
24413 Subp_Id : Entity_Id;
24415 -- Start of processing for Test_Case
24419 Check_At_Least_N_Arguments (2);
24420 Check_At_Most_N_Arguments (4);
24422 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24426 Check_Optional_Identifier (Arg1, Name_Name);
24427 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24431 Check_Optional_Identifier (Arg2, Name_Mode);
24432 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24434 -- Arguments "Requires" and "Ensures"
24436 if Present (Arg3) then
24437 if Present (Arg4) then
24438 Check_Identifier (Arg3, Name_Requires);
24439 Check_Identifier (Arg4, Name_Ensures);
24441 Check_Identifier_Is_One_Of
24442 (Arg3, Name_Requires, Name_Ensures);
24446 -- Pragma Test_Case must be associated with a subprogram declared
24447 -- in a library-level package. First determine whether the current
24448 -- compilation unit is a legal context.
24450 if Nkind (Pack_Decl) in N_Package_Declaration
24451 | N_Generic_Package_Declaration
24455 -- Otherwise the placement is illegal
24459 ("pragma % must be specified within a package declaration");
24463 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24465 -- Find the enclosing context
24467 Context := Parent (Subp_Decl);
24469 if Present (Context) then
24470 Context := Parent (Context);
24473 -- Verify the placement of the pragma
24475 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24477 ("pragma % cannot be applied to abstract subprogram");
24480 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24481 Error_Pragma ("pragma % cannot be applied to entry");
24484 -- The context is a [generic] subprogram declared at the top level
24485 -- of the [generic] package unit.
24487 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
24488 | N_Subprogram_Declaration
24489 and then Present (Context)
24490 and then Nkind (Context) in N_Generic_Package_Declaration
24491 | N_Package_Declaration
24495 -- Otherwise the placement is illegal
24499 ("pragma % must be applied to a library-level subprogram "
24504 Subp_Id := Defining_Entity (Subp_Decl);
24506 -- A pragma that applies to a Ghost entity becomes Ghost for the
24507 -- purposes of legality checks and removal of ignored Ghost code.
24509 Mark_Ghost_Pragma (N, Subp_Id);
24511 -- Chain the pragma on the contract for further processing by
24512 -- Analyze_Test_Case_In_Decl_Part.
24514 Add_Contract_Item (N, Subp_Id);
24516 -- Preanalyze the original aspect argument "Name" for a generic
24517 -- subprogram to properly capture global references.
24519 if Is_Generic_Subprogram (Subp_Id) then
24520 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24522 if Present (Asp_Arg) then
24524 -- The argument appears with an identifier in association
24527 if Nkind (Asp_Arg) = N_Component_Association then
24528 Asp_Arg := Expression (Asp_Arg);
24531 Check_Expr_Is_OK_Static_Expression
24532 (Asp_Arg, Standard_String);
24536 -- Ensure that the all Test_Case pragmas of the related subprogram
24537 -- have distinct names.
24539 Check_Distinct_Name (Subp_Id);
24541 -- Fully analyze the pragma when it appears inside an entry
24542 -- or subprogram body because it cannot benefit from forward
24545 if Nkind (Subp_Decl) in N_Entry_Body
24546 | N_Subprogram_Body
24547 | N_Subprogram_Body_Stub
24549 -- The legality checks of pragma Test_Case are affected by the
24550 -- SPARK mode in effect and the volatility of the context.
24551 -- Analyze all pragmas in a specific order.
24553 Analyze_If_Present (Pragma_SPARK_Mode);
24554 Analyze_If_Present (Pragma_Volatile_Function);
24555 Analyze_Test_Case_In_Decl_Part (N);
24559 --------------------------
24560 -- Thread_Local_Storage --
24561 --------------------------
24563 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24565 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24571 Check_Arg_Count (1);
24572 Check_Optional_Identifier (Arg1, Name_Entity);
24573 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24575 Id := Get_Pragma_Arg (Arg1);
24578 if not Is_Entity_Name (Id)
24579 or else Ekind (Entity (Id)) /= E_Variable
24581 Error_Pragma_Arg ("local variable name required", Arg1);
24586 -- A pragma that applies to a Ghost entity becomes Ghost for the
24587 -- purposes of legality checks and removal of ignored Ghost code.
24589 Mark_Ghost_Pragma (N, E);
24591 if Rep_Item_Too_Early (E, N)
24593 Rep_Item_Too_Late (E, N)
24598 Set_Has_Pragma_Thread_Local_Storage (E);
24599 Set_Has_Gigi_Rep_Item (E);
24600 end Thread_Local_Storage;
24606 -- pragma Time_Slice (static_duration_EXPRESSION);
24608 when Pragma_Time_Slice => Time_Slice : declare
24614 Check_Arg_Count (1);
24615 Check_No_Identifiers;
24616 Check_In_Main_Program;
24617 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24619 if not Error_Posted (Arg1) then
24621 while Present (Nod) loop
24622 if Nkind (Nod) = N_Pragma
24623 and then Pragma_Name (Nod) = Name_Time_Slice
24625 Error_Msg_Name_1 := Pname;
24626 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24633 -- Process only if in main unit
24635 if Get_Source_Unit (Loc) = Main_Unit then
24636 Opt.Time_Slice_Set := True;
24637 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24639 if Val <= Ureal_0 then
24640 Opt.Time_Slice_Value := 0;
24642 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24643 Opt.Time_Slice_Value := 1_000_000_000;
24646 Opt.Time_Slice_Value :=
24647 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24656 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24658 -- TITLING_OPTION ::=
24659 -- [Title =>] STRING_LITERAL
24660 -- | [Subtitle =>] STRING_LITERAL
24662 when Pragma_Title => Title : declare
24663 Args : Args_List (1 .. 2);
24664 Names : constant Name_List (1 .. 2) := (
24670 Gather_Associations (Names, Args);
24673 for J in 1 .. 2 loop
24674 if Present (Args (J)) then
24675 Check_Arg_Is_OK_Static_Expression
24676 (Args (J), Standard_String);
24681 ----------------------------
24682 -- Type_Invariant[_Class] --
24683 ----------------------------
24685 -- pragma Type_Invariant[_Class]
24686 -- ([Entity =>] type_LOCAL_NAME,
24687 -- [Check =>] EXPRESSION);
24689 when Pragma_Type_Invariant
24690 | Pragma_Type_Invariant_Class
24692 Type_Invariant : declare
24693 I_Pragma : Node_Id;
24696 Check_Arg_Count (2);
24698 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24699 -- setting Class_Present for the Type_Invariant_Class case.
24701 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24702 I_Pragma := New_Copy (N);
24703 Set_Pragma_Identifier
24704 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24705 Rewrite (N, I_Pragma);
24706 Set_Analyzed (N, False);
24708 end Type_Invariant;
24710 ---------------------
24711 -- Unchecked_Union --
24712 ---------------------
24714 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24716 when Pragma_Unchecked_Union => Unchecked_Union : declare
24717 Assoc : constant Node_Id := Arg1;
24718 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24728 Check_No_Identifiers;
24729 Check_Arg_Count (1);
24730 Check_Arg_Is_Local_Name (Arg1);
24732 Find_Type (Type_Id);
24734 Typ := Entity (Type_Id);
24736 -- A pragma that applies to a Ghost entity becomes Ghost for the
24737 -- purposes of legality checks and removal of ignored Ghost code.
24739 Mark_Ghost_Pragma (N, Typ);
24742 or else Rep_Item_Too_Early (Typ, N)
24746 Typ := Underlying_Type (Typ);
24749 if Rep_Item_Too_Late (Typ, N) then
24753 Check_First_Subtype (Arg1);
24755 -- Note remaining cases are references to a type in the current
24756 -- declarative part. If we find an error, we post the error on
24757 -- the relevant type declaration at an appropriate point.
24759 if not Is_Record_Type (Typ) then
24760 Error_Msg_N ("unchecked union must be record type", Typ);
24763 elsif Is_Tagged_Type (Typ) then
24764 Error_Msg_N ("unchecked union must not be tagged", Typ);
24767 elsif not Has_Discriminants (Typ) then
24769 ("unchecked union must have one discriminant", Typ);
24772 -- Note: in previous versions of GNAT we used to check for limited
24773 -- types and give an error, but in fact the standard does allow
24774 -- Unchecked_Union on limited types, so this check was removed.
24776 -- Similarly, GNAT used to require that all discriminants have
24777 -- default values, but this is not mandated by the RM.
24779 -- Proceed with basic error checks completed
24782 Tdef := Type_Definition (Declaration_Node (Typ));
24783 Clist := Component_List (Tdef);
24785 -- Check presence of component list and variant part
24787 if No (Clist) or else No (Variant_Part (Clist)) then
24789 ("unchecked union must have variant part", Tdef);
24793 -- Check components
24795 Comp := First_Non_Pragma (Component_Items (Clist));
24796 while Present (Comp) loop
24797 Check_Component (Comp, Typ);
24798 Next_Non_Pragma (Comp);
24801 -- Check variant part
24803 Vpart := Variant_Part (Clist);
24805 Variant := First_Non_Pragma (Variants (Vpart));
24806 while Present (Variant) loop
24807 Check_Variant (Variant, Typ);
24808 Next_Non_Pragma (Variant);
24812 Set_Is_Unchecked_Union (Typ);
24813 Set_Convention (Typ, Convention_C);
24814 Set_Has_Unchecked_Union (Base_Type (Typ));
24815 Set_Is_Unchecked_Union (Base_Type (Typ));
24816 end Unchecked_Union;
24818 ----------------------------
24819 -- Unevaluated_Use_Of_Old --
24820 ----------------------------
24822 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24824 when Pragma_Unevaluated_Use_Of_Old =>
24826 Check_Arg_Count (1);
24827 Check_No_Identifiers;
24828 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24830 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24831 -- a declarative part or a package spec.
24833 if not Is_Configuration_Pragma then
24834 Check_Is_In_Decl_Part_Or_Package_Spec;
24837 -- Store proper setting of Uneval_Old
24839 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24840 Uneval_Old := Fold_Upper (Name_Buffer (1));
24842 ------------------------
24843 -- Unimplemented_Unit --
24844 ------------------------
24846 -- pragma Unimplemented_Unit;
24848 -- Note: this only gives an error if we are generating code, or if
24849 -- we are in a generic library unit (where the pragma appears in the
24850 -- body, not in the spec).
24852 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24853 Cunitent : constant Entity_Id :=
24854 Cunit_Entity (Get_Source_Unit (Loc));
24858 Check_Arg_Count (0);
24860 if Operating_Mode = Generate_Code
24861 or else Is_Generic_Unit (Cunitent)
24863 Get_Name_String (Chars (Cunitent));
24864 Set_Casing (Mixed_Case);
24865 Write_Str (Name_Buffer (1 .. Name_Len));
24866 Write_Str (" is not supported in this configuration");
24868 raise Unrecoverable_Error;
24870 end Unimplemented_Unit;
24872 ------------------------
24873 -- Universal_Aliasing --
24874 ------------------------
24876 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24878 when Pragma_Universal_Aliasing => Universal_Alias : declare
24884 Check_Arg_Count (1);
24885 Check_Optional_Identifier (Arg2, Name_Entity);
24886 Check_Arg_Is_Local_Name (Arg1);
24887 E_Id := Get_Pragma_Arg (Arg1);
24889 if Etype (E_Id) = Any_Type then
24893 E := Entity (E_Id);
24895 if not Is_Type (E) then
24896 Error_Pragma_Arg ("pragma% requires type", Arg1);
24899 -- A pragma that applies to a Ghost entity becomes Ghost for the
24900 -- purposes of legality checks and removal of ignored Ghost code.
24902 Mark_Ghost_Pragma (N, E);
24903 Set_Universal_Aliasing (Base_Type (E));
24904 Record_Rep_Item (E, N);
24905 end Universal_Alias;
24907 --------------------
24908 -- Universal_Data --
24909 --------------------
24911 -- pragma Universal_Data [(library_unit_NAME)];
24913 when Pragma_Universal_Data =>
24915 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24921 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24923 when Pragma_Unmodified =>
24924 Analyze_Unmodified_Or_Unused;
24930 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24932 -- or when used in a context clause:
24934 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24936 when Pragma_Unreferenced =>
24937 Analyze_Unreferenced_Or_Unused;
24939 --------------------------
24940 -- Unreferenced_Objects --
24941 --------------------------
24943 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24945 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24947 Arg_Expr : Node_Id;
24948 Arg_Id : Entity_Id;
24950 Ghost_Error_Posted : Boolean := False;
24951 -- Flag set when an error concerning the illegal mix of Ghost and
24952 -- non-Ghost types is emitted.
24954 Ghost_Id : Entity_Id := Empty;
24955 -- The entity of the first Ghost type encountered while processing
24956 -- the arguments of the pragma.
24960 Check_At_Least_N_Arguments (1);
24963 while Present (Arg) loop
24964 Check_No_Identifier (Arg);
24965 Check_Arg_Is_Local_Name (Arg);
24966 Arg_Expr := Get_Pragma_Arg (Arg);
24968 if Is_Entity_Name (Arg_Expr) then
24969 Arg_Id := Entity (Arg_Expr);
24971 if Is_Type (Arg_Id) then
24972 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24974 -- A pragma that applies to a Ghost entity becomes Ghost
24975 -- for the purposes of legality checks and removal of
24976 -- ignored Ghost code.
24978 Mark_Ghost_Pragma (N, Arg_Id);
24980 -- Capture the entity of the first Ghost type being
24981 -- processed for error detection purposes.
24983 if Is_Ghost_Entity (Arg_Id) then
24984 if No (Ghost_Id) then
24985 Ghost_Id := Arg_Id;
24988 -- Otherwise the type is non-Ghost. It is illegal to mix
24989 -- references to Ghost and non-Ghost entities
24992 elsif Present (Ghost_Id)
24993 and then not Ghost_Error_Posted
24995 Ghost_Error_Posted := True;
24997 Error_Msg_Name_1 := Pname;
24999 ("pragma % cannot mention ghost and non-ghost types",
25002 Error_Msg_Sloc := Sloc (Ghost_Id);
25003 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25005 Error_Msg_Sloc := Sloc (Arg_Id);
25006 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25010 ("argument for pragma% must be type or subtype", Arg);
25014 ("argument for pragma% must be type or subtype", Arg);
25019 end Unreferenced_Objects;
25021 ------------------------------
25022 -- Unreserve_All_Interrupts --
25023 ------------------------------
25025 -- pragma Unreserve_All_Interrupts;
25027 when Pragma_Unreserve_All_Interrupts =>
25029 Check_Arg_Count (0);
25031 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25032 Unreserve_All_Interrupts := True;
25039 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25041 when Pragma_Unsuppress =>
25043 Process_Suppress_Unsuppress (Suppress_Case => False);
25049 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25051 when Pragma_Unused =>
25052 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25053 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25055 -------------------
25056 -- Use_VADS_Size --
25057 -------------------
25059 -- pragma Use_VADS_Size;
25061 when Pragma_Use_VADS_Size =>
25063 Check_Arg_Count (0);
25064 Check_Valid_Configuration_Pragma;
25065 Use_VADS_Size := True;
25067 ---------------------
25068 -- Validity_Checks --
25069 ---------------------
25071 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25073 when Pragma_Validity_Checks => Validity_Checks : declare
25074 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25080 Check_Arg_Count (1);
25081 Check_No_Identifiers;
25083 -- Pragma always active unless in CodePeer or GNATprove modes,
25084 -- which use a fixed configuration of validity checks.
25086 if not (CodePeer_Mode or GNATprove_Mode) then
25087 if Nkind (A) = N_String_Literal then
25091 Slen : constant Natural := Natural (String_Length (S));
25092 Options : String (1 .. Slen);
25096 -- Couldn't we use a for loop here over Options'Range???
25100 C := Get_String_Char (S, Pos (J));
25102 -- This is a weird test, it skips setting validity
25103 -- checks entirely if any element of S is out of
25104 -- range of Character, what is that about ???
25106 exit when not In_Character_Range (C);
25107 Options (J) := Get_Character (C);
25110 Set_Validity_Check_Options (Options);
25118 elsif Nkind (A) = N_Identifier then
25119 if Chars (A) = Name_All_Checks then
25120 Set_Validity_Check_Options ("a");
25121 elsif Chars (A) = Name_On then
25122 Validity_Checks_On := True;
25123 elsif Chars (A) = Name_Off then
25124 Validity_Checks_On := False;
25128 end Validity_Checks;
25134 -- pragma Volatile (LOCAL_NAME);
25136 when Pragma_Volatile =>
25137 Process_Atomic_Independent_Shared_Volatile;
25139 -------------------------
25140 -- Volatile_Components --
25141 -------------------------
25143 -- pragma Volatile_Components (array_LOCAL_NAME);
25145 -- Volatile is handled by the same circuit as Atomic_Components
25147 --------------------------
25148 -- Volatile_Full_Access --
25149 --------------------------
25151 -- pragma Volatile_Full_Access (LOCAL_NAME);
25153 when Pragma_Volatile_Full_Access =>
25155 Process_Atomic_Independent_Shared_Volatile;
25157 -----------------------
25158 -- Volatile_Function --
25159 -----------------------
25161 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25163 when Pragma_Volatile_Function => Volatile_Function : declare
25164 Over_Id : Entity_Id;
25165 Spec_Id : Entity_Id;
25166 Subp_Decl : Node_Id;
25170 Check_No_Identifiers;
25171 Check_At_Most_N_Arguments (1);
25174 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25176 -- Generic subprogram
25178 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25181 -- Body acts as spec
25183 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25184 and then No (Corresponding_Spec (Subp_Decl))
25188 -- Body stub acts as spec
25190 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25191 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25197 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25205 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25207 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
25212 -- A pragma that applies to a Ghost entity becomes Ghost for the
25213 -- purposes of legality checks and removal of ignored Ghost code.
25215 Mark_Ghost_Pragma (N, Spec_Id);
25217 -- Chain the pragma on the contract for completeness
25219 Add_Contract_Item (N, Spec_Id);
25221 -- The legality checks of pragma Volatile_Function are affected by
25222 -- the SPARK mode in effect. Analyze all pragmas in a specific
25225 Analyze_If_Present (Pragma_SPARK_Mode);
25227 -- A volatile function cannot override a non-volatile function
25228 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25229 -- in New_Overloaded_Entity, however at that point the pragma has
25230 -- not been processed yet.
25232 Over_Id := Overridden_Operation (Spec_Id);
25234 if Present (Over_Id)
25235 and then not Is_Volatile_Function (Over_Id)
25238 ("incompatible volatile function values in effect", Spec_Id);
25240 Error_Msg_Sloc := Sloc (Over_Id);
25242 ("\& declared # with Volatile_Function value False",
25245 Error_Msg_Sloc := Sloc (Spec_Id);
25247 ("\overridden # with Volatile_Function value True",
25251 -- Analyze the Boolean expression (if any)
25253 if Present (Arg1) then
25254 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25256 end Volatile_Function;
25258 ----------------------
25259 -- Warning_As_Error --
25260 ----------------------
25262 -- pragma Warning_As_Error (static_string_EXPRESSION);
25264 when Pragma_Warning_As_Error =>
25266 Check_Arg_Count (1);
25267 Check_No_Identifiers;
25268 Check_Valid_Configuration_Pragma;
25270 if not Is_Static_String_Expression (Arg1) then
25272 ("argument of pragma% must be static string expression",
25275 -- OK static string expression
25278 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25279 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25280 new String'(Acquire_Warning_Match_String
25281 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25288 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25290 -- DETAILS ::= On | Off
25291 -- DETAILS ::= On | Off, local_NAME
25292 -- DETAILS ::= static_string_EXPRESSION
25293 -- DETAILS ::= On | Off, static_string_EXPRESSION
25295 -- TOOL_NAME ::= GNAT | GNATprove
25297 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25299 -- Note: If the first argument matches an allowed tool name, it is
25300 -- always considered to be a tool name, even if there is a string
25301 -- variable of that name.
25303 -- Note if the second argument of DETAILS is a local_NAME then the
25304 -- second form is always understood. If the intention is to use
25305 -- the fourth form, then you can write NAME & "" to force the
25306 -- intepretation as a static_string_EXPRESSION.
25308 when Pragma_Warnings => Warnings : declare
25309 Reason : String_Id;
25313 Check_At_Least_N_Arguments (1);
25315 -- See if last argument is labeled Reason. If so, make sure we
25316 -- have a string literal or a concatenation of string literals,
25317 -- and acquire the REASON string. Then remove the REASON argument
25318 -- by decreasing Num_Args by one; Remaining processing looks only
25319 -- at first Num_Args arguments).
25322 Last_Arg : constant Node_Id :=
25323 Last (Pragma_Argument_Associations (N));
25326 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25327 and then Chars (Last_Arg) = Name_Reason
25330 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25331 Reason := End_String;
25332 Arg_Count := Arg_Count - 1;
25334 -- Not allowed in compiler units (bootstrap issues)
25336 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25338 -- No REASON string, set null string as reason
25341 Reason := Null_String_Id;
25345 -- Now proceed with REASON taken care of and eliminated
25347 Check_No_Identifiers;
25349 -- If debug flag -gnatd.i is set, pragma is ignored
25351 if Debug_Flag_Dot_I then
25355 -- Process various forms of the pragma
25358 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25359 Shifted_Args : List_Id;
25362 -- See if first argument is a tool name, currently either
25363 -- GNAT or GNATprove. If so, either ignore the pragma if the
25364 -- tool used does not match, or continue as if no tool name
25365 -- was given otherwise, by shifting the arguments.
25367 if Nkind (Argx) = N_Identifier
25368 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25370 if Chars (Argx) = Name_Gnat then
25371 if CodePeer_Mode or GNATprove_Mode then
25372 Rewrite (N, Make_Null_Statement (Loc));
25377 elsif Chars (Argx) = Name_Gnatprove then
25378 if not GNATprove_Mode then
25379 Rewrite (N, Make_Null_Statement (Loc));
25385 raise Program_Error;
25388 -- At this point, the pragma Warnings applies to the tool,
25389 -- so continue with shifted arguments.
25391 Arg_Count := Arg_Count - 1;
25393 if Arg_Count = 1 then
25394 Shifted_Args := New_List (New_Copy (Arg2));
25395 elsif Arg_Count = 2 then
25396 Shifted_Args := New_List (New_Copy (Arg2),
25398 elsif Arg_Count = 3 then
25399 Shifted_Args := New_List (New_Copy (Arg2),
25403 raise Program_Error;
25408 Chars => Name_Warnings,
25409 Pragma_Argument_Associations => Shifted_Args));
25414 -- One argument case
25416 if Arg_Count = 1 then
25418 -- On/Off one argument case was processed by parser
25420 if Nkind (Argx) = N_Identifier
25421 and then Chars (Argx) in Name_On | Name_Off
25425 -- One argument case must be ON/OFF or static string expr
25427 elsif not Is_Static_String_Expression (Arg1) then
25429 ("argument of pragma% must be On/Off or static string "
25430 & "expression", Arg1);
25432 -- One argument string expression case
25436 Lit : constant Node_Id := Expr_Value_S (Argx);
25437 Str : constant String_Id := Strval (Lit);
25438 Len : constant Nat := String_Length (Str);
25446 while J <= Len loop
25447 C := Get_String_Char (Str, J);
25448 OK := In_Character_Range (C);
25451 Chr := Get_Character (C);
25453 -- Dash case: only -Wxxx is accepted
25460 C := Get_String_Char (Str, J);
25461 Chr := Get_Character (C);
25462 exit when Chr = 'W';
25467 elsif J < Len and then Chr = '.' then
25469 C := Get_String_Char (Str, J);
25470 Chr := Get_Character (C);
25472 if not Set_Dot_Warning_Switch (Chr) then
25474 ("invalid warning switch character "
25475 & '.' & Chr, Arg1);
25481 OK := Set_Warning_Switch (Chr);
25486 ("invalid warning switch character " & Chr,
25492 ("invalid wide character in warning switch ",
25501 -- Two or more arguments (must be two)
25504 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25505 Check_Arg_Count (2);
25513 E_Id := Get_Pragma_Arg (Arg2);
25516 -- In the expansion of an inlined body, a reference to
25517 -- the formal may be wrapped in a conversion if the
25518 -- actual is a conversion. Retrieve the real entity name.
25520 if (In_Instance_Body or In_Inlined_Body)
25521 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25523 E_Id := Expression (E_Id);
25526 -- Entity name case
25528 if Is_Entity_Name (E_Id) then
25529 E := Entity (E_Id);
25536 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25539 -- Suppress elaboration warnings if the entity
25540 -- denotes an elaboration target.
25542 if Is_Elaboration_Target (E) then
25543 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25546 -- For OFF case, make entry in warnings off
25547 -- pragma table for later processing. But we do
25548 -- not do that within an instance, since these
25549 -- warnings are about what is needed in the
25550 -- template, not an instance of it.
25552 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25553 and then Warn_On_Warnings_Off
25554 and then not In_Instance
25556 Warnings_Off_Pragmas.Append ((N, E, Reason));
25559 if Is_Enumeration_Type (E) then
25563 Lit := First_Literal (E);
25564 while Present (Lit) loop
25565 Set_Warnings_Off (Lit);
25566 Next_Literal (Lit);
25571 exit when No (Homonym (E));
25576 -- Error if not entity or static string expression case
25578 elsif not Is_Static_String_Expression (Arg2) then
25580 ("second argument of pragma% must be entity name "
25581 & "or static string expression", Arg2);
25583 -- Static string expression case
25586 -- Note on configuration pragma case: If this is a
25587 -- configuration pragma, then for an OFF pragma, we
25588 -- just set Config True in the call, which is all
25589 -- that needs to be done. For the case of ON, this
25590 -- is normally an error, unless it is canceling the
25591 -- effect of a previous OFF pragma in the same file.
25592 -- In any other case, an error will be signalled (ON
25593 -- with no matching OFF).
25595 -- Note: We set Used if we are inside a generic to
25596 -- disable the test that the non-config case actually
25597 -- cancels a warning. That's because we can't be sure
25598 -- there isn't an instantiation in some other unit
25599 -- where a warning is suppressed.
25601 -- We could do a little better here by checking if the
25602 -- generic unit we are inside is public, but for now
25603 -- we don't bother with that refinement.
25606 Message : constant String :=
25607 Acquire_Warning_Match_String
25608 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25610 if Chars (Argx) = Name_Off then
25611 Set_Specific_Warning_Off
25612 (Loc, Message, Reason,
25613 Config => Is_Configuration_Pragma,
25614 Used => Inside_A_Generic or else In_Instance);
25616 elsif Chars (Argx) = Name_On then
25617 Set_Specific_Warning_On (Loc, Message, Err);
25621 ("??pragma Warnings On with no matching "
25622 & "Warnings Off", Loc);
25632 -------------------
25633 -- Weak_External --
25634 -------------------
25636 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25638 when Pragma_Weak_External => Weak_External : declare
25643 Check_Arg_Count (1);
25644 Check_Optional_Identifier (Arg1, Name_Entity);
25645 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25646 Ent := Entity (Get_Pragma_Arg (Arg1));
25648 if Rep_Item_Too_Early (Ent, N) then
25651 Ent := Underlying_Type (Ent);
25654 -- The pragma applies to entities with addresses
25656 if Is_Type (Ent) then
25657 Error_Pragma ("pragma applies to objects and subprograms");
25660 -- The only processing required is to link this item on to the
25661 -- list of rep items for the given entity. This is accomplished
25662 -- by the call to Rep_Item_Too_Late (when no error is detected
25663 -- and False is returned).
25665 if Rep_Item_Too_Late (Ent, N) then
25668 Set_Has_Gigi_Rep_Item (Ent);
25672 -----------------------------
25673 -- Wide_Character_Encoding --
25674 -----------------------------
25676 -- pragma Wide_Character_Encoding (IDENTIFIER);
25678 when Pragma_Wide_Character_Encoding =>
25681 -- Nothing to do, handled in parser. Note that we do not enforce
25682 -- configuration pragma placement, this pragma can appear at any
25683 -- place in the source, allowing mixed encodings within a single
25688 --------------------
25689 -- Unknown_Pragma --
25690 --------------------
25692 -- Should be impossible, since the case of an unknown pragma is
25693 -- separately processed before the case statement is entered.
25695 when Unknown_Pragma =>
25696 raise Program_Error;
25699 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25700 -- until AI is formally approved.
25702 -- Check_Order_Dependence;
25705 when Pragma_Exit => null;
25706 end Analyze_Pragma;
25708 ---------------------------------------------
25709 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25710 ---------------------------------------------
25712 -- WARNING: This routine manages Ghost regions. Return statements must be
25713 -- replaced by gotos which jump to the end of the routine and restore the
25716 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25718 Freeze_Id : Entity_Id := Empty)
25720 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25721 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25723 Disp_Typ : Entity_Id;
25724 -- The dispatching type of the subprogram subject to the pre- or
25727 function Check_References (Nod : Node_Id) return Traverse_Result;
25728 -- Check that expression Nod does not mention non-primitives of the
25729 -- type, global objects of the type, or other illegalities described
25730 -- and implied by AI12-0113.
25732 ----------------------
25733 -- Check_References --
25734 ----------------------
25736 function Check_References (Nod : Node_Id) return Traverse_Result is
25738 if Nkind (Nod) = N_Function_Call
25739 and then Is_Entity_Name (Name (Nod))
25742 Func : constant Entity_Id := Entity (Name (Nod));
25746 -- An operation of the type must be a primitive
25748 if No (Find_Dispatching_Type (Func)) then
25749 Form := First_Formal (Func);
25750 while Present (Form) loop
25751 if Etype (Form) = Disp_Typ then
25753 ("operation in class-wide condition must be "
25754 & "primitive of &", Nod, Disp_Typ);
25757 Next_Formal (Form);
25760 -- A return object of the type is illegal as well
25762 if Etype (Func) = Disp_Typ
25763 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25766 ("operation in class-wide condition must be primitive "
25767 & "of &", Nod, Disp_Typ);
25770 -- Otherwise we have a call to an overridden primitive, and we
25771 -- will create a common class-wide clone for the body of
25772 -- original operation and its eventual inherited versions. If
25773 -- the original operation dispatches on result it is never
25774 -- inherited and there is no need for a clone. There is not
25775 -- need for a clone either in GNATprove mode, as cases that
25776 -- would require it are rejected (when an inherited primitive
25777 -- calls an overridden operation in a class-wide contract), and
25778 -- the clone would make proof impossible in some cases.
25780 elsif not Is_Abstract_Subprogram (Spec_Id)
25781 and then No (Class_Wide_Clone (Spec_Id))
25782 and then not Has_Controlling_Result (Spec_Id)
25783 and then not GNATprove_Mode
25785 Build_Class_Wide_Clone_Decl (Spec_Id);
25789 elsif Is_Entity_Name (Nod)
25791 (Etype (Nod) = Disp_Typ
25792 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25793 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
25796 ("object in class-wide condition must be formal of type &",
25799 elsif Nkind (Nod) = N_Explicit_Dereference
25800 and then (Etype (Nod) = Disp_Typ
25801 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25802 and then (not Is_Entity_Name (Prefix (Nod))
25803 or else not Is_Formal (Entity (Prefix (Nod))))
25806 ("operation in class-wide condition must be primitive of &",
25811 end Check_References;
25813 procedure Check_Class_Wide_Condition is
25814 new Traverse_Proc (Check_References);
25818 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25820 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25821 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25822 -- Save the Ghost-related attributes to restore on exit
25825 Restore_Scope : Boolean := False;
25827 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25830 -- Do not analyze the pragma multiple times
25832 if Is_Analyzed_Pragma (N) then
25836 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25837 -- analysis of the pragma, the Ghost mode at point of declaration and
25838 -- point of analysis may not necessarily be the same. Use the mode in
25839 -- effect at the point of declaration.
25841 Set_Ghost_Mode (N);
25843 -- Ensure that the subprogram and its formals are visible when analyzing
25844 -- the expression of the pragma.
25846 if not In_Open_Scopes (Spec_Id) then
25847 Restore_Scope := True;
25848 Push_Scope (Spec_Id);
25850 if Is_Generic_Subprogram (Spec_Id) then
25851 Install_Generic_Formals (Spec_Id);
25853 Install_Formals (Spec_Id);
25857 Errors := Serious_Errors_Detected;
25858 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25860 -- Emit a clarification message when the expression contains at least
25861 -- one undefined reference, possibly due to contract freezing.
25863 if Errors /= Serious_Errors_Detected
25864 and then Present (Freeze_Id)
25865 and then Has_Undefined_Reference (Expr)
25867 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25870 if Class_Present (N) then
25872 -- Verify that a class-wide condition is legal, i.e. the operation is
25873 -- a primitive of a tagged type. Note that a generic subprogram is
25874 -- not a primitive operation.
25876 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25878 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25879 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25881 if From_Aspect_Specification (N) then
25883 ("aspect % can only be specified for a primitive operation "
25884 & "of a tagged type", Corresponding_Aspect (N));
25886 -- The pragma is a source construct
25890 ("pragma % can only be specified for a primitive operation "
25891 & "of a tagged type", N);
25894 -- Remaining semantic checks require a full tree traversal
25897 Check_Class_Wide_Condition (Expr);
25902 if Restore_Scope then
25906 -- If analysis of the condition indicates that a class-wide clone
25907 -- has been created, build and analyze its declaration.
25909 if Is_Subprogram (Spec_Id)
25910 and then Present (Class_Wide_Clone (Spec_Id))
25912 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25915 -- Currently it is not possible to inline pre/postconditions on a
25916 -- subprogram subject to pragma Inline_Always.
25918 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25919 Set_Is_Analyzed_Pragma (N);
25921 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25922 end Analyze_Pre_Post_Condition_In_Decl_Part;
25924 ------------------------------------------
25925 -- Analyze_Refined_Depends_In_Decl_Part --
25926 ------------------------------------------
25928 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25929 procedure Check_Dependency_Clause
25930 (Spec_Id : Entity_Id;
25931 Dep_Clause : Node_Id;
25932 Dep_States : Elist_Id;
25933 Refinements : List_Id;
25934 Matched_Items : in out Elist_Id);
25935 -- Try to match a single dependency clause Dep_Clause against one or
25936 -- more refinement clauses found in list Refinements. Each successful
25937 -- match eliminates at least one refinement clause from Refinements.
25938 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25939 -- denotes the entities of all abstract states which appear in pragma
25940 -- Depends. Matched_Items contains the entities of all successfully
25941 -- matched items found in pragma Depends.
25943 procedure Check_Output_States
25944 (Spec_Inputs : Elist_Id;
25945 Spec_Outputs : Elist_Id;
25946 Body_Inputs : Elist_Id;
25947 Body_Outputs : Elist_Id);
25948 -- Determine whether pragma Depends contains an output state with a
25949 -- visible refinement and if so, ensure that pragma Refined_Depends
25950 -- mentions all its constituents as outputs. Spec_Inputs and
25951 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25952 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25953 -- the inputs and outputs of the subprogram body synthesized from pragma
25954 -- Refined_Depends.
25956 function Collect_States (Clauses : List_Id) return Elist_Id;
25957 -- Given a normalized list of dependencies obtained from calling
25958 -- Normalize_Clauses, return a list containing the entities of all
25959 -- states appearing in dependencies. It helps in checking refinements
25960 -- involving a state and a corresponding constituent which is not a
25961 -- direct constituent of the state.
25963 procedure Normalize_Clauses (Clauses : List_Id);
25964 -- Given a list of dependence or refinement clauses Clauses, normalize
25965 -- each clause by creating multiple dependencies with exactly one input
25968 procedure Remove_Extra_Clauses
25969 (Clauses : List_Id;
25970 Matched_Items : Elist_Id);
25971 -- Given a list of refinement clauses Clauses, remove all clauses whose
25972 -- inputs and/or outputs have been previously matched. See the body for
25973 -- all special cases. Matched_Items contains the entities of all matched
25974 -- items found in pragma Depends.
25976 procedure Report_Extra_Clauses (Clauses : List_Id);
25977 -- Emit an error for each extra clause found in list Clauses
25979 -----------------------------
25980 -- Check_Dependency_Clause --
25981 -----------------------------
25983 procedure Check_Dependency_Clause
25984 (Spec_Id : Entity_Id;
25985 Dep_Clause : Node_Id;
25986 Dep_States : Elist_Id;
25987 Refinements : List_Id;
25988 Matched_Items : in out Elist_Id)
25990 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25991 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25993 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25994 -- Determine whether dependency item Dep_Item has been matched in a
25995 -- previous clause.
25997 function Is_In_Out_State_Clause return Boolean;
25998 -- Determine whether dependence clause Dep_Clause denotes an abstract
25999 -- state that depends on itself (State => State).
26001 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26002 -- Determine whether item Item denotes an abstract state with visible
26003 -- null refinement.
26005 procedure Match_Items
26006 (Dep_Item : Node_Id;
26007 Ref_Item : Node_Id;
26008 Matched : out Boolean);
26009 -- Try to match dependence item Dep_Item against refinement item
26010 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26011 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26012 -- the following conformance scenarios is in effect:
26013 -- 1) Both items denote null
26014 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26015 -- 3) Both items denote attribute 'Result
26016 -- 4) Both items denote the same object
26017 -- 5) Both items denote the same formal parameter
26018 -- 6) Both items denote the same current instance of a type
26019 -- 7) Both items denote the same discriminant
26020 -- 8) Dep_Item is an abstract state with visible null refinement
26021 -- and Ref_Item denotes null.
26022 -- 9) Dep_Item is an abstract state with visible null refinement
26023 -- and Ref_Item is Empty (special case).
26024 -- 10) Dep_Item is an abstract state with full or partial visible
26025 -- non-null refinement and Ref_Item denotes one of its
26027 -- 11) Dep_Item is an abstract state without a full visible
26028 -- refinement and Ref_Item denotes the same state.
26029 -- When scenario 10 is in effect, the entity of the abstract state
26030 -- denoted by Dep_Item is added to list Refined_States.
26032 procedure Record_Item (Item_Id : Entity_Id);
26033 -- Store the entity of an item denoted by Item_Id in Matched_Items
26035 ------------------------
26036 -- Is_Already_Matched --
26037 ------------------------
26039 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26040 Item_Id : Entity_Id := Empty;
26043 -- When the dependency item denotes attribute 'Result, check for
26044 -- the entity of the related subprogram.
26046 if Is_Attribute_Result (Dep_Item) then
26047 Item_Id := Spec_Id;
26049 elsif Is_Entity_Name (Dep_Item) then
26050 Item_Id := Available_View (Entity_Of (Dep_Item));
26054 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26055 end Is_Already_Matched;
26057 ----------------------------
26058 -- Is_In_Out_State_Clause --
26059 ----------------------------
26061 function Is_In_Out_State_Clause return Boolean is
26062 Dep_Input_Id : Entity_Id;
26063 Dep_Output_Id : Entity_Id;
26066 -- Detect the following clause:
26069 if Is_Entity_Name (Dep_Input)
26070 and then Is_Entity_Name (Dep_Output)
26072 -- Handle abstract views generated for limited with clauses
26074 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26075 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26078 Ekind (Dep_Input_Id) = E_Abstract_State
26079 and then Dep_Input_Id = Dep_Output_Id;
26083 end Is_In_Out_State_Clause;
26085 ---------------------------
26086 -- Is_Null_Refined_State --
26087 ---------------------------
26089 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26090 Item_Id : Entity_Id;
26093 if Is_Entity_Name (Item) then
26095 -- Handle abstract views generated for limited with clauses
26097 Item_Id := Available_View (Entity_Of (Item));
26100 Ekind (Item_Id) = E_Abstract_State
26101 and then Has_Null_Visible_Refinement (Item_Id);
26105 end Is_Null_Refined_State;
26111 procedure Match_Items
26112 (Dep_Item : Node_Id;
26113 Ref_Item : Node_Id;
26114 Matched : out Boolean)
26116 Dep_Item_Id : Entity_Id;
26117 Ref_Item_Id : Entity_Id;
26120 -- Assume that the two items do not match
26124 -- A null matches null or Empty (special case)
26126 if Nkind (Dep_Item) = N_Null
26127 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26131 -- Attribute 'Result matches attribute 'Result
26133 elsif Is_Attribute_Result (Dep_Item)
26134 and then Is_Attribute_Result (Ref_Item)
26136 -- Put the entity of the related function on the list of
26137 -- matched items because attribute 'Result does not carry
26138 -- an entity similar to states and constituents.
26140 Record_Item (Spec_Id);
26143 -- Abstract states, current instances of concurrent types,
26144 -- discriminants, formal parameters and objects.
26146 elsif Is_Entity_Name (Dep_Item) then
26148 -- Handle abstract views generated for limited with clauses
26150 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26152 if Ekind (Dep_Item_Id) = E_Abstract_State then
26154 -- An abstract state with visible null refinement matches
26155 -- null or Empty (special case).
26157 if Has_Null_Visible_Refinement (Dep_Item_Id)
26158 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26160 Record_Item (Dep_Item_Id);
26163 -- An abstract state with visible non-null refinement
26164 -- matches one of its constituents, or itself for an
26165 -- abstract state with partial visible refinement.
26167 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26168 if Is_Entity_Name (Ref_Item) then
26169 Ref_Item_Id := Entity_Of (Ref_Item);
26171 if Ekind (Ref_Item_Id) in
26172 E_Abstract_State | E_Constant | E_Variable
26173 and then Present (Encapsulating_State (Ref_Item_Id))
26174 and then Find_Encapsulating_State
26175 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26177 Record_Item (Dep_Item_Id);
26180 elsif not Has_Visible_Refinement (Dep_Item_Id)
26181 and then Ref_Item_Id = Dep_Item_Id
26183 Record_Item (Dep_Item_Id);
26188 -- An abstract state without a visible refinement matches
26191 elsif Is_Entity_Name (Ref_Item)
26192 and then Entity_Of (Ref_Item) = Dep_Item_Id
26194 Record_Item (Dep_Item_Id);
26198 -- A current instance of a concurrent type, discriminant,
26199 -- formal parameter or an object matches itself.
26201 elsif Is_Entity_Name (Ref_Item)
26202 and then Entity_Of (Ref_Item) = Dep_Item_Id
26204 Record_Item (Dep_Item_Id);
26214 procedure Record_Item (Item_Id : Entity_Id) is
26216 if No (Matched_Items) then
26217 Matched_Items := New_Elmt_List;
26220 Append_Unique_Elmt (Item_Id, Matched_Items);
26225 Clause_Matched : Boolean := False;
26226 Dummy : Boolean := False;
26227 Inputs_Match : Boolean;
26228 Next_Ref_Clause : Node_Id;
26229 Outputs_Match : Boolean;
26230 Ref_Clause : Node_Id;
26231 Ref_Input : Node_Id;
26232 Ref_Output : Node_Id;
26234 -- Start of processing for Check_Dependency_Clause
26237 -- Do not perform this check in an instance because it was already
26238 -- performed successfully in the generic template.
26240 if In_Instance then
26244 -- Examine all refinement clauses and compare them against the
26245 -- dependence clause.
26247 Ref_Clause := First (Refinements);
26248 while Present (Ref_Clause) loop
26249 Next_Ref_Clause := Next (Ref_Clause);
26251 -- Obtain the attributes of the current refinement clause
26253 Ref_Input := Expression (Ref_Clause);
26254 Ref_Output := First (Choices (Ref_Clause));
26256 -- The current refinement clause matches the dependence clause
26257 -- when both outputs match and both inputs match. See routine
26258 -- Match_Items for all possible conformance scenarios.
26260 -- Depends Dep_Output => Dep_Input
26264 -- Refined_Depends Ref_Output => Ref_Input
26267 (Dep_Item => Dep_Input,
26268 Ref_Item => Ref_Input,
26269 Matched => Inputs_Match);
26272 (Dep_Item => Dep_Output,
26273 Ref_Item => Ref_Output,
26274 Matched => Outputs_Match);
26276 -- An In_Out state clause may be matched against a refinement with
26277 -- a null input or null output as long as the non-null side of the
26278 -- relation contains a valid constituent of the In_Out_State.
26280 if Is_In_Out_State_Clause then
26282 -- Depends => (State => State)
26283 -- Refined_Depends => (null => Constit) -- OK
26286 and then not Outputs_Match
26287 and then Nkind (Ref_Output) = N_Null
26289 Outputs_Match := True;
26292 -- Depends => (State => State)
26293 -- Refined_Depends => (Constit => null) -- OK
26295 if not Inputs_Match
26296 and then Outputs_Match
26297 and then Nkind (Ref_Input) = N_Null
26299 Inputs_Match := True;
26303 -- The current refinement clause is legally constructed following
26304 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26305 -- the pool of candidates. The seach continues because a single
26306 -- dependence clause may have multiple matching refinements.
26308 if Inputs_Match and Outputs_Match then
26309 Clause_Matched := True;
26310 Remove (Ref_Clause);
26313 Ref_Clause := Next_Ref_Clause;
26316 -- Depending on the order or composition of refinement clauses, an
26317 -- In_Out state clause may not be directly refinable.
26319 -- Refined_State => (State => (Constit_1, Constit_2))
26320 -- Depends => ((Output, State) => (Input, State))
26321 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26323 -- Matching normalized clause (State => State) fails because there is
26324 -- no direct refinement capable of satisfying this relation. Another
26325 -- similar case arises when clauses (Constit_1 => Input) and (Output
26326 -- => Constit_2) are matched first, leaving no candidates for clause
26327 -- (State => State). Both scenarios are legal as long as one of the
26328 -- previous clauses mentioned a valid constituent of State.
26330 if not Clause_Matched
26331 and then Is_In_Out_State_Clause
26332 and then Is_Already_Matched (Dep_Input)
26334 Clause_Matched := True;
26337 -- A clause where the input is an abstract state with visible null
26338 -- refinement or a 'Result attribute is implicitly matched when the
26339 -- output has already been matched in a previous clause.
26341 -- Refined_State => (State => null)
26342 -- Depends => (Output => State) -- implicitly OK
26343 -- Refined_Depends => (Output => ...)
26344 -- Depends => (...'Result => State) -- implicitly OK
26345 -- Refined_Depends => (...'Result => ...)
26347 if not Clause_Matched
26348 and then Is_Null_Refined_State (Dep_Input)
26349 and then Is_Already_Matched (Dep_Output)
26351 Clause_Matched := True;
26354 -- A clause where the output is an abstract state with visible null
26355 -- refinement is implicitly matched when the input has already been
26356 -- matched in a previous clause.
26358 -- Refined_State => (State => null)
26359 -- Depends => (State => Input) -- implicitly OK
26360 -- Refined_Depends => (... => Input)
26362 if not Clause_Matched
26363 and then Is_Null_Refined_State (Dep_Output)
26364 and then Is_Already_Matched (Dep_Input)
26366 Clause_Matched := True;
26369 -- At this point either all refinement clauses have been examined or
26370 -- pragma Refined_Depends contains a solitary null. Only an abstract
26371 -- state with null refinement can possibly match these cases.
26373 -- Refined_State => (State => null)
26374 -- Depends => (State => null)
26375 -- Refined_Depends => null -- OK
26377 if not Clause_Matched then
26379 (Dep_Item => Dep_Input,
26381 Matched => Inputs_Match);
26384 (Dep_Item => Dep_Output,
26386 Matched => Outputs_Match);
26388 Clause_Matched := Inputs_Match and Outputs_Match;
26391 -- If the contents of Refined_Depends are legal, then the current
26392 -- dependence clause should be satisfied either by an explicit match
26393 -- or by one of the special cases.
26395 if not Clause_Matched then
26397 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26398 & "matching refinement in body"), Dep_Clause, Spec_Id);
26400 end Check_Dependency_Clause;
26402 -------------------------
26403 -- Check_Output_States --
26404 -------------------------
26406 procedure Check_Output_States
26407 (Spec_Inputs : Elist_Id;
26408 Spec_Outputs : Elist_Id;
26409 Body_Inputs : Elist_Id;
26410 Body_Outputs : Elist_Id)
26412 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26413 -- Determine whether all constituents of state State_Id with full
26414 -- visible refinement are used as outputs in pragma Refined_Depends.
26415 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26417 -----------------------------
26418 -- Check_Constituent_Usage --
26419 -----------------------------
26421 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26422 Constits : constant Elist_Id :=
26423 Partial_Refinement_Constituents (State_Id);
26424 Constit_Elmt : Elmt_Id;
26425 Constit_Id : Entity_Id;
26426 Only_Partial : constant Boolean :=
26427 not Has_Visible_Refinement (State_Id);
26428 Posted : Boolean := False;
26431 if Present (Constits) then
26432 Constit_Elmt := First_Elmt (Constits);
26433 while Present (Constit_Elmt) loop
26434 Constit_Id := Node (Constit_Elmt);
26436 -- Issue an error when a constituent of State_Id is used,
26437 -- and State_Id has only partial visible refinement
26438 -- (SPARK RM 7.2.4(3d)).
26440 if Only_Partial then
26441 if (Present (Body_Inputs)
26442 and then Appears_In (Body_Inputs, Constit_Id))
26444 (Present (Body_Outputs)
26445 and then Appears_In (Body_Outputs, Constit_Id))
26447 Error_Msg_Name_1 := Chars (State_Id);
26449 ("constituent & of state % cannot be used in "
26450 & "dependence refinement", N, Constit_Id);
26451 Error_Msg_Name_1 := Chars (State_Id);
26452 SPARK_Msg_N ("\use state % instead", N);
26455 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26457 elsif Present (Body_Inputs)
26458 and then Appears_In (Body_Inputs, Constit_Id)
26460 Error_Msg_Name_1 := Chars (State_Id);
26462 ("constituent & of state % must act as output in "
26463 & "dependence refinement", N, Constit_Id);
26465 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26467 elsif No (Body_Outputs)
26468 or else not Appears_In (Body_Outputs, Constit_Id)
26473 ("output state & must be replaced by all its "
26474 & "constituents in dependence refinement",
26479 ("\constituent & is missing in output list",
26483 Next_Elmt (Constit_Elmt);
26486 end Check_Constituent_Usage;
26491 Item_Elmt : Elmt_Id;
26492 Item_Id : Entity_Id;
26494 -- Start of processing for Check_Output_States
26497 -- Do not perform this check in an instance because it was already
26498 -- performed successfully in the generic template.
26500 if In_Instance then
26503 -- Inspect the outputs of pragma Depends looking for a state with a
26504 -- visible refinement.
26506 elsif Present (Spec_Outputs) then
26507 Item_Elmt := First_Elmt (Spec_Outputs);
26508 while Present (Item_Elmt) loop
26509 Item := Node (Item_Elmt);
26511 -- Deal with the mixed nature of the input and output lists
26513 if Nkind (Item) = N_Defining_Identifier then
26516 Item_Id := Available_View (Entity_Of (Item));
26519 if Ekind (Item_Id) = E_Abstract_State then
26521 -- The state acts as an input-output, skip it
26523 if Present (Spec_Inputs)
26524 and then Appears_In (Spec_Inputs, Item_Id)
26528 -- Ensure that all of the constituents are utilized as
26529 -- outputs in pragma Refined_Depends.
26531 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26532 Check_Constituent_Usage (Item_Id);
26536 Next_Elmt (Item_Elmt);
26539 end Check_Output_States;
26541 --------------------
26542 -- Collect_States --
26543 --------------------
26545 function Collect_States (Clauses : List_Id) return Elist_Id is
26546 procedure Collect_State
26548 States : in out Elist_Id);
26549 -- Add the entity of Item to list States when it denotes to a state
26551 -------------------
26552 -- Collect_State --
26553 -------------------
26555 procedure Collect_State
26557 States : in out Elist_Id)
26562 if Is_Entity_Name (Item) then
26563 Id := Entity_Of (Item);
26565 if Ekind (Id) = E_Abstract_State then
26566 if No (States) then
26567 States := New_Elmt_List;
26570 Append_Unique_Elmt (Id, States);
26580 States : Elist_Id := No_Elist;
26582 -- Start of processing for Collect_States
26585 Clause := First (Clauses);
26586 while Present (Clause) loop
26587 Input := Expression (Clause);
26588 Output := First (Choices (Clause));
26590 Collect_State (Input, States);
26591 Collect_State (Output, States);
26597 end Collect_States;
26599 -----------------------
26600 -- Normalize_Clauses --
26601 -----------------------
26603 procedure Normalize_Clauses (Clauses : List_Id) is
26604 procedure Normalize_Inputs (Clause : Node_Id);
26605 -- Normalize clause Clause by creating multiple clauses for each
26606 -- input item of Clause. It is assumed that Clause has exactly one
26607 -- output. The transformation is as follows:
26609 -- Output => (Input_1, Input_2) -- original
26611 -- Output => Input_1 -- normalizations
26612 -- Output => Input_2
26614 procedure Normalize_Outputs (Clause : Node_Id);
26615 -- Normalize clause Clause by creating multiple clause for each
26616 -- output item of Clause. The transformation is as follows:
26618 -- (Output_1, Output_2) => Input -- original
26620 -- Output_1 => Input -- normalization
26621 -- Output_2 => Input
26623 ----------------------
26624 -- Normalize_Inputs --
26625 ----------------------
26627 procedure Normalize_Inputs (Clause : Node_Id) is
26628 Inputs : constant Node_Id := Expression (Clause);
26629 Loc : constant Source_Ptr := Sloc (Clause);
26630 Output : constant List_Id := Choices (Clause);
26631 Last_Input : Node_Id;
26633 New_Clause : Node_Id;
26634 Next_Input : Node_Id;
26637 -- Normalization is performed only when the original clause has
26638 -- more than one input. Multiple inputs appear as an aggregate.
26640 if Nkind (Inputs) = N_Aggregate then
26641 Last_Input := Last (Expressions (Inputs));
26643 -- Create a new clause for each input
26645 Input := First (Expressions (Inputs));
26646 while Present (Input) loop
26647 Next_Input := Next (Input);
26649 -- Unhook the current input from the original input list
26650 -- because it will be relocated to a new clause.
26654 -- Special processing for the last input. At this point the
26655 -- original aggregate has been stripped down to one element.
26656 -- Replace the aggregate by the element itself.
26658 if Input = Last_Input then
26659 Rewrite (Inputs, Input);
26661 -- Generate a clause of the form:
26666 Make_Component_Association (Loc,
26667 Choices => New_Copy_List_Tree (Output),
26668 Expression => Input);
26670 -- The new clause contains replicated content that has
26671 -- already been analyzed, mark the clause as analyzed.
26673 Set_Analyzed (New_Clause);
26674 Insert_After (Clause, New_Clause);
26677 Input := Next_Input;
26680 end Normalize_Inputs;
26682 -----------------------
26683 -- Normalize_Outputs --
26684 -----------------------
26686 procedure Normalize_Outputs (Clause : Node_Id) is
26687 Inputs : constant Node_Id := Expression (Clause);
26688 Loc : constant Source_Ptr := Sloc (Clause);
26689 Outputs : constant Node_Id := First (Choices (Clause));
26690 Last_Output : Node_Id;
26691 New_Clause : Node_Id;
26692 Next_Output : Node_Id;
26696 -- Multiple outputs appear as an aggregate. Nothing to do when
26697 -- the clause has exactly one output.
26699 if Nkind (Outputs) = N_Aggregate then
26700 Last_Output := Last (Expressions (Outputs));
26702 -- Create a clause for each output. Note that each time a new
26703 -- clause is created, the original output list slowly shrinks
26704 -- until there is one item left.
26706 Output := First (Expressions (Outputs));
26707 while Present (Output) loop
26708 Next_Output := Next (Output);
26710 -- Unhook the output from the original output list as it
26711 -- will be relocated to a new clause.
26715 -- Special processing for the last output. At this point
26716 -- the original aggregate has been stripped down to one
26717 -- element. Replace the aggregate by the element itself.
26719 if Output = Last_Output then
26720 Rewrite (Outputs, Output);
26723 -- Generate a clause of the form:
26724 -- (Output => Inputs)
26727 Make_Component_Association (Loc,
26728 Choices => New_List (Output),
26729 Expression => New_Copy_Tree (Inputs));
26731 -- The new clause contains replicated content that has
26732 -- already been analyzed. There is not need to reanalyze
26735 Set_Analyzed (New_Clause);
26736 Insert_After (Clause, New_Clause);
26739 Output := Next_Output;
26742 end Normalize_Outputs;
26748 -- Start of processing for Normalize_Clauses
26751 Clause := First (Clauses);
26752 while Present (Clause) loop
26753 Normalize_Outputs (Clause);
26757 Clause := First (Clauses);
26758 while Present (Clause) loop
26759 Normalize_Inputs (Clause);
26762 end Normalize_Clauses;
26764 --------------------------
26765 -- Remove_Extra_Clauses --
26766 --------------------------
26768 procedure Remove_Extra_Clauses
26769 (Clauses : List_Id;
26770 Matched_Items : Elist_Id)
26774 Input_Id : Entity_Id;
26775 Next_Clause : Node_Id;
26777 State_Id : Entity_Id;
26780 Clause := First (Clauses);
26781 while Present (Clause) loop
26782 Next_Clause := Next (Clause);
26784 Input := Expression (Clause);
26785 Output := First (Choices (Clause));
26787 -- Recognize a clause of the form
26791 -- where Input is a constituent of a state which was already
26792 -- successfully matched. This clause must be removed because it
26793 -- simply indicates that some of the constituents of the state
26796 -- Refined_State => (State => (Constit_1, Constit_2))
26797 -- Depends => (Output => State)
26798 -- Refined_Depends => ((Output => Constit_1), -- State matched
26799 -- (null => Constit_2)) -- OK
26801 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26803 -- Handle abstract views generated for limited with clauses
26805 Input_Id := Available_View (Entity_Of (Input));
26807 -- The input must be a constituent of a state
26809 if Ekind (Input_Id) in
26810 E_Abstract_State | E_Constant | E_Variable
26811 and then Present (Encapsulating_State (Input_Id))
26813 State_Id := Encapsulating_State (Input_Id);
26815 -- The state must have a non-null visible refinement and be
26816 -- matched in a previous clause.
26818 if Has_Non_Null_Visible_Refinement (State_Id)
26819 and then Contains (Matched_Items, State_Id)
26825 -- Recognize a clause of the form
26829 -- where Output is an arbitrary item. This clause must be removed
26830 -- because a null input legitimately matches anything.
26832 elsif Nkind (Input) = N_Null then
26836 Clause := Next_Clause;
26838 end Remove_Extra_Clauses;
26840 --------------------------
26841 -- Report_Extra_Clauses --
26842 --------------------------
26844 procedure Report_Extra_Clauses (Clauses : List_Id) is
26848 -- Do not perform this check in an instance because it was already
26849 -- performed successfully in the generic template.
26851 if In_Instance then
26854 elsif Present (Clauses) then
26855 Clause := First (Clauses);
26856 while Present (Clause) loop
26858 ("unmatched or extra clause in dependence refinement",
26864 end Report_Extra_Clauses;
26868 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26869 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26870 Errors : constant Nat := Serious_Errors_Detected;
26877 Body_Inputs : Elist_Id := No_Elist;
26878 Body_Outputs : Elist_Id := No_Elist;
26879 -- The inputs and outputs of the subprogram body synthesized from pragma
26880 -- Refined_Depends.
26882 Dependencies : List_Id := No_List;
26884 -- The corresponding Depends pragma along with its clauses
26886 Matched_Items : Elist_Id := No_Elist;
26887 -- A list containing the entities of all successfully matched items
26888 -- found in pragma Depends.
26890 Refinements : List_Id := No_List;
26891 -- The clauses of pragma Refined_Depends
26893 Spec_Id : Entity_Id;
26894 -- The entity of the subprogram subject to pragma Refined_Depends
26896 Spec_Inputs : Elist_Id := No_Elist;
26897 Spec_Outputs : Elist_Id := No_Elist;
26898 -- The inputs and outputs of the subprogram spec synthesized from pragma
26901 States : Elist_Id := No_Elist;
26902 -- A list containing the entities of all states whose constituents
26903 -- appear in pragma Depends.
26905 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26908 -- Do not analyze the pragma multiple times
26910 if Is_Analyzed_Pragma (N) then
26914 Spec_Id := Unique_Defining_Entity (Body_Decl);
26916 -- Use the anonymous object as the proper spec when Refined_Depends
26917 -- applies to the body of a single task type. The object carries the
26918 -- proper Chars as well as all non-refined versions of pragmas.
26920 if Is_Single_Concurrent_Type (Spec_Id) then
26921 Spec_Id := Anonymous_Object (Spec_Id);
26924 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26926 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26927 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26929 if No (Depends) then
26931 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26932 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26936 Deps := Expression (Get_Argument (Depends, Spec_Id));
26938 -- A null dependency relation renders the refinement useless because it
26939 -- cannot possibly mention abstract states with visible refinement. Note
26940 -- that the inverse is not true as states may be refined to null
26941 -- (SPARK RM 7.2.5(2)).
26943 if Nkind (Deps) = N_Null then
26945 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26946 & "depend on abstract state with visible refinement"), N, Spec_Id);
26950 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26951 -- This ensures that the categorization of all refined dependency items
26952 -- is consistent with their role.
26954 Analyze_Depends_In_Decl_Part (N);
26956 -- Do not match dependencies against refinements if Refined_Depends is
26957 -- illegal to avoid emitting misleading error.
26959 if Serious_Errors_Detected = Errors then
26961 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26962 -- the inputs and outputs of the subprogram spec and body to verify
26963 -- the use of states with visible refinement and their constituents.
26965 if No (Get_Pragma (Spec_Id, Pragma_Global))
26966 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26968 Collect_Subprogram_Inputs_Outputs
26969 (Subp_Id => Spec_Id,
26970 Synthesize => True,
26971 Subp_Inputs => Spec_Inputs,
26972 Subp_Outputs => Spec_Outputs,
26973 Global_Seen => Dummy);
26975 Collect_Subprogram_Inputs_Outputs
26976 (Subp_Id => Body_Id,
26977 Synthesize => True,
26978 Subp_Inputs => Body_Inputs,
26979 Subp_Outputs => Body_Outputs,
26980 Global_Seen => Dummy);
26982 -- For an output state with a visible refinement, ensure that all
26983 -- constituents appear as outputs in the dependency refinement.
26985 Check_Output_States
26986 (Spec_Inputs => Spec_Inputs,
26987 Spec_Outputs => Spec_Outputs,
26988 Body_Inputs => Body_Inputs,
26989 Body_Outputs => Body_Outputs);
26992 -- Multiple dependency clauses appear as component associations of an
26993 -- aggregate. Note that the clauses are copied because the algorithm
26994 -- modifies them and this should not be visible in Depends.
26996 pragma Assert (Nkind (Deps) = N_Aggregate);
26997 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
26998 Normalize_Clauses (Dependencies);
27000 -- Gather all states which appear in Depends
27002 States := Collect_States (Dependencies);
27004 Refs := Expression (Get_Argument (N, Spec_Id));
27006 if Nkind (Refs) = N_Null then
27007 Refinements := No_List;
27009 -- Multiple dependency clauses appear as component associations of an
27010 -- aggregate. Note that the clauses are copied because the algorithm
27011 -- modifies them and this should not be visible in Refined_Depends.
27013 else pragma Assert (Nkind (Refs) = N_Aggregate);
27014 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27015 Normalize_Clauses (Refinements);
27018 -- At this point the clauses of pragmas Depends and Refined_Depends
27019 -- have been normalized into simple dependencies between one output
27020 -- and one input. Examine all clauses of pragma Depends looking for
27021 -- matching clauses in pragma Refined_Depends.
27023 Clause := First (Dependencies);
27024 while Present (Clause) loop
27025 Check_Dependency_Clause
27026 (Spec_Id => Spec_Id,
27027 Dep_Clause => Clause,
27028 Dep_States => States,
27029 Refinements => Refinements,
27030 Matched_Items => Matched_Items);
27035 -- Pragma Refined_Depends may contain multiple clarification clauses
27036 -- which indicate that certain constituents do not influence the data
27037 -- flow in any way. Such clauses must be removed as long as the state
27038 -- has been matched, otherwise they will be incorrectly flagged as
27041 -- Refined_State => (State => (Constit_1, Constit_2))
27042 -- Depends => (Output => State)
27043 -- Refined_Depends => ((Output => Constit_1), -- State matched
27044 -- (null => Constit_2)) -- must be removed
27046 Remove_Extra_Clauses (Refinements, Matched_Items);
27048 if Serious_Errors_Detected = Errors then
27049 Report_Extra_Clauses (Refinements);
27054 Set_Is_Analyzed_Pragma (N);
27055 end Analyze_Refined_Depends_In_Decl_Part;
27057 -----------------------------------------
27058 -- Analyze_Refined_Global_In_Decl_Part --
27059 -----------------------------------------
27061 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27063 -- The corresponding Global pragma
27065 Has_In_State : Boolean := False;
27066 Has_In_Out_State : Boolean := False;
27067 Has_Out_State : Boolean := False;
27068 Has_Proof_In_State : Boolean := False;
27069 -- These flags are set when the corresponding Global pragma has a state
27070 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27073 Has_Null_State : Boolean := False;
27074 -- This flag is set when the corresponding Global pragma has at least
27075 -- one state with a null refinement.
27077 In_Constits : Elist_Id := No_Elist;
27078 In_Out_Constits : Elist_Id := No_Elist;
27079 Out_Constits : Elist_Id := No_Elist;
27080 Proof_In_Constits : Elist_Id := No_Elist;
27081 -- These lists contain the entities of all Input, In_Out, Output and
27082 -- Proof_In constituents that appear in Refined_Global and participate
27083 -- in state refinement.
27085 In_Items : Elist_Id := No_Elist;
27086 In_Out_Items : Elist_Id := No_Elist;
27087 Out_Items : Elist_Id := No_Elist;
27088 Proof_In_Items : Elist_Id := No_Elist;
27089 -- These lists contain the entities of all Input, In_Out, Output and
27090 -- Proof_In items defined in the corresponding Global pragma.
27092 Repeat_Items : Elist_Id := No_Elist;
27093 -- A list of all global items without full visible refinement found
27094 -- in pragma Global. These states should be repeated in the global
27095 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27096 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27098 Spec_Id : Entity_Id;
27099 -- The entity of the subprogram subject to pragma Refined_Global
27101 States : Elist_Id := No_Elist;
27102 -- A list of all states with full or partial visible refinement found in
27105 procedure Check_In_Out_States;
27106 -- Determine whether the corresponding Global pragma mentions In_Out
27107 -- states with visible refinement and if so, ensure that one of the
27108 -- following completions apply to the constituents of the state:
27109 -- 1) there is at least one constituent of mode In_Out
27110 -- 2) there is at least one Input and one Output constituent
27111 -- 3) not all constituents are present and one of them is of mode
27113 -- This routine may remove elements from In_Constits, In_Out_Constits,
27114 -- Out_Constits and Proof_In_Constits.
27116 procedure Check_Input_States;
27117 -- Determine whether the corresponding Global pragma mentions Input
27118 -- states with visible refinement and if so, ensure that at least one of
27119 -- its constituents appears as an Input item in Refined_Global.
27120 -- This routine may remove elements from In_Constits, In_Out_Constits,
27121 -- Out_Constits and Proof_In_Constits.
27123 procedure Check_Output_States;
27124 -- Determine whether the corresponding Global pragma mentions Output
27125 -- states with visible refinement and if so, ensure that all of its
27126 -- constituents appear as Output items in Refined_Global.
27127 -- This routine may remove elements from In_Constits, In_Out_Constits,
27128 -- Out_Constits and Proof_In_Constits.
27130 procedure Check_Proof_In_States;
27131 -- Determine whether the corresponding Global pragma mentions Proof_In
27132 -- states with visible refinement and if so, ensure that at least one of
27133 -- its constituents appears as a Proof_In item in Refined_Global.
27134 -- This routine may remove elements from In_Constits, In_Out_Constits,
27135 -- Out_Constits and Proof_In_Constits.
27137 procedure Check_Refined_Global_List
27139 Global_Mode : Name_Id := Name_Input);
27140 -- Verify the legality of a single global list declaration. Global_Mode
27141 -- denotes the current mode in effect.
27143 procedure Collect_Global_Items
27145 Mode : Name_Id := Name_Input);
27146 -- Gather all Input, In_Out, Output and Proof_In items from node List
27147 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27148 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27149 -- and Has_Proof_In_State are set when there is at least one abstract
27150 -- state with full or partial visible refinement available in the
27151 -- corresponding mode. Flag Has_Null_State is set when at least state
27152 -- has a null refinement. Mode denotes the current global mode in
27155 function Present_Then_Remove
27157 Item : Entity_Id) return Boolean;
27158 -- Search List for a particular entity Item. If Item has been found,
27159 -- remove it from List. This routine is used to strip lists In_Constits,
27160 -- In_Out_Constits and Out_Constits of valid constituents.
27162 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27163 -- Same as function Present_Then_Remove, but do not report the presence
27164 -- of Item in List.
27166 procedure Report_Extra_Constituents;
27167 -- Emit an error for each constituent found in lists In_Constits,
27168 -- In_Out_Constits and Out_Constits.
27170 procedure Report_Missing_Items;
27171 -- Emit an error for each global item not repeated found in list
27174 -------------------------
27175 -- Check_In_Out_States --
27176 -------------------------
27178 procedure Check_In_Out_States is
27179 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27180 -- Determine whether one of the following coverage scenarios is in
27182 -- 1) there is at least one constituent of mode In_Out or Output
27183 -- 2) there is at least one pair of constituents with modes Input
27184 -- and Output, or Proof_In and Output.
27185 -- 3) there is at least one constituent of mode Output and not all
27186 -- constituents are present.
27187 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27189 -----------------------------
27190 -- Check_Constituent_Usage --
27191 -----------------------------
27193 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27194 Constits : constant Elist_Id :=
27195 Partial_Refinement_Constituents (State_Id);
27196 Constit_Elmt : Elmt_Id;
27197 Constit_Id : Entity_Id;
27198 Has_Missing : Boolean := False;
27199 In_Out_Seen : Boolean := False;
27200 Input_Seen : Boolean := False;
27201 Output_Seen : Boolean := False;
27202 Proof_In_Seen : Boolean := False;
27205 -- Process all the constituents of the state and note their modes
27206 -- within the global refinement.
27208 if Present (Constits) then
27209 Constit_Elmt := First_Elmt (Constits);
27210 while Present (Constit_Elmt) loop
27211 Constit_Id := Node (Constit_Elmt);
27213 if Present_Then_Remove (In_Constits, Constit_Id) then
27214 Input_Seen := True;
27216 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27217 In_Out_Seen := True;
27219 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27220 Output_Seen := True;
27222 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27224 Proof_In_Seen := True;
27227 Has_Missing := True;
27230 Next_Elmt (Constit_Elmt);
27234 -- An In_Out constituent is a valid completion
27236 if In_Out_Seen then
27239 -- A pair of one Input/Proof_In and one Output constituent is a
27240 -- valid completion.
27242 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27245 elsif Output_Seen then
27247 -- A single Output constituent is a valid completion only when
27248 -- some of the other constituents are missing.
27250 if Has_Missing then
27253 -- Otherwise all constituents are of mode Output
27257 ("global refinement of state & must include at least one "
27258 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27262 -- The state lacks a completion. When full refinement is visible,
27263 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27264 -- refinement is visible, emit an error if the abstract state
27265 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27266 -- both are utilized, Check_State_And_Constituent_Use. will issue
27269 elsif not Input_Seen
27270 and then not In_Out_Seen
27271 and then not Output_Seen
27272 and then not Proof_In_Seen
27274 if Has_Visible_Refinement (State_Id)
27275 or else Contains (Repeat_Items, State_Id)
27278 ("missing global refinement of state &", N, State_Id);
27281 -- Otherwise the state has a malformed completion where at least
27282 -- one of the constituents has a different mode.
27286 ("global refinement of state & redefines the mode of its "
27287 & "constituents", N, State_Id);
27289 end Check_Constituent_Usage;
27293 Item_Elmt : Elmt_Id;
27294 Item_Id : Entity_Id;
27296 -- Start of processing for Check_In_Out_States
27299 -- Do not perform this check in an instance because it was already
27300 -- performed successfully in the generic template.
27302 if In_Instance then
27305 -- Inspect the In_Out items of the corresponding Global pragma
27306 -- looking for a state with a visible refinement.
27308 elsif Has_In_Out_State and then Present (In_Out_Items) then
27309 Item_Elmt := First_Elmt (In_Out_Items);
27310 while Present (Item_Elmt) loop
27311 Item_Id := Node (Item_Elmt);
27313 -- Ensure that one of the three coverage variants is satisfied
27315 if Ekind (Item_Id) = E_Abstract_State
27316 and then Has_Non_Null_Visible_Refinement (Item_Id)
27318 Check_Constituent_Usage (Item_Id);
27321 Next_Elmt (Item_Elmt);
27324 end Check_In_Out_States;
27326 ------------------------
27327 -- Check_Input_States --
27328 ------------------------
27330 procedure Check_Input_States is
27331 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27332 -- Determine whether at least one constituent of state State_Id with
27333 -- full or partial visible refinement is used and has mode Input.
27334 -- Ensure that the remaining constituents do not have In_Out or
27335 -- Output modes. Emit an error if this is not the case
27336 -- (SPARK RM 7.2.4(5)).
27338 -----------------------------
27339 -- Check_Constituent_Usage --
27340 -----------------------------
27342 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27343 Constits : constant Elist_Id :=
27344 Partial_Refinement_Constituents (State_Id);
27345 Constit_Elmt : Elmt_Id;
27346 Constit_Id : Entity_Id;
27347 In_Seen : Boolean := False;
27350 if Present (Constits) then
27351 Constit_Elmt := First_Elmt (Constits);
27352 while Present (Constit_Elmt) loop
27353 Constit_Id := Node (Constit_Elmt);
27355 -- At least one of the constituents appears as an Input
27357 if Present_Then_Remove (In_Constits, Constit_Id) then
27360 -- A Proof_In constituent can refine an Input state as long
27361 -- as there is at least one Input constituent present.
27363 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27367 -- The constituent appears in the global refinement, but has
27368 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27370 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27371 or else Present_Then_Remove (Out_Constits, Constit_Id)
27373 Error_Msg_Name_1 := Chars (State_Id);
27375 ("constituent & of state % must have mode `Input` in "
27376 & "global refinement", N, Constit_Id);
27379 Next_Elmt (Constit_Elmt);
27383 -- Not one of the constituents appeared as Input. Always emit an
27384 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27385 -- When only partial refinement is visible, emit an error if the
27386 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27387 -- the case where both are utilized, an error will be issued in
27388 -- Check_State_And_Constituent_Use.
27391 and then (Has_Visible_Refinement (State_Id)
27392 or else Contains (Repeat_Items, State_Id))
27395 ("global refinement of state & must include at least one "
27396 & "constituent of mode `Input`", N, State_Id);
27398 end Check_Constituent_Usage;
27402 Item_Elmt : Elmt_Id;
27403 Item_Id : Entity_Id;
27405 -- Start of processing for Check_Input_States
27408 -- Do not perform this check in an instance because it was already
27409 -- performed successfully in the generic template.
27411 if In_Instance then
27414 -- Inspect the Input items of the corresponding Global pragma looking
27415 -- for a state with a visible refinement.
27417 elsif Has_In_State and then Present (In_Items) then
27418 Item_Elmt := First_Elmt (In_Items);
27419 while Present (Item_Elmt) loop
27420 Item_Id := Node (Item_Elmt);
27422 -- When full refinement is visible, ensure that at least one of
27423 -- the constituents is utilized and is of mode Input. When only
27424 -- partial refinement is visible, ensure that either one of
27425 -- the constituents is utilized and is of mode Input, or the
27426 -- abstract state is repeated and no constituent is utilized.
27428 if Ekind (Item_Id) = E_Abstract_State
27429 and then Has_Non_Null_Visible_Refinement (Item_Id)
27431 Check_Constituent_Usage (Item_Id);
27434 Next_Elmt (Item_Elmt);
27437 end Check_Input_States;
27439 -------------------------
27440 -- Check_Output_States --
27441 -------------------------
27443 procedure Check_Output_States is
27444 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27445 -- Determine whether all constituents of state State_Id with full
27446 -- visible refinement are used and have mode Output. Emit an error
27447 -- if this is not the case (SPARK RM 7.2.4(5)).
27449 -----------------------------
27450 -- Check_Constituent_Usage --
27451 -----------------------------
27453 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27454 Constits : constant Elist_Id :=
27455 Partial_Refinement_Constituents (State_Id);
27456 Only_Partial : constant Boolean :=
27457 not Has_Visible_Refinement (State_Id);
27458 Constit_Elmt : Elmt_Id;
27459 Constit_Id : Entity_Id;
27460 Posted : Boolean := False;
27463 if Present (Constits) then
27464 Constit_Elmt := First_Elmt (Constits);
27465 while Present (Constit_Elmt) loop
27466 Constit_Id := Node (Constit_Elmt);
27468 -- Issue an error when a constituent of State_Id is utilized
27469 -- and State_Id has only partial visible refinement
27470 -- (SPARK RM 7.2.4(3d)).
27472 if Only_Partial then
27473 if Present_Then_Remove (Out_Constits, Constit_Id)
27474 or else Present_Then_Remove (In_Constits, Constit_Id)
27476 Present_Then_Remove (In_Out_Constits, Constit_Id)
27478 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27480 Error_Msg_Name_1 := Chars (State_Id);
27482 ("constituent & of state % cannot be used in global "
27483 & "refinement", N, Constit_Id);
27484 Error_Msg_Name_1 := Chars (State_Id);
27485 SPARK_Msg_N ("\use state % instead", N);
27488 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27491 -- The constituent appears in the global refinement, but has
27492 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27494 elsif Present_Then_Remove (In_Constits, Constit_Id)
27495 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27496 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27498 Error_Msg_Name_1 := Chars (State_Id);
27500 ("constituent & of state % must have mode `Output` in "
27501 & "global refinement", N, Constit_Id);
27503 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27509 ("`Output` state & must be replaced by all its "
27510 & "constituents in global refinement", N, State_Id);
27514 ("\constituent & is missing in output list",
27518 Next_Elmt (Constit_Elmt);
27521 end Check_Constituent_Usage;
27525 Item_Elmt : Elmt_Id;
27526 Item_Id : Entity_Id;
27528 -- Start of processing for Check_Output_States
27531 -- Do not perform this check in an instance because it was already
27532 -- performed successfully in the generic template.
27534 if In_Instance then
27537 -- Inspect the Output items of the corresponding Global pragma
27538 -- looking for a state with a visible refinement.
27540 elsif Has_Out_State and then Present (Out_Items) then
27541 Item_Elmt := First_Elmt (Out_Items);
27542 while Present (Item_Elmt) loop
27543 Item_Id := Node (Item_Elmt);
27545 -- When full refinement is visible, ensure that all of the
27546 -- constituents are utilized and they have mode Output. When
27547 -- only partial refinement is visible, ensure that no
27548 -- constituent is utilized.
27550 if Ekind (Item_Id) = E_Abstract_State
27551 and then Has_Non_Null_Visible_Refinement (Item_Id)
27553 Check_Constituent_Usage (Item_Id);
27556 Next_Elmt (Item_Elmt);
27559 end Check_Output_States;
27561 ---------------------------
27562 -- Check_Proof_In_States --
27563 ---------------------------
27565 procedure Check_Proof_In_States is
27566 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27567 -- Determine whether at least one constituent of state State_Id with
27568 -- full or partial visible refinement is used and has mode Proof_In.
27569 -- Ensure that the remaining constituents do not have Input, In_Out,
27570 -- or Output modes. Emit an error if this is not the case
27571 -- (SPARK RM 7.2.4(5)).
27573 -----------------------------
27574 -- Check_Constituent_Usage --
27575 -----------------------------
27577 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27578 Constits : constant Elist_Id :=
27579 Partial_Refinement_Constituents (State_Id);
27580 Constit_Elmt : Elmt_Id;
27581 Constit_Id : Entity_Id;
27582 Proof_In_Seen : Boolean := False;
27585 if Present (Constits) then
27586 Constit_Elmt := First_Elmt (Constits);
27587 while Present (Constit_Elmt) loop
27588 Constit_Id := Node (Constit_Elmt);
27590 -- At least one of the constituents appears as Proof_In
27592 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27593 Proof_In_Seen := True;
27595 -- The constituent appears in the global refinement, but has
27596 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27598 elsif Present_Then_Remove (In_Constits, Constit_Id)
27599 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27600 or else Present_Then_Remove (Out_Constits, Constit_Id)
27602 Error_Msg_Name_1 := Chars (State_Id);
27604 ("constituent & of state % must have mode `Proof_In` "
27605 & "in global refinement", N, Constit_Id);
27608 Next_Elmt (Constit_Elmt);
27612 -- Not one of the constituents appeared as Proof_In. Always emit
27613 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27614 -- When only partial refinement is visible, emit an error if the
27615 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27616 -- the case where both are utilized, an error will be issued by
27617 -- Check_State_And_Constituent_Use.
27619 if not Proof_In_Seen
27620 and then (Has_Visible_Refinement (State_Id)
27621 or else Contains (Repeat_Items, State_Id))
27624 ("global refinement of state & must include at least one "
27625 & "constituent of mode `Proof_In`", N, State_Id);
27627 end Check_Constituent_Usage;
27631 Item_Elmt : Elmt_Id;
27632 Item_Id : Entity_Id;
27634 -- Start of processing for Check_Proof_In_States
27637 -- Do not perform this check in an instance because it was already
27638 -- performed successfully in the generic template.
27640 if In_Instance then
27643 -- Inspect the Proof_In items of the corresponding Global pragma
27644 -- looking for a state with a visible refinement.
27646 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27647 Item_Elmt := First_Elmt (Proof_In_Items);
27648 while Present (Item_Elmt) loop
27649 Item_Id := Node (Item_Elmt);
27651 -- Ensure that at least one of the constituents is utilized
27652 -- and is of mode Proof_In. When only partial refinement is
27653 -- visible, ensure that either one of the constituents is
27654 -- utilized and is of mode Proof_In, or the abstract state
27655 -- is repeated and no constituent is utilized.
27657 if Ekind (Item_Id) = E_Abstract_State
27658 and then Has_Non_Null_Visible_Refinement (Item_Id)
27660 Check_Constituent_Usage (Item_Id);
27663 Next_Elmt (Item_Elmt);
27666 end Check_Proof_In_States;
27668 -------------------------------
27669 -- Check_Refined_Global_List --
27670 -------------------------------
27672 procedure Check_Refined_Global_List
27674 Global_Mode : Name_Id := Name_Input)
27676 procedure Check_Refined_Global_Item
27678 Global_Mode : Name_Id);
27679 -- Verify the legality of a single global item declaration. Parameter
27680 -- Global_Mode denotes the current mode in effect.
27682 -------------------------------
27683 -- Check_Refined_Global_Item --
27684 -------------------------------
27686 procedure Check_Refined_Global_Item
27688 Global_Mode : Name_Id)
27690 Item_Id : constant Entity_Id := Entity_Of (Item);
27692 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27693 -- Issue a common error message for all mode mismatches. Expect
27694 -- denotes the expected mode.
27696 -----------------------------
27697 -- Inconsistent_Mode_Error --
27698 -----------------------------
27700 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27703 ("global item & has inconsistent modes", Item, Item_Id);
27705 Error_Msg_Name_1 := Global_Mode;
27706 Error_Msg_Name_2 := Expect;
27707 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27708 end Inconsistent_Mode_Error;
27712 Enc_State : Entity_Id := Empty;
27713 -- Encapsulating state for constituent, Empty otherwise
27715 -- Start of processing for Check_Refined_Global_Item
27718 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
27720 Enc_State := Find_Encapsulating_State (States, Item_Id);
27723 -- When the state or object acts as a constituent of another
27724 -- state with a visible refinement, collect it for the state
27725 -- completeness checks performed later on. Note that the item
27726 -- acts as a constituent only when the encapsulating state is
27727 -- present in pragma Global.
27729 if Present (Enc_State)
27730 and then (Has_Visible_Refinement (Enc_State)
27731 or else Has_Partial_Visible_Refinement (Enc_State))
27732 and then Contains (States, Enc_State)
27734 -- If the state has only partial visible refinement, remove it
27735 -- from the list of items that should be repeated from pragma
27738 if not Has_Visible_Refinement (Enc_State) then
27739 Present_Then_Remove (Repeat_Items, Enc_State);
27742 if Global_Mode = Name_Input then
27743 Append_New_Elmt (Item_Id, In_Constits);
27745 elsif Global_Mode = Name_In_Out then
27746 Append_New_Elmt (Item_Id, In_Out_Constits);
27748 elsif Global_Mode = Name_Output then
27749 Append_New_Elmt (Item_Id, Out_Constits);
27751 elsif Global_Mode = Name_Proof_In then
27752 Append_New_Elmt (Item_Id, Proof_In_Constits);
27755 -- When not a constituent, ensure that both occurrences of the
27756 -- item in pragmas Global and Refined_Global match. Also remove
27757 -- it when present from the list of items that should be repeated
27758 -- from pragma Global.
27761 Present_Then_Remove (Repeat_Items, Item_Id);
27763 if Contains (In_Items, Item_Id) then
27764 if Global_Mode /= Name_Input then
27765 Inconsistent_Mode_Error (Name_Input);
27768 elsif Contains (In_Out_Items, Item_Id) then
27769 if Global_Mode /= Name_In_Out then
27770 Inconsistent_Mode_Error (Name_In_Out);
27773 elsif Contains (Out_Items, Item_Id) then
27774 if Global_Mode /= Name_Output then
27775 Inconsistent_Mode_Error (Name_Output);
27778 elsif Contains (Proof_In_Items, Item_Id) then
27781 -- The item does not appear in the corresponding Global pragma,
27782 -- it must be an extra (SPARK RM 7.2.4(3)).
27785 pragma Assert (Present (Global));
27786 Error_Msg_Sloc := Sloc (Global);
27788 ("extra global item & does not refine or repeat any "
27789 & "global item #", Item, Item_Id);
27792 end Check_Refined_Global_Item;
27798 -- Start of processing for Check_Refined_Global_List
27801 -- Do not perform this check in an instance because it was already
27802 -- performed successfully in the generic template.
27804 if In_Instance then
27807 elsif Nkind (List) = N_Null then
27810 -- Single global item declaration
27812 elsif Nkind (List) in N_Expanded_Name
27814 | N_Selected_Component
27816 Check_Refined_Global_Item (List, Global_Mode);
27818 -- Simple global list or moded global list declaration
27820 elsif Nkind (List) = N_Aggregate then
27822 -- The declaration of a simple global list appear as a collection
27825 if Present (Expressions (List)) then
27826 Item := First (Expressions (List));
27827 while Present (Item) loop
27828 Check_Refined_Global_Item (Item, Global_Mode);
27832 -- The declaration of a moded global list appears as a collection
27833 -- of component associations where individual choices denote
27836 elsif Present (Component_Associations (List)) then
27837 Item := First (Component_Associations (List));
27838 while Present (Item) loop
27839 Check_Refined_Global_List
27840 (List => Expression (Item),
27841 Global_Mode => Chars (First (Choices (Item))));
27849 raise Program_Error;
27855 raise Program_Error;
27857 end Check_Refined_Global_List;
27859 --------------------------
27860 -- Collect_Global_Items --
27861 --------------------------
27863 procedure Collect_Global_Items
27865 Mode : Name_Id := Name_Input)
27867 procedure Collect_Global_Item
27869 Item_Mode : Name_Id);
27870 -- Add a single item to the appropriate list. Item_Mode denotes the
27871 -- current mode in effect.
27873 -------------------------
27874 -- Collect_Global_Item --
27875 -------------------------
27877 procedure Collect_Global_Item
27879 Item_Mode : Name_Id)
27881 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27882 -- The above handles abstract views of variables and states built
27883 -- for limited with clauses.
27886 -- Signal that the global list contains at least one abstract
27887 -- state with a visible refinement. Note that the refinement may
27888 -- be null in which case there are no constituents.
27890 if Ekind (Item_Id) = E_Abstract_State then
27891 if Has_Null_Visible_Refinement (Item_Id) then
27892 Has_Null_State := True;
27894 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27895 Append_New_Elmt (Item_Id, States);
27897 if Item_Mode = Name_Input then
27898 Has_In_State := True;
27899 elsif Item_Mode = Name_In_Out then
27900 Has_In_Out_State := True;
27901 elsif Item_Mode = Name_Output then
27902 Has_Out_State := True;
27903 elsif Item_Mode = Name_Proof_In then
27904 Has_Proof_In_State := True;
27909 -- Record global items without full visible refinement found in
27910 -- pragma Global which should be repeated in the global refinement
27911 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27913 if Ekind (Item_Id) /= E_Abstract_State
27914 or else not Has_Visible_Refinement (Item_Id)
27916 Append_New_Elmt (Item_Id, Repeat_Items);
27919 -- Add the item to the proper list
27921 if Item_Mode = Name_Input then
27922 Append_New_Elmt (Item_Id, In_Items);
27923 elsif Item_Mode = Name_In_Out then
27924 Append_New_Elmt (Item_Id, In_Out_Items);
27925 elsif Item_Mode = Name_Output then
27926 Append_New_Elmt (Item_Id, Out_Items);
27927 elsif Item_Mode = Name_Proof_In then
27928 Append_New_Elmt (Item_Id, Proof_In_Items);
27930 end Collect_Global_Item;
27936 -- Start of processing for Collect_Global_Items
27939 if Nkind (List) = N_Null then
27942 -- Single global item declaration
27944 elsif Nkind (List) in N_Expanded_Name
27946 | N_Selected_Component
27948 Collect_Global_Item (List, Mode);
27950 -- Single global list or moded global list declaration
27952 elsif Nkind (List) = N_Aggregate then
27954 -- The declaration of a simple global list appear as a collection
27957 if Present (Expressions (List)) then
27958 Item := First (Expressions (List));
27959 while Present (Item) loop
27960 Collect_Global_Item (Item, Mode);
27964 -- The declaration of a moded global list appears as a collection
27965 -- of component associations where individual choices denote mode.
27967 elsif Present (Component_Associations (List)) then
27968 Item := First (Component_Associations (List));
27969 while Present (Item) loop
27970 Collect_Global_Items
27971 (List => Expression (Item),
27972 Mode => Chars (First (Choices (Item))));
27980 raise Program_Error;
27983 -- To accommodate partial decoration of disabled SPARK features, this
27984 -- routine may be called with illegal input. If this is the case, do
27985 -- not raise Program_Error.
27990 end Collect_Global_Items;
27992 -------------------------
27993 -- Present_Then_Remove --
27994 -------------------------
27996 function Present_Then_Remove
27998 Item : Entity_Id) return Boolean
28003 if Present (List) then
28004 Elmt := First_Elmt (List);
28005 while Present (Elmt) loop
28006 if Node (Elmt) = Item then
28007 Remove_Elmt (List, Elmt);
28016 end Present_Then_Remove;
28018 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28021 Ignore := Present_Then_Remove (List, Item);
28022 end Present_Then_Remove;
28024 -------------------------------
28025 -- Report_Extra_Constituents --
28026 -------------------------------
28028 procedure Report_Extra_Constituents is
28029 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28030 -- Emit an error for every element of List
28032 ---------------------------------------
28033 -- Report_Extra_Constituents_In_List --
28034 ---------------------------------------
28036 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28037 Constit_Elmt : Elmt_Id;
28040 if Present (List) then
28041 Constit_Elmt := First_Elmt (List);
28042 while Present (Constit_Elmt) loop
28043 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28044 Next_Elmt (Constit_Elmt);
28047 end Report_Extra_Constituents_In_List;
28049 -- Start of processing for Report_Extra_Constituents
28052 -- Do not perform this check in an instance because it was already
28053 -- performed successfully in the generic template.
28055 if In_Instance then
28059 Report_Extra_Constituents_In_List (In_Constits);
28060 Report_Extra_Constituents_In_List (In_Out_Constits);
28061 Report_Extra_Constituents_In_List (Out_Constits);
28062 Report_Extra_Constituents_In_List (Proof_In_Constits);
28064 end Report_Extra_Constituents;
28066 --------------------------
28067 -- Report_Missing_Items --
28068 --------------------------
28070 procedure Report_Missing_Items is
28071 Item_Elmt : Elmt_Id;
28072 Item_Id : Entity_Id;
28075 -- Do not perform this check in an instance because it was already
28076 -- performed successfully in the generic template.
28078 if In_Instance then
28082 if Present (Repeat_Items) then
28083 Item_Elmt := First_Elmt (Repeat_Items);
28084 while Present (Item_Elmt) loop
28085 Item_Id := Node (Item_Elmt);
28086 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28087 Next_Elmt (Item_Elmt);
28091 end Report_Missing_Items;
28095 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28096 Errors : constant Nat := Serious_Errors_Detected;
28098 No_Constit : Boolean;
28100 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28103 -- Do not analyze the pragma multiple times
28105 if Is_Analyzed_Pragma (N) then
28109 Spec_Id := Unique_Defining_Entity (Body_Decl);
28111 -- Use the anonymous object as the proper spec when Refined_Global
28112 -- applies to the body of a single task type. The object carries the
28113 -- proper Chars as well as all non-refined versions of pragmas.
28115 if Is_Single_Concurrent_Type (Spec_Id) then
28116 Spec_Id := Anonymous_Object (Spec_Id);
28119 Global := Get_Pragma (Spec_Id, Pragma_Global);
28120 Items := Expression (Get_Argument (N, Spec_Id));
28122 -- The subprogram declaration lacks pragma Global. This renders
28123 -- Refined_Global useless as there is nothing to refine.
28125 if No (Global) then
28127 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28128 & "& lacks aspect or pragma Global"), N, Spec_Id);
28132 -- Extract all relevant items from the corresponding Global pragma
28134 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28136 -- Package and subprogram bodies are instantiated individually in
28137 -- a separate compiler pass. Due to this mode of instantiation, the
28138 -- refinement of a state may no longer be visible when a subprogram
28139 -- body contract is instantiated. Since the generic template is legal,
28140 -- do not perform this check in the instance to circumvent this oddity.
28142 if In_Instance then
28145 -- Non-instance case
28148 -- The corresponding Global pragma must mention at least one
28149 -- state with a visible refinement at the point Refined_Global
28150 -- is processed. States with null refinements need Refined_Global
28151 -- pragma (SPARK RM 7.2.4(2)).
28153 if not Has_In_State
28154 and then not Has_In_Out_State
28155 and then not Has_Out_State
28156 and then not Has_Proof_In_State
28157 and then not Has_Null_State
28160 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28161 & "depend on abstract state with visible refinement"),
28165 -- The global refinement of inputs and outputs cannot be null when
28166 -- the corresponding Global pragma contains at least one item except
28167 -- in the case where we have states with null refinements.
28169 elsif Nkind (Items) = N_Null
28171 (Present (In_Items)
28172 or else Present (In_Out_Items)
28173 or else Present (Out_Items)
28174 or else Present (Proof_In_Items))
28175 and then not Has_Null_State
28178 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28179 & "global items"), N, Spec_Id);
28184 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28185 -- This ensures that the categorization of all refined global items is
28186 -- consistent with their role.
28188 Analyze_Global_In_Decl_Part (N);
28190 -- Perform all refinement checks with respect to completeness and mode
28193 if Serious_Errors_Detected = Errors then
28194 Check_Refined_Global_List (Items);
28197 -- Store the information that no constituent is used in the global
28198 -- refinement, prior to calling checking procedures which remove items
28199 -- from the list of constituents.
28203 and then No (In_Out_Constits)
28204 and then No (Out_Constits)
28205 and then No (Proof_In_Constits);
28207 -- For Input states with visible refinement, at least one constituent
28208 -- must be used as an Input in the global refinement.
28210 if Serious_Errors_Detected = Errors then
28211 Check_Input_States;
28214 -- Verify all possible completion variants for In_Out states with
28215 -- visible refinement.
28217 if Serious_Errors_Detected = Errors then
28218 Check_In_Out_States;
28221 -- For Output states with visible refinement, all constituents must be
28222 -- used as Outputs in the global refinement.
28224 if Serious_Errors_Detected = Errors then
28225 Check_Output_States;
28228 -- For Proof_In states with visible refinement, at least one constituent
28229 -- must be used as Proof_In in the global refinement.
28231 if Serious_Errors_Detected = Errors then
28232 Check_Proof_In_States;
28235 -- Emit errors for all constituents that belong to other states with
28236 -- visible refinement that do not appear in Global.
28238 if Serious_Errors_Detected = Errors then
28239 Report_Extra_Constituents;
28242 -- Emit errors for all items in Global that are not repeated in the
28243 -- global refinement and for which there is no full visible refinement
28244 -- and, in the case of states with partial visible refinement, no
28245 -- constituent is mentioned in the global refinement.
28247 if Serious_Errors_Detected = Errors then
28248 Report_Missing_Items;
28251 -- Emit an error if no constituent is used in the global refinement
28252 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28253 -- one may be issued by the checking procedures. Do not perform this
28254 -- check in an instance because it was already performed successfully
28255 -- in the generic template.
28257 if Serious_Errors_Detected = Errors
28258 and then not In_Instance
28259 and then not Has_Null_State
28260 and then No_Constit
28262 SPARK_Msg_N ("missing refinement", N);
28266 Set_Is_Analyzed_Pragma (N);
28267 end Analyze_Refined_Global_In_Decl_Part;
28269 ----------------------------------------
28270 -- Analyze_Refined_State_In_Decl_Part --
28271 ----------------------------------------
28273 procedure Analyze_Refined_State_In_Decl_Part
28275 Freeze_Id : Entity_Id := Empty)
28277 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28278 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28279 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28281 Available_States : Elist_Id := No_Elist;
28282 -- A list of all abstract states defined in the package declaration that
28283 -- are available for refinement. The list is used to report unrefined
28286 Body_States : Elist_Id := No_Elist;
28287 -- A list of all hidden states that appear in the body of the related
28288 -- package. The list is used to report unused hidden states.
28290 Constituents_Seen : Elist_Id := No_Elist;
28291 -- A list that contains all constituents processed so far. The list is
28292 -- used to detect multiple uses of the same constituent.
28294 Freeze_Posted : Boolean := False;
28295 -- A flag that controls the output of a freezing-related error (see use
28298 Refined_States_Seen : Elist_Id := No_Elist;
28299 -- A list that contains all refined states processed so far. The list is
28300 -- used to detect duplicate refinements.
28302 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28303 -- Perform full analysis of a single refinement clause
28305 procedure Report_Unrefined_States (States : Elist_Id);
28306 -- Emit errors for all unrefined abstract states found in list States
28308 -------------------------------
28309 -- Analyze_Refinement_Clause --
28310 -------------------------------
28312 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28313 AR_Constit : Entity_Id := Empty;
28314 AW_Constit : Entity_Id := Empty;
28315 ER_Constit : Entity_Id := Empty;
28316 EW_Constit : Entity_Id := Empty;
28317 -- The entities of external constituents that contain one of the
28318 -- following enabled properties: Async_Readers, Async_Writers,
28319 -- Effective_Reads and Effective_Writes.
28321 External_Constit_Seen : Boolean := False;
28322 -- Flag used to mark when at least one external constituent is part
28323 -- of the state refinement.
28325 Non_Null_Seen : Boolean := False;
28326 Null_Seen : Boolean := False;
28327 -- Flags used to detect multiple uses of null in a single clause or a
28328 -- mixture of null and non-null constituents.
28330 Part_Of_Constits : Elist_Id := No_Elist;
28331 -- A list of all candidate constituents subject to indicator Part_Of
28332 -- where the encapsulating state is the current state.
28335 State_Id : Entity_Id;
28336 -- The current state being refined
28338 procedure Analyze_Constituent (Constit : Node_Id);
28339 -- Perform full analysis of a single constituent
28341 procedure Check_External_Property
28342 (Prop_Nam : Name_Id;
28344 Constit : Entity_Id);
28345 -- Determine whether a property denoted by name Prop_Nam is present
28346 -- in the refined state. Emit an error if this is not the case. Flag
28347 -- Enabled should be set when the property applies to the refined
28348 -- state. Constit denotes the constituent (if any) which introduces
28349 -- the property in the refinement.
28351 procedure Match_State;
28352 -- Determine whether the state being refined appears in list
28353 -- Available_States. Emit an error when attempting to re-refine the
28354 -- state or when the state is not defined in the package declaration,
28355 -- otherwise remove the state from Available_States.
28357 procedure Report_Unused_Constituents (Constits : Elist_Id);
28358 -- Emit errors for all unused Part_Of constituents in list Constits
28360 -------------------------
28361 -- Analyze_Constituent --
28362 -------------------------
28364 procedure Analyze_Constituent (Constit : Node_Id) is
28365 procedure Match_Constituent (Constit_Id : Entity_Id);
28366 -- Determine whether constituent Constit denoted by its entity
28367 -- Constit_Id appears in Body_States. Emit an error when the
28368 -- constituent is not a valid hidden state of the related package
28369 -- or when it is used more than once. Otherwise remove the
28370 -- constituent from Body_States.
28372 -----------------------
28373 -- Match_Constituent --
28374 -----------------------
28376 procedure Match_Constituent (Constit_Id : Entity_Id) is
28377 procedure Collect_Constituent;
28378 -- Verify the legality of constituent Constit_Id and add it to
28379 -- the refinements of State_Id.
28381 -------------------------
28382 -- Collect_Constituent --
28383 -------------------------
28385 procedure Collect_Constituent is
28386 Constits : Elist_Id;
28389 -- The Ghost policy in effect at the point of abstract state
28390 -- declaration and constituent must match (SPARK RM 6.9(15))
28392 Check_Ghost_Refinement
28393 (State, State_Id, Constit, Constit_Id);
28395 -- A synchronized state must be refined by a synchronized
28396 -- object or another synchronized state (SPARK RM 9.6).
28398 if Is_Synchronized_State (State_Id)
28399 and then not Is_Synchronized_Object (Constit_Id)
28400 and then not Is_Synchronized_State (Constit_Id)
28403 ("constituent of synchronized state & must be "
28404 & "synchronized", Constit, State_Id);
28407 -- Add the constituent to the list of processed items to aid
28408 -- with the detection of duplicates.
28410 Append_New_Elmt (Constit_Id, Constituents_Seen);
28412 -- Collect the constituent in the list of refinement items
28413 -- and establish a relation between the refined state and
28416 Constits := Refinement_Constituents (State_Id);
28418 if No (Constits) then
28419 Constits := New_Elmt_List;
28420 Set_Refinement_Constituents (State_Id, Constits);
28423 Append_Elmt (Constit_Id, Constits);
28424 Set_Encapsulating_State (Constit_Id, State_Id);
28426 -- The state has at least one legal constituent, mark the
28427 -- start of the refinement region. The region ends when the
28428 -- body declarations end (see routine Analyze_Declarations).
28430 Set_Has_Visible_Refinement (State_Id);
28432 -- When the constituent is external, save its relevant
28433 -- property for further checks.
28435 if Async_Readers_Enabled (Constit_Id) then
28436 AR_Constit := Constit_Id;
28437 External_Constit_Seen := True;
28440 if Async_Writers_Enabled (Constit_Id) then
28441 AW_Constit := Constit_Id;
28442 External_Constit_Seen := True;
28445 if Effective_Reads_Enabled (Constit_Id) then
28446 ER_Constit := Constit_Id;
28447 External_Constit_Seen := True;
28450 if Effective_Writes_Enabled (Constit_Id) then
28451 EW_Constit := Constit_Id;
28452 External_Constit_Seen := True;
28454 end Collect_Constituent;
28458 State_Elmt : Elmt_Id;
28460 -- Start of processing for Match_Constituent
28463 -- Detect a duplicate use of a constituent
28465 if Contains (Constituents_Seen, Constit_Id) then
28467 ("duplicate use of constituent &", Constit, Constit_Id);
28471 -- The constituent is subject to a Part_Of indicator
28473 if Present (Encapsulating_State (Constit_Id)) then
28474 if Encapsulating_State (Constit_Id) = State_Id then
28475 Remove (Part_Of_Constits, Constit_Id);
28476 Collect_Constituent;
28478 -- The constituent is part of another state and is used
28479 -- incorrectly in the refinement of the current state.
28482 Error_Msg_Name_1 := Chars (State_Id);
28484 ("& cannot act as constituent of state %",
28485 Constit, Constit_Id);
28487 ("\Part_Of indicator specifies encapsulator &",
28488 Constit, Encapsulating_State (Constit_Id));
28493 Pack_Id : Entity_Id;
28494 Placement : State_Space_Kind;
28496 -- Find where the constituent lives with respect to the
28499 Find_Placement_In_State_Space
28500 (Item_Id => Constit_Id,
28501 Placement => Placement,
28502 Pack_Id => Pack_Id);
28504 -- The constituent is part of the visible state of a
28505 -- private child package, but lacks a Part_Of indicator.
28507 if Placement = Visible_State_Space
28508 and then Is_Child_Unit (Pack_Id)
28509 and then not Is_Generic_Unit (Pack_Id)
28510 and then Is_Private_Descendant (Pack_Id)
28512 Error_Msg_Name_1 := Chars (State_Id);
28514 ("& cannot act as constituent of state %",
28515 Constit, Constit_Id);
28517 Sloc (Enclosing_Declaration (Constit_Id));
28519 ("\missing Part_Of indicator # should specify "
28520 & "encapsulator &",
28521 Constit, State_Id);
28523 -- The only other source of legal constituents is the
28524 -- body state space of the related package.
28527 if Present (Body_States) then
28528 State_Elmt := First_Elmt (Body_States);
28529 while Present (State_Elmt) loop
28531 -- Consume a valid constituent to signal that it
28532 -- has been encountered.
28534 if Node (State_Elmt) = Constit_Id then
28535 Remove_Elmt (Body_States, State_Elmt);
28536 Collect_Constituent;
28540 Next_Elmt (State_Elmt);
28544 -- At this point it is known that the constituent is
28545 -- not part of the package hidden state and cannot be
28546 -- used in a refinement (SPARK RM 7.2.2(9)).
28548 Error_Msg_Name_1 := Chars (Spec_Id);
28550 ("cannot use & in refinement, constituent is not a "
28551 & "hidden state of package %", Constit, Constit_Id);
28555 end Match_Constituent;
28559 Constit_Id : Entity_Id;
28560 Constits : Elist_Id;
28562 -- Start of processing for Analyze_Constituent
28565 -- Detect multiple uses of null in a single refinement clause or a
28566 -- mixture of null and non-null constituents.
28568 if Nkind (Constit) = N_Null then
28571 ("multiple null constituents not allowed", Constit);
28573 elsif Non_Null_Seen then
28575 ("cannot mix null and non-null constituents", Constit);
28580 -- Collect the constituent in the list of refinement items
28582 Constits := Refinement_Constituents (State_Id);
28584 if No (Constits) then
28585 Constits := New_Elmt_List;
28586 Set_Refinement_Constituents (State_Id, Constits);
28589 Append_Elmt (Constit, Constits);
28591 -- The state has at least one legal constituent, mark the
28592 -- start of the refinement region. The region ends when the
28593 -- body declarations end (see Analyze_Declarations).
28595 Set_Has_Visible_Refinement (State_Id);
28598 -- Non-null constituents
28601 Non_Null_Seen := True;
28605 ("cannot mix null and non-null constituents", Constit);
28609 Resolve_State (Constit);
28611 -- Ensure that the constituent denotes a valid state or a
28612 -- whole object (SPARK RM 7.2.2(5)).
28614 if Is_Entity_Name (Constit) then
28615 Constit_Id := Entity_Of (Constit);
28617 -- When a constituent is declared after a subprogram body
28618 -- that caused freezing of the related contract where
28619 -- pragma Refined_State resides, the constituent appears
28620 -- undefined and carries Any_Id as its entity.
28622 -- package body Pack
28623 -- with Refined_State => (State => Constit)
28626 -- with Refined_Global => (Input => Constit)
28634 if Constit_Id = Any_Id then
28635 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28637 -- Emit a specialized info message when the contract of
28638 -- the related package body was "frozen" by another body.
28639 -- Note that it is not possible to precisely identify why
28640 -- the constituent is undefined because it is not visible
28641 -- when pragma Refined_State is analyzed. This message is
28642 -- a reasonable approximation.
28644 if Present (Freeze_Id) and then not Freeze_Posted then
28645 Freeze_Posted := True;
28647 Error_Msg_Name_1 := Chars (Body_Id);
28648 Error_Msg_Sloc := Sloc (Freeze_Id);
28650 ("body & declared # freezes the contract of %",
28653 ("\all constituents must be declared before body #",
28656 -- A misplaced constituent is a critical error because
28657 -- pragma Refined_Depends or Refined_Global depends on
28658 -- the proper link between a state and a constituent.
28659 -- Stop the compilation, as this leads to a multitude
28660 -- of misleading cascaded errors.
28662 raise Unrecoverable_Error;
28665 -- The constituent is a valid state or object
28667 elsif Ekind (Constit_Id) in
28668 E_Abstract_State | E_Constant | E_Variable
28670 Match_Constituent (Constit_Id);
28672 -- The variable may eventually become a constituent of a
28673 -- single protected/task type. Record the reference now
28674 -- and verify its legality when analyzing the contract of
28675 -- the variable (SPARK RM 9.3).
28677 if Ekind (Constit_Id) = E_Variable then
28678 Record_Possible_Part_Of_Reference
28679 (Var_Id => Constit_Id,
28683 -- Otherwise the constituent is illegal
28687 ("constituent & must denote object or state",
28688 Constit, Constit_Id);
28691 -- The constituent is illegal
28694 SPARK_Msg_N ("malformed constituent", Constit);
28697 end Analyze_Constituent;
28699 -----------------------------
28700 -- Check_External_Property --
28701 -----------------------------
28703 procedure Check_External_Property
28704 (Prop_Nam : Name_Id;
28706 Constit : Entity_Id)
28709 -- The property is missing in the declaration of the state, but
28710 -- a constituent is introducing it in the state refinement
28711 -- (SPARK RM 7.2.8(2)).
28713 if not Enabled and then Present (Constit) then
28714 Error_Msg_Name_1 := Prop_Nam;
28715 Error_Msg_Name_2 := Chars (State_Id);
28717 ("constituent & introduces external property % in refinement "
28718 & "of state %", State, Constit);
28720 Error_Msg_Sloc := Sloc (State_Id);
28722 ("\property is missing in abstract state declaration #",
28725 end Check_External_Property;
28731 procedure Match_State is
28732 State_Elmt : Elmt_Id;
28735 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28737 if Contains (Refined_States_Seen, State_Id) then
28739 ("duplicate refinement of state &", State, State_Id);
28743 -- Inspect the abstract states defined in the package declaration
28744 -- looking for a match.
28746 State_Elmt := First_Elmt (Available_States);
28747 while Present (State_Elmt) loop
28749 -- A valid abstract state is being refined in the body. Add
28750 -- the state to the list of processed refined states to aid
28751 -- with the detection of duplicate refinements. Remove the
28752 -- state from Available_States to signal that it has already
28755 if Node (State_Elmt) = State_Id then
28756 Append_New_Elmt (State_Id, Refined_States_Seen);
28757 Remove_Elmt (Available_States, State_Elmt);
28761 Next_Elmt (State_Elmt);
28764 -- If we get here, we are refining a state that is not defined in
28765 -- the package declaration.
28767 Error_Msg_Name_1 := Chars (Spec_Id);
28769 ("cannot refine state, & is not defined in package %",
28773 --------------------------------
28774 -- Report_Unused_Constituents --
28775 --------------------------------
28777 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28778 Constit_Elmt : Elmt_Id;
28779 Constit_Id : Entity_Id;
28780 Posted : Boolean := False;
28783 if Present (Constits) then
28784 Constit_Elmt := First_Elmt (Constits);
28785 while Present (Constit_Elmt) loop
28786 Constit_Id := Node (Constit_Elmt);
28788 -- Generate an error message of the form:
28790 -- state ... has unused Part_Of constituents
28791 -- abstract state ... defined at ...
28792 -- constant ... defined at ...
28793 -- variable ... defined at ...
28798 ("state & has unused Part_Of constituents",
28802 Error_Msg_Sloc := Sloc (Constit_Id);
28804 if Ekind (Constit_Id) = E_Abstract_State then
28806 ("\abstract state & defined #", State, Constit_Id);
28808 elsif Ekind (Constit_Id) = E_Constant then
28810 ("\constant & defined #", State, Constit_Id);
28813 pragma Assert (Ekind (Constit_Id) = E_Variable);
28814 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28817 Next_Elmt (Constit_Elmt);
28820 end Report_Unused_Constituents;
28822 -- Local declarations
28824 Body_Ref : Node_Id;
28825 Body_Ref_Elmt : Elmt_Id;
28827 Extra_State : Node_Id;
28829 -- Start of processing for Analyze_Refinement_Clause
28832 -- A refinement clause appears as a component association where the
28833 -- sole choice is the state and the expressions are the constituents.
28834 -- This is a syntax error, always report.
28836 if Nkind (Clause) /= N_Component_Association then
28837 Error_Msg_N ("malformed state refinement clause", Clause);
28841 -- Analyze the state name of a refinement clause
28843 State := First (Choices (Clause));
28846 Resolve_State (State);
28848 -- Ensure that the state name denotes a valid abstract state that is
28849 -- defined in the spec of the related package.
28851 if Is_Entity_Name (State) then
28852 State_Id := Entity_Of (State);
28854 -- When the abstract state is undefined, it appears as Any_Id. Do
28855 -- not continue with the analysis of the clause.
28857 if State_Id = Any_Id then
28860 -- Catch any attempts to re-refine a state or refine a state that
28861 -- is not defined in the package declaration.
28863 elsif Ekind (State_Id) = E_Abstract_State then
28867 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28871 -- References to a state with visible refinement are illegal.
28872 -- When nested packages are involved, detecting such references is
28873 -- tricky because pragma Refined_State is analyzed later than the
28874 -- offending pragma Depends or Global. References that occur in
28875 -- such nested context are stored in a list. Emit errors for all
28876 -- references found in Body_References (SPARK RM 6.1.4(8)).
28878 if Present (Body_References (State_Id)) then
28879 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28880 while Present (Body_Ref_Elmt) loop
28881 Body_Ref := Node (Body_Ref_Elmt);
28883 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28884 Error_Msg_Sloc := Sloc (State);
28885 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28887 Next_Elmt (Body_Ref_Elmt);
28891 -- The state name is illegal. This is a syntax error, always report.
28894 Error_Msg_N ("malformed state name in refinement clause", State);
28898 -- A refinement clause may only refine one state at a time
28900 Extra_State := Next (State);
28902 if Present (Extra_State) then
28904 ("refinement clause cannot cover multiple states", Extra_State);
28907 -- Replicate the Part_Of constituents of the refined state because
28908 -- the algorithm will consume items.
28910 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28912 -- Analyze all constituents of the refinement. Multiple constituents
28913 -- appear as an aggregate.
28915 Constit := Expression (Clause);
28917 if Nkind (Constit) = N_Aggregate then
28918 if Present (Component_Associations (Constit)) then
28920 ("constituents of refinement clause must appear in "
28921 & "positional form", Constit);
28923 else pragma Assert (Present (Expressions (Constit)));
28924 Constit := First (Expressions (Constit));
28925 while Present (Constit) loop
28926 Analyze_Constituent (Constit);
28931 -- Various forms of a single constituent. Note that these may include
28932 -- malformed constituents.
28935 Analyze_Constituent (Constit);
28938 -- Verify that external constituents do not introduce new external
28939 -- property in the state refinement (SPARK RM 7.2.8(2)).
28941 if Is_External_State (State_Id) then
28942 Check_External_Property
28943 (Prop_Nam => Name_Async_Readers,
28944 Enabled => Async_Readers_Enabled (State_Id),
28945 Constit => AR_Constit);
28947 Check_External_Property
28948 (Prop_Nam => Name_Async_Writers,
28949 Enabled => Async_Writers_Enabled (State_Id),
28950 Constit => AW_Constit);
28952 Check_External_Property
28953 (Prop_Nam => Name_Effective_Reads,
28954 Enabled => Effective_Reads_Enabled (State_Id),
28955 Constit => ER_Constit);
28957 Check_External_Property
28958 (Prop_Nam => Name_Effective_Writes,
28959 Enabled => Effective_Writes_Enabled (State_Id),
28960 Constit => EW_Constit);
28962 -- When a refined state is not external, it should not have external
28963 -- constituents (SPARK RM 7.2.8(1)).
28965 elsif External_Constit_Seen then
28967 ("non-external state & cannot contain external constituents in "
28968 & "refinement", State, State_Id);
28971 -- Ensure that all Part_Of candidate constituents have been mentioned
28972 -- in the refinement clause.
28974 Report_Unused_Constituents (Part_Of_Constits);
28976 -- Avoid a cascading error reporting a missing refinement by adding a
28977 -- dummy constituent.
28979 if No (Refinement_Constituents (State_Id)) then
28980 Set_Refinement_Constituents (State_Id, New_Elmt_List (Any_Id));
28983 -- At this point the refinement might be dummy, but must be
28984 -- well-formed, to prevent cascaded errors.
28986 pragma Assert (Has_Null_Refinement (State_Id)
28988 Has_Non_Null_Refinement (State_Id));
28989 end Analyze_Refinement_Clause;
28991 -----------------------------
28992 -- Report_Unrefined_States --
28993 -----------------------------
28995 procedure Report_Unrefined_States (States : Elist_Id) is
28996 State_Elmt : Elmt_Id;
28999 if Present (States) then
29000 State_Elmt := First_Elmt (States);
29001 while Present (State_Elmt) loop
29003 ("abstract state & must be refined", Node (State_Elmt));
29005 Next_Elmt (State_Elmt);
29008 end Report_Unrefined_States;
29010 -- Local declarations
29012 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29015 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29018 -- Do not analyze the pragma multiple times
29020 if Is_Analyzed_Pragma (N) then
29024 -- Save the scenario for examination by the ABE Processing phase
29026 Record_Elaboration_Scenario (N);
29028 -- Replicate the abstract states declared by the package because the
29029 -- matching algorithm will consume states.
29031 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29033 -- Gather all abstract states and objects declared in the visible
29034 -- state space of the package body. These items must be utilized as
29035 -- constituents in a state refinement.
29037 Body_States := Collect_Body_States (Body_Id);
29039 -- Multiple non-null state refinements appear as an aggregate
29041 if Nkind (Clauses) = N_Aggregate then
29042 if Present (Expressions (Clauses)) then
29044 ("state refinements must appear as component associations",
29047 else pragma Assert (Present (Component_Associations (Clauses)));
29048 Clause := First (Component_Associations (Clauses));
29049 while Present (Clause) loop
29050 Analyze_Refinement_Clause (Clause);
29055 -- Various forms of a single state refinement. Note that these may
29056 -- include malformed refinements.
29059 Analyze_Refinement_Clause (Clauses);
29062 -- List all abstract states that were left unrefined
29064 Report_Unrefined_States (Available_States);
29066 Set_Is_Analyzed_Pragma (N);
29067 end Analyze_Refined_State_In_Decl_Part;
29069 ---------------------------------------------
29070 -- Analyze_Subprogram_Variant_In_Decl_Part --
29071 ---------------------------------------------
29073 -- WARNING: This routine manages Ghost regions. Return statements must be
29074 -- replaced by gotos which jump to the end of the routine and restore the
29077 procedure Analyze_Subprogram_Variant_In_Decl_Part
29079 Freeze_Id : Entity_Id := Empty)
29081 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29082 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29084 procedure Analyze_Variant (Variant : Node_Id);
29085 -- Verify the legality of a single contract case
29087 ---------------------
29088 -- Analyze_Variant --
29089 ---------------------
29091 procedure Analyze_Variant (Variant : Node_Id) is
29092 Direction : Node_Id;
29095 Extra_Direction : Node_Id;
29098 if Nkind (Variant) /= N_Component_Association then
29099 Error_Msg_N ("wrong syntax in subprogram variant", Variant);
29103 Direction := First (Choices (Variant));
29104 Expr := Expression (Variant);
29106 -- Each variant must have exactly one direction
29108 Extra_Direction := Next (Direction);
29110 if Present (Extra_Direction) then
29112 ("subprogram variant case must have exactly one direction",
29116 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29118 if Nkind (Direction) = N_Identifier then
29119 if Chars (Direction) /= Name_Decreases
29121 Chars (Direction) /= Name_Increases
29123 Error_Msg_N ("wrong direction", Direction);
29126 Error_Msg_N ("wrong syntax", Direction);
29129 Errors := Serious_Errors_Detected;
29130 Preanalyze_Assert_Expression (Expr, Any_Discrete);
29132 -- Emit a clarification message when the variant expression
29133 -- contains at least one undefined reference, possibly due
29134 -- to contract freezing.
29136 if Errors /= Serious_Errors_Detected
29137 and then Present (Freeze_Id)
29138 and then Has_Undefined_Reference (Expr)
29140 Contract_Freeze_Error (Spec_Id, Freeze_Id);
29142 end Analyze_Variant;
29146 Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29148 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
29149 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
29150 -- Save the Ghost-related attributes to restore on exit
29153 Restore_Scope : Boolean := False;
29155 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29158 -- Do not analyze the pragma multiple times
29160 if Is_Analyzed_Pragma (N) then
29164 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29165 -- analysis of the pragma, the Ghost mode at point of declaration and
29166 -- point of analysis may not necessarily be the same. Use the mode in
29167 -- effect at the point of declaration.
29169 Set_Ghost_Mode (N);
29171 -- Single and multiple contract cases must appear in aggregate form. If
29172 -- this is not the case, then either the parser of the analysis of the
29173 -- pragma failed to produce an aggregate.
29175 pragma Assert (Nkind (Variants) = N_Aggregate);
29177 -- Only "change_direction => discrete_expression" clauses are allowed
29179 if Present (Component_Associations (Variants))
29180 and then No (Expressions (Variants))
29183 -- Ensure that the formal parameters are visible when analyzing all
29184 -- clauses. This falls out of the general rule of aspects pertaining
29185 -- to subprogram declarations.
29187 if not In_Open_Scopes (Spec_Id) then
29188 Restore_Scope := True;
29189 Push_Scope (Spec_Id);
29191 if Is_Generic_Subprogram (Spec_Id) then
29192 Install_Generic_Formals (Spec_Id);
29194 Install_Formals (Spec_Id);
29198 Variant := First (Component_Associations (Variants));
29199 while Present (Variant) loop
29200 Analyze_Variant (Variant);
29204 if Restore_Scope then
29208 -- Otherwise the pragma is illegal
29211 Error_Msg_N ("wrong syntax for subprogram variant", N);
29214 Set_Is_Analyzed_Pragma (N);
29216 Restore_Ghost_Region (Saved_GM, Saved_IGR);
29217 end Analyze_Subprogram_Variant_In_Decl_Part;
29219 ------------------------------------
29220 -- Analyze_Test_Case_In_Decl_Part --
29221 ------------------------------------
29223 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29224 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29225 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29227 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29228 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29229 -- denoted by Arg_Nam.
29231 ------------------------------
29232 -- Preanalyze_Test_Case_Arg --
29233 ------------------------------
29235 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29239 -- Preanalyze the original aspect argument for a generic subprogram
29240 -- to properly capture global references.
29242 if Is_Generic_Subprogram (Spec_Id) then
29246 Arg_Nam => Arg_Nam,
29247 From_Aspect => True);
29249 if Present (Arg) then
29250 Preanalyze_Assert_Expression
29251 (Expression (Arg), Standard_Boolean);
29255 Arg := Test_Case_Arg (N, Arg_Nam);
29257 if Present (Arg) then
29258 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29260 end Preanalyze_Test_Case_Arg;
29264 Restore_Scope : Boolean := False;
29266 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29269 -- Do not analyze the pragma multiple times
29271 if Is_Analyzed_Pragma (N) then
29275 -- Ensure that the formal parameters are visible when analyzing all
29276 -- clauses. This falls out of the general rule of aspects pertaining
29277 -- to subprogram declarations.
29279 if not In_Open_Scopes (Spec_Id) then
29280 Restore_Scope := True;
29281 Push_Scope (Spec_Id);
29283 if Is_Generic_Subprogram (Spec_Id) then
29284 Install_Generic_Formals (Spec_Id);
29286 Install_Formals (Spec_Id);
29290 Preanalyze_Test_Case_Arg (Name_Requires);
29291 Preanalyze_Test_Case_Arg (Name_Ensures);
29293 if Restore_Scope then
29297 -- Currently it is not possible to inline pre/postconditions on a
29298 -- subprogram subject to pragma Inline_Always.
29300 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29302 Set_Is_Analyzed_Pragma (N);
29303 end Analyze_Test_Case_In_Decl_Part;
29309 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29314 if Present (List) then
29315 Elmt := First_Elmt (List);
29316 while Present (Elmt) loop
29317 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29320 Id := Entity_Of (Node (Elmt));
29323 if Id = Item_Id then
29334 -----------------------------------
29335 -- Build_Pragma_Check_Equivalent --
29336 -----------------------------------
29338 function Build_Pragma_Check_Equivalent
29340 Subp_Id : Entity_Id := Empty;
29341 Inher_Id : Entity_Id := Empty;
29342 Keep_Pragma_Id : Boolean := False) return Node_Id
29344 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29345 -- Detect whether node N references a formal parameter subject to
29346 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29347 -- to False to suppress the generation of a reference when analyzing
29350 ------------------------
29351 -- Suppress_Reference --
29352 ------------------------
29354 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29355 Formal : Entity_Id;
29358 if Is_Entity_Name (N) and then Present (Entity (N)) then
29359 Formal := Entity (N);
29361 -- The formal parameter is subject to pragma Unreferenced. Prevent
29362 -- the generation of references by resetting the Comes_From_Source
29365 if Is_Formal (Formal)
29366 and then Has_Pragma_Unreferenced (Formal)
29368 Set_Comes_From_Source (N, False);
29373 end Suppress_Reference;
29375 procedure Suppress_References is
29376 new Traverse_Proc (Suppress_Reference);
29380 Loc : constant Source_Ptr := Sloc (Prag);
29381 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29382 Check_Prag : Node_Id;
29386 Needs_Wrapper : Boolean;
29387 pragma Unreferenced (Needs_Wrapper);
29389 -- Start of processing for Build_Pragma_Check_Equivalent
29392 -- When the pre- or postcondition is inherited, map the formals of the
29393 -- inherited subprogram to those of the current subprogram. In addition,
29394 -- map primitive operations of the parent type into the corresponding
29395 -- primitive operations of the descendant.
29397 if Present (Inher_Id) then
29398 pragma Assert (Present (Subp_Id));
29400 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29402 -- Use generic machinery to copy inherited pragma, as if it were an
29403 -- instantiation, resetting source locations appropriately, so that
29404 -- expressions inside the inherited pragma use chained locations.
29405 -- This is used in particular in GNATprove to locate precisely
29406 -- messages on a given inherited pragma.
29408 Set_Copied_Sloc_For_Inherited_Pragma
29409 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29410 Check_Prag := New_Copy_Tree (Source => Prag);
29412 -- Build the inherited class-wide condition
29414 Build_Class_Wide_Expression
29415 (Prag => Check_Prag,
29417 Par_Subp => Inher_Id,
29418 Adjust_Sloc => True,
29419 Needs_Wrapper => Needs_Wrapper);
29421 -- If not an inherited condition simply copy the original pragma
29424 Check_Prag := New_Copy_Tree (Source => Prag);
29427 -- Mark the pragma as being internally generated and reset the Analyzed
29430 Set_Analyzed (Check_Prag, False);
29431 Set_Comes_From_Source (Check_Prag, False);
29433 -- The tree of the original pragma may contain references to the
29434 -- formal parameters of the related subprogram. At the same time
29435 -- the corresponding body may mark the formals as unreferenced:
29437 -- procedure Proc (Formal : ...)
29438 -- with Pre => Formal ...;
29440 -- procedure Proc (Formal : ...) is
29441 -- pragma Unreferenced (Formal);
29444 -- This creates problems because all pragma Check equivalents are
29445 -- analyzed at the end of the body declarations. Since all source
29446 -- references have already been accounted for, reset any references
29447 -- to such formals in the generated pragma Check equivalent.
29449 Suppress_References (Check_Prag);
29451 if Present (Corresponding_Aspect (Prag)) then
29452 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29457 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29458 -- the copied pragma in the newly created pragma, convert the copy into
29459 -- pragma Check by correcting the name and adding a check_kind argument.
29461 if not Keep_Pragma_Id then
29462 Set_Class_Present (Check_Prag, False);
29464 Set_Pragma_Identifier
29465 (Check_Prag, Make_Identifier (Loc, Name_Check));
29467 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29468 Make_Pragma_Argument_Association (Loc,
29469 Expression => Make_Identifier (Loc, Nam)));
29472 -- Update the error message when the pragma is inherited
29474 if Present (Inher_Id) then
29475 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29477 if Chars (Msg_Arg) = Name_Message then
29478 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29480 -- Insert "inherited" to improve the error message
29482 if Name_Buffer (1 .. 8) = "failed p" then
29483 Insert_Str_In_Name_Buffer ("inherited ", 8);
29484 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29490 end Build_Pragma_Check_Equivalent;
29492 -----------------------------
29493 -- Check_Applicable_Policy --
29494 -----------------------------
29496 procedure Check_Applicable_Policy (N : Node_Id) is
29500 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29503 -- No effect if not valid assertion kind name
29505 if not Is_Valid_Assertion_Kind (Ename) then
29509 -- Loop through entries in check policy list
29511 PP := Opt.Check_Policy_List;
29512 while Present (PP) loop
29514 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29515 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29519 or else Pnm = Name_Assertion
29520 or else (Pnm = Name_Statement_Assertions
29521 and then Ename in Name_Assert
29522 | Name_Assert_And_Cut
29524 | Name_Loop_Invariant
29525 | Name_Loop_Variant)
29527 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29533 -- In CodePeer mode and GNATprove mode, we need to
29534 -- consider all assertions, unless they are disabled.
29535 -- Force Is_Checked on ignored assertions, in particular
29536 -- because transformations of the AST may depend on
29537 -- assertions being checked (e.g. the translation of
29538 -- attribute 'Loop_Entry).
29540 if CodePeer_Mode or GNATprove_Mode then
29541 Set_Is_Checked (N, True);
29542 Set_Is_Ignored (N, False);
29544 Set_Is_Checked (N, False);
29545 Set_Is_Ignored (N, True);
29551 Set_Is_Checked (N, True);
29552 Set_Is_Ignored (N, False);
29554 when Name_Disable =>
29555 Set_Is_Ignored (N, True);
29556 Set_Is_Checked (N, False);
29557 Set_Is_Disabled (N, True);
29559 -- That should be exhaustive, the null here is a defence
29560 -- against a malformed tree from previous errors.
29569 PP := Next_Pragma (PP);
29573 -- If there are no specific entries that matched, then we let the
29574 -- setting of assertions govern. Note that this provides the needed
29575 -- compatibility with the RM for the cases of assertion, invariant,
29576 -- precondition, predicate, and postcondition. Note also that
29577 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29579 if Assertions_Enabled then
29580 Set_Is_Checked (N, True);
29581 Set_Is_Ignored (N, False);
29583 Set_Is_Checked (N, False);
29584 Set_Is_Ignored (N, True);
29586 end Check_Applicable_Policy;
29588 -------------------------------
29589 -- Check_External_Properties --
29590 -------------------------------
29592 procedure Check_External_Properties
29599 type Properties is array (Positive range 1 .. 4) of Boolean;
29600 type Combinations is array (Positive range <>) of Properties;
29601 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
29602 -- Effective_Reads properties and their combinations, respectively.
29604 Specified : constant Properties := (AR, AW, EW, ER);
29605 -- External properties, as given by the Item pragma
29607 Allowed : constant Combinations :=
29608 (1 => (True, False, True, False),
29609 2 => (False, True, False, True),
29610 3 => (True, False, False, False),
29611 4 => (False, True, False, False),
29612 5 => (True, True, True, False),
29613 6 => (True, True, False, True),
29614 7 => (True, True, False, False),
29615 8 => (True, True, True, True));
29616 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
29619 -- Check if the specified properties match any of the allowed
29620 -- combination; if not, then emit an error.
29622 for J in Allowed'Range loop
29623 if Specified = Allowed (J) then
29629 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29631 end Check_External_Properties;
29637 function Check_Kind (Nam : Name_Id) return Name_Id is
29641 -- Loop through entries in check policy list
29643 PP := Opt.Check_Policy_List;
29644 while Present (PP) loop
29646 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29647 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29651 or else (Pnm = Name_Assertion
29652 and then Is_Valid_Assertion_Kind (Nam))
29653 or else (Pnm = Name_Statement_Assertions
29654 and then Nam in Name_Assert
29655 | Name_Assert_And_Cut
29657 | Name_Loop_Invariant
29658 | Name_Loop_Variant)
29660 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29669 return Name_Ignore;
29671 when Name_Disable =>
29672 return Name_Disable;
29675 raise Program_Error;
29679 PP := Next_Pragma (PP);
29684 -- If there are no specific entries that matched, then we let the
29685 -- setting of assertions govern. Note that this provides the needed
29686 -- compatibility with the RM for the cases of assertion, invariant,
29687 -- precondition, predicate, and postcondition.
29689 if Assertions_Enabled then
29692 return Name_Ignore;
29696 ---------------------------
29697 -- Check_Missing_Part_Of --
29698 ---------------------------
29700 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29701 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29702 -- Determine whether a package denoted by Pack_Id declares at least one
29705 -----------------------
29706 -- Has_Visible_State --
29707 -----------------------
29709 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29710 Item_Id : Entity_Id;
29713 -- Traverse the entity chain of the package trying to find at least
29714 -- one visible abstract state, variable or a package [instantiation]
29715 -- that declares a visible state.
29717 Item_Id := First_Entity (Pack_Id);
29718 while Present (Item_Id)
29719 and then not In_Private_Part (Item_Id)
29721 -- Do not consider internally generated items
29723 if not Comes_From_Source (Item_Id) then
29726 -- Do not consider generic formals or their corresponding actuals
29727 -- because they are not part of a visible state. Note that both
29728 -- entities are marked as hidden.
29730 elsif Is_Hidden (Item_Id) then
29733 -- A visible state has been found. Note that constants are not
29734 -- considered here because it is not possible to determine whether
29735 -- they depend on variable input. This check is left to the SPARK
29738 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
29741 -- Recursively peek into nested packages and instantiations
29743 elsif Ekind (Item_Id) = E_Package
29744 and then Has_Visible_State (Item_Id)
29749 Next_Entity (Item_Id);
29753 end Has_Visible_State;
29757 Pack_Id : Entity_Id;
29758 Placement : State_Space_Kind;
29760 -- Start of processing for Check_Missing_Part_Of
29763 -- Do not consider abstract states, variables or package instantiations
29764 -- coming from an instance as those always inherit the Part_Of indicator
29765 -- of the instance itself.
29767 if In_Instance then
29770 -- Do not consider internally generated entities as these can never
29771 -- have a Part_Of indicator.
29773 elsif not Comes_From_Source (Item_Id) then
29776 -- Perform these checks only when SPARK_Mode is enabled as they will
29777 -- interfere with standard Ada rules and produce false positives.
29779 elsif SPARK_Mode /= On then
29782 -- Do not consider constants, because the compiler cannot accurately
29783 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29784 -- act as a hidden state of a package.
29786 elsif Ekind (Item_Id) = E_Constant then
29790 -- Find where the abstract state, variable or package instantiation
29791 -- lives with respect to the state space.
29793 Find_Placement_In_State_Space
29794 (Item_Id => Item_Id,
29795 Placement => Placement,
29796 Pack_Id => Pack_Id);
29798 -- Items that appear in a non-package construct (subprogram, block, etc)
29799 -- do not require a Part_Of indicator because they can never act as a
29802 if Placement = Not_In_Package then
29805 -- An item declared in the body state space of a package always act as a
29806 -- constituent and does not need explicit Part_Of indicator.
29808 elsif Placement = Body_State_Space then
29811 -- In general an item declared in the visible state space of a package
29812 -- does not require a Part_Of indicator. The only exception is when the
29813 -- related package is a nongeneric private child unit, in which case
29814 -- Part_Of must denote a state in the parent unit or in one of its
29817 elsif Placement = Visible_State_Space then
29818 if Is_Child_Unit (Pack_Id)
29819 and then not Is_Generic_Unit (Pack_Id)
29820 and then Is_Private_Descendant (Pack_Id)
29822 -- A package instantiation does not need a Part_Of indicator when
29823 -- the related generic template has no visible state.
29825 if Ekind (Item_Id) = E_Package
29826 and then Is_Generic_Instance (Item_Id)
29827 and then not Has_Visible_State (Item_Id)
29831 -- All other cases require Part_Of
29835 ("indicator Part_Of is required in this context "
29836 & "(SPARK RM 7.2.6(3))", Item_Id);
29837 Error_Msg_Name_1 := Chars (Pack_Id);
29839 ("\& is declared in the visible part of private child "
29840 & "unit %", Item_Id);
29844 -- When the item appears in the private state space of a package, it
29845 -- must be a part of some state declared by the said package.
29847 else pragma Assert (Placement = Private_State_Space);
29849 -- The related package does not declare a state, the item cannot act
29850 -- as a Part_Of constituent.
29852 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29855 -- A package instantiation does not need a Part_Of indicator when the
29856 -- related generic template has no visible state.
29858 elsif Ekind (Item_Id) = E_Package
29859 and then Is_Generic_Instance (Item_Id)
29860 and then not Has_Visible_State (Item_Id)
29864 -- All other cases require Part_Of
29868 ("indicator Part_Of is required in this context "
29869 & "(SPARK RM 7.2.6(2))", Item_Id);
29870 Error_Msg_Name_1 := Chars (Pack_Id);
29872 ("\& is declared in the private part of package %", Item_Id);
29875 end Check_Missing_Part_Of;
29877 ---------------------------------------------------
29878 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29879 ---------------------------------------------------
29881 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29883 Spec_Id : Entity_Id)
29886 if Warn_On_Redundant_Constructs
29887 and then Has_Pragma_Inline_Always (Spec_Id)
29888 and then Assertions_Enabled
29890 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29892 if From_Aspect_Specification (Prag) then
29894 ("aspect % not enforced on inlined subprogram &?r?",
29895 Corresponding_Aspect (Prag), Spec_Id);
29898 ("pragma % not enforced on inlined subprogram &?r?",
29902 end Check_Postcondition_Use_In_Inlined_Subprogram;
29904 -------------------------------------
29905 -- Check_State_And_Constituent_Use --
29906 -------------------------------------
29908 procedure Check_State_And_Constituent_Use
29909 (States : Elist_Id;
29910 Constits : Elist_Id;
29913 Constit_Elmt : Elmt_Id;
29914 Constit_Id : Entity_Id;
29915 State_Id : Entity_Id;
29918 -- Nothing to do if there are no states or constituents
29920 if No (States) or else No (Constits) then
29924 -- Inspect the list of constituents and try to determine whether its
29925 -- encapsulating state is in list States.
29927 Constit_Elmt := First_Elmt (Constits);
29928 while Present (Constit_Elmt) loop
29929 Constit_Id := Node (Constit_Elmt);
29931 -- Determine whether the constituent is part of an encapsulating
29932 -- state that appears in the same context and if this is the case,
29933 -- emit an error (SPARK RM 7.2.6(7)).
29935 State_Id := Find_Encapsulating_State (States, Constit_Id);
29937 if Present (State_Id) then
29938 Error_Msg_Name_1 := Chars (Constit_Id);
29940 ("cannot mention state & and its constituent % in the same "
29941 & "context", Context, State_Id);
29945 Next_Elmt (Constit_Elmt);
29947 end Check_State_And_Constituent_Use;
29949 ---------------------------------------------
29950 -- Collect_Inherited_Class_Wide_Conditions --
29951 ---------------------------------------------
29953 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29954 Parent_Subp : constant Entity_Id :=
29955 Ultimate_Alias (Overridden_Operation (Subp));
29956 -- The Overridden_Operation may itself be inherited and as such have no
29957 -- explicit contract.
29959 Prags : constant Node_Id := Contract (Parent_Subp);
29960 In_Spec_Expr : Boolean := In_Spec_Expression;
29961 Installed : Boolean;
29963 New_Prag : Node_Id;
29966 Installed := False;
29968 -- Iterate over the contract of the overridden subprogram to find all
29969 -- inherited class-wide pre- and postconditions.
29971 if Present (Prags) then
29972 Prag := Pre_Post_Conditions (Prags);
29974 while Present (Prag) loop
29975 if Pragma_Name_Unmapped (Prag)
29976 in Name_Precondition | Name_Postcondition
29977 and then Class_Present (Prag)
29979 -- The generated pragma must be analyzed in the context of
29980 -- the subprogram, to make its formals visible. In addition,
29981 -- we must inhibit freezing and full analysis because the
29982 -- controlling type of the subprogram is not frozen yet, and
29983 -- may have further primitives.
29985 if not Installed then
29988 Install_Formals (Subp);
29989 In_Spec_Expr := In_Spec_Expression;
29990 In_Spec_Expression := True;
29994 Build_Pragma_Check_Equivalent
29995 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29997 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29998 Preanalyze (New_Prag);
30000 -- Prevent further analysis in subsequent processing of the
30001 -- current list of declarations
30003 Set_Analyzed (New_Prag);
30006 Prag := Next_Pragma (Prag);
30010 In_Spec_Expression := In_Spec_Expr;
30014 end Collect_Inherited_Class_Wide_Conditions;
30016 ---------------------------------------
30017 -- Collect_Subprogram_Inputs_Outputs --
30018 ---------------------------------------
30020 procedure Collect_Subprogram_Inputs_Outputs
30021 (Subp_Id : Entity_Id;
30022 Synthesize : Boolean := False;
30023 Subp_Inputs : in out Elist_Id;
30024 Subp_Outputs : in out Elist_Id;
30025 Global_Seen : out Boolean)
30027 procedure Collect_Dependency_Clause (Clause : Node_Id);
30028 -- Collect all relevant items from a dependency clause
30030 procedure Collect_Global_List
30032 Mode : Name_Id := Name_Input);
30033 -- Collect all relevant items from a global list
30035 -------------------------------
30036 -- Collect_Dependency_Clause --
30037 -------------------------------
30039 procedure Collect_Dependency_Clause (Clause : Node_Id) is
30040 procedure Collect_Dependency_Item
30042 Is_Input : Boolean);
30043 -- Add an item to the proper subprogram input or output collection
30045 -----------------------------
30046 -- Collect_Dependency_Item --
30047 -----------------------------
30049 procedure Collect_Dependency_Item
30051 Is_Input : Boolean)
30056 -- Nothing to collect when the item is null
30058 if Nkind (Item) = N_Null then
30061 -- Ditto for attribute 'Result
30063 elsif Is_Attribute_Result (Item) then
30066 -- Multiple items appear as an aggregate
30068 elsif Nkind (Item) = N_Aggregate then
30069 Extra := First (Expressions (Item));
30070 while Present (Extra) loop
30071 Collect_Dependency_Item (Extra, Is_Input);
30075 -- Otherwise this is a solitary item
30079 Append_New_Elmt (Item, Subp_Inputs);
30081 Append_New_Elmt (Item, Subp_Outputs);
30084 end Collect_Dependency_Item;
30086 -- Start of processing for Collect_Dependency_Clause
30089 if Nkind (Clause) = N_Null then
30092 -- A dependency clause appears as component association
30094 elsif Nkind (Clause) = N_Component_Association then
30095 Collect_Dependency_Item
30096 (Item => Expression (Clause),
30099 Collect_Dependency_Item
30100 (Item => First (Choices (Clause)),
30101 Is_Input => False);
30103 -- To accommodate partial decoration of disabled SPARK features, this
30104 -- routine may be called with illegal input. If this is the case, do
30105 -- not raise Program_Error.
30110 end Collect_Dependency_Clause;
30112 -------------------------
30113 -- Collect_Global_List --
30114 -------------------------
30116 procedure Collect_Global_List
30118 Mode : Name_Id := Name_Input)
30120 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30121 -- Add an item to the proper subprogram input or output collection
30123 -------------------------
30124 -- Collect_Global_Item --
30125 -------------------------
30127 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30129 if Mode in Name_In_Out | Name_Input then
30130 Append_New_Elmt (Item, Subp_Inputs);
30133 if Mode in Name_In_Out | Name_Output then
30134 Append_New_Elmt (Item, Subp_Outputs);
30136 end Collect_Global_Item;
30143 -- Start of processing for Collect_Global_List
30146 if Nkind (List) = N_Null then
30149 -- Single global item declaration
30151 elsif Nkind (List) in N_Expanded_Name
30153 | N_Selected_Component
30155 Collect_Global_Item (List, Mode);
30157 -- Simple global list or moded global list declaration
30159 elsif Nkind (List) = N_Aggregate then
30160 if Present (Expressions (List)) then
30161 Item := First (Expressions (List));
30162 while Present (Item) loop
30163 Collect_Global_Item (Item, Mode);
30168 Assoc := First (Component_Associations (List));
30169 while Present (Assoc) loop
30170 Collect_Global_List
30171 (List => Expression (Assoc),
30172 Mode => Chars (First (Choices (Assoc))));
30177 -- To accommodate partial decoration of disabled SPARK features, this
30178 -- routine may be called with illegal input. If this is the case, do
30179 -- not raise Program_Error.
30184 end Collect_Global_List;
30191 Formal : Entity_Id;
30193 Spec_Id : Entity_Id := Empty;
30194 Subp_Decl : Node_Id;
30197 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30200 Global_Seen := False;
30202 -- Process all formal parameters of entries, [generic] subprograms, and
30205 if Ekind (Subp_Id) in E_Entry
30208 | E_Generic_Function
30209 | E_Generic_Procedure
30211 | E_Subprogram_Body
30213 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30214 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30216 -- Process all formal parameters
30218 Formal := First_Entity (Spec_Id);
30219 while Present (Formal) loop
30220 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
30222 -- IN parameters can act as output when the related type is
30223 -- access-to-variable.
30225 if Ekind (Formal) = E_In_Parameter
30226 and then Is_Access_Variable (Etype (Formal))
30228 Append_New_Elmt (Formal, Subp_Outputs);
30231 Append_New_Elmt (Formal, Subp_Inputs);
30234 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
30235 Append_New_Elmt (Formal, Subp_Outputs);
30237 -- OUT parameters can act as inputs when the related type is
30238 -- tagged, unconstrained array, unconstrained record, or record
30239 -- with unconstrained components.
30241 if Ekind (Formal) = E_Out_Parameter
30242 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30244 Append_New_Elmt (Formal, Subp_Inputs);
30248 Next_Entity (Formal);
30251 -- Otherwise the input denotes a task type, a task body, or the
30252 -- anonymous object created for a single task type.
30254 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
30255 or else Is_Single_Task_Object (Subp_Id)
30257 Subp_Decl := Declaration_Node (Subp_Id);
30258 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30261 -- When processing an entry, subprogram or task body, look for pragmas
30262 -- Refined_Depends and Refined_Global as they specify the inputs and
30265 if Is_Entry_Body (Subp_Id)
30266 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
30268 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30269 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30271 -- Subprogram declaration or stand-alone body case, look for pragmas
30272 -- Depends and Global.
30275 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30276 Global := Get_Pragma (Spec_Id, Pragma_Global);
30279 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30280 -- because it provides finer granularity of inputs and outputs.
30282 if Present (Global) then
30283 Global_Seen := True;
30284 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30286 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30287 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30288 -- the inputs and outputs from [Refined_]Depends.
30290 elsif Synthesize and then Present (Depends) then
30291 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30293 -- Multiple dependency clauses appear as an aggregate
30295 if Nkind (Clauses) = N_Aggregate then
30296 Clause := First (Component_Associations (Clauses));
30297 while Present (Clause) loop
30298 Collect_Dependency_Clause (Clause);
30302 -- Otherwise this is a single dependency clause
30305 Collect_Dependency_Clause (Clauses);
30309 -- The current instance of a protected type acts as a formal parameter
30310 -- of mode IN for functions and IN OUT for entries and procedures
30311 -- (SPARK RM 6.1.4).
30313 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30314 Typ := Scope (Spec_Id);
30316 -- Use the anonymous object when the type is single protected
30318 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30319 Typ := Anonymous_Object (Typ);
30322 Append_New_Elmt (Typ, Subp_Inputs);
30324 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
30325 Append_New_Elmt (Typ, Subp_Outputs);
30328 -- The current instance of a task type acts as a formal parameter of
30329 -- mode IN OUT (SPARK RM 6.1.4).
30331 elsif Ekind (Spec_Id) = E_Task_Type then
30334 -- Use the anonymous object when the type is single task
30336 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30337 Typ := Anonymous_Object (Typ);
30340 Append_New_Elmt (Typ, Subp_Inputs);
30341 Append_New_Elmt (Typ, Subp_Outputs);
30343 elsif Is_Single_Task_Object (Spec_Id) then
30344 Append_New_Elmt (Spec_Id, Subp_Inputs);
30345 Append_New_Elmt (Spec_Id, Subp_Outputs);
30347 end Collect_Subprogram_Inputs_Outputs;
30349 ---------------------------
30350 -- Contract_Freeze_Error --
30351 ---------------------------
30353 procedure Contract_Freeze_Error
30354 (Contract_Id : Entity_Id;
30355 Freeze_Id : Entity_Id)
30358 Error_Msg_Name_1 := Chars (Contract_Id);
30359 Error_Msg_Sloc := Sloc (Freeze_Id);
30362 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30364 ("\all contractual items must be declared before body #", Contract_Id);
30365 end Contract_Freeze_Error;
30367 ---------------------------------
30368 -- Delay_Config_Pragma_Analyze --
30369 ---------------------------------
30371 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30373 return Pragma_Name_Unmapped (N)
30374 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
30375 end Delay_Config_Pragma_Analyze;
30377 -----------------------
30378 -- Duplication_Error --
30379 -----------------------
30381 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30382 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30383 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30386 Error_Msg_Sloc := Sloc (Prev);
30387 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30389 -- Emit a precise message to distinguish between source pragmas and
30390 -- pragmas generated from aspects. The ordering of the two pragmas is
30394 -- Prag -- duplicate
30396 -- No error is emitted when both pragmas come from aspects because this
30397 -- is already detected by the general aspect analysis mechanism.
30399 if Prag_From_Asp and Prev_From_Asp then
30401 elsif Prag_From_Asp then
30402 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30403 elsif Prev_From_Asp then
30404 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30406 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30408 end Duplication_Error;
30410 ------------------------------
30411 -- Find_Encapsulating_State --
30412 ------------------------------
30414 function Find_Encapsulating_State
30415 (States : Elist_Id;
30416 Constit_Id : Entity_Id) return Entity_Id
30418 State_Id : Entity_Id;
30421 -- Since a constituent may be part of a larger constituent set, climb
30422 -- the encapsulating state chain looking for a state that appears in
30425 State_Id := Encapsulating_State (Constit_Id);
30426 while Present (State_Id) loop
30427 if Contains (States, State_Id) then
30431 State_Id := Encapsulating_State (State_Id);
30435 end Find_Encapsulating_State;
30437 --------------------------
30438 -- Find_Related_Context --
30439 --------------------------
30441 function Find_Related_Context
30443 Do_Checks : Boolean := False) return Node_Id
30448 Stmt := Prev (Prag);
30449 while Present (Stmt) loop
30451 -- Skip prior pragmas, but check for duplicates
30453 if Nkind (Stmt) = N_Pragma then
30455 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30462 -- Skip internally generated code
30464 elsif not Comes_From_Source (Stmt)
30465 and then not Comes_From_Source (Original_Node (Stmt))
30468 -- The anonymous object created for a single concurrent type is a
30469 -- suitable context.
30471 if Nkind (Stmt) = N_Object_Declaration
30472 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30477 -- Return the current source construct
30487 end Find_Related_Context;
30489 --------------------------------------
30490 -- Find_Related_Declaration_Or_Body --
30491 --------------------------------------
30493 function Find_Related_Declaration_Or_Body
30495 Do_Checks : Boolean := False) return Node_Id
30497 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30499 procedure Expression_Function_Error;
30500 -- Emit an error concerning pragma Prag that illegaly applies to an
30501 -- expression function.
30503 -------------------------------
30504 -- Expression_Function_Error --
30505 -------------------------------
30507 procedure Expression_Function_Error is
30509 Error_Msg_Name_1 := Prag_Nam;
30511 -- Emit a precise message to distinguish between source pragmas and
30512 -- pragmas generated from aspects.
30514 if From_Aspect_Specification (Prag) then
30516 ("aspect % cannot apply to a stand alone expression function",
30520 ("pragma % cannot apply to a stand alone expression function",
30523 end Expression_Function_Error;
30527 Context : constant Node_Id := Parent (Prag);
30530 Look_For_Body : constant Boolean :=
30531 Prag_Nam in Name_Refined_Depends
30532 | Name_Refined_Global
30533 | Name_Refined_Post
30534 | Name_Refined_State;
30535 -- Refinement pragmas must be associated with a subprogram body [stub]
30537 -- Start of processing for Find_Related_Declaration_Or_Body
30540 Stmt := Prev (Prag);
30541 while Present (Stmt) loop
30543 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30544 -- by splitting a complex pre/postcondition are not considered to
30547 if Nkind (Stmt) = N_Pragma then
30549 and then not Split_PPC (Stmt)
30550 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30557 -- Emit an error when a refinement pragma appears on an expression
30558 -- function without a completion.
30561 and then Look_For_Body
30562 and then Nkind (Stmt) = N_Subprogram_Declaration
30563 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30564 and then not Has_Completion (Defining_Entity (Stmt))
30566 Expression_Function_Error;
30569 -- The refinement pragma applies to a subprogram body stub
30571 elsif Look_For_Body
30572 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30576 -- Skip internally generated code
30578 elsif not Comes_From_Source (Stmt) then
30580 -- The anonymous object created for a single concurrent type is a
30581 -- suitable context.
30583 if Nkind (Stmt) = N_Object_Declaration
30584 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30588 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30590 -- The subprogram declaration is an internally generated spec
30591 -- for an expression function.
30593 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30596 -- The subprogram declaration is an internally generated spec
30597 -- for a stand-alone subrogram body declared inside a protected
30600 elsif Present (Corresponding_Body (Stmt))
30601 and then Comes_From_Source (Corresponding_Body (Stmt))
30602 and then Is_Protected_Type (Current_Scope)
30606 -- The subprogram is actually an instance housed within an
30607 -- anonymous wrapper package.
30609 elsif Present (Generic_Parent (Specification (Stmt))) then
30612 -- Ada 2020: contract on formal subprogram or on generated
30613 -- Access_Subprogram_Wrapper, which appears after the related
30614 -- Access_Subprogram declaration.
30616 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30617 and then Ada_Version >= Ada_2020
30621 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
30622 and then Ada_Version >= Ada_2020
30628 -- Return the current construct which is either a subprogram body,
30629 -- a subprogram declaration or is illegal.
30638 -- If we fall through, then the pragma was either the first declaration
30639 -- or it was preceded by other pragmas and no source constructs.
30641 -- The pragma is associated with a library-level subprogram
30643 if Nkind (Context) = N_Compilation_Unit_Aux then
30644 return Unit (Parent (Context));
30646 -- The pragma appears inside the declarations of an entry body
30648 elsif Nkind (Context) = N_Entry_Body then
30651 -- The pragma appears inside the statements of a subprogram body. This
30652 -- placement is the result of subprogram contract expansion.
30654 elsif Is_Statement (Context)
30655 and then Present (Enclosing_HSS (Context))
30657 return Parent (Enclosing_HSS (Context));
30659 -- The pragma appears inside the declarative part of a package body
30661 elsif Nkind (Context) = N_Package_Body then
30664 -- The pragma appears inside the declarative part of a subprogram body
30666 elsif Nkind (Context) = N_Subprogram_Body then
30669 -- The pragma appears inside the declarative part of a task body
30671 elsif Nkind (Context) = N_Task_Body then
30674 -- The pragma appears inside the visible part of a package specification
30676 elsif Nkind (Context) = N_Package_Specification then
30677 return Parent (Context);
30679 -- The pragma is a byproduct of aspect expansion, return the related
30680 -- context of the original aspect. This case has a lower priority as
30681 -- the above circuitry pinpoints precisely the related context.
30683 elsif Present (Corresponding_Aspect (Prag)) then
30684 return Parent (Corresponding_Aspect (Prag));
30686 -- No candidate subprogram [body] found
30691 end Find_Related_Declaration_Or_Body;
30693 ----------------------------------
30694 -- Find_Related_Package_Or_Body --
30695 ----------------------------------
30697 function Find_Related_Package_Or_Body
30699 Do_Checks : Boolean := False) return Node_Id
30701 Context : constant Node_Id := Parent (Prag);
30702 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30706 Stmt := Prev (Prag);
30707 while Present (Stmt) loop
30709 -- Skip prior pragmas, but check for duplicates
30711 if Nkind (Stmt) = N_Pragma then
30712 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30718 -- Skip internally generated code
30720 elsif not Comes_From_Source (Stmt) then
30721 if Nkind (Stmt) = N_Subprogram_Declaration then
30723 -- The subprogram declaration is an internally generated spec
30724 -- for an expression function.
30726 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30729 -- The subprogram is actually an instance housed within an
30730 -- anonymous wrapper package.
30732 elsif Present (Generic_Parent (Specification (Stmt))) then
30737 -- Return the current source construct which is illegal
30746 -- If we fall through, then the pragma was either the first declaration
30747 -- or it was preceded by other pragmas and no source constructs.
30749 -- The pragma is associated with a package. The immediate context in
30750 -- this case is the specification of the package.
30752 if Nkind (Context) = N_Package_Specification then
30753 return Parent (Context);
30755 -- The pragma appears in the declarations of a package body
30757 elsif Nkind (Context) = N_Package_Body then
30760 -- The pragma appears in the statements of a package body
30762 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30763 and then Nkind (Parent (Context)) = N_Package_Body
30765 return Parent (Context);
30767 -- The pragma is a byproduct of aspect expansion, return the related
30768 -- context of the original aspect. This case has a lower priority as
30769 -- the above circuitry pinpoints precisely the related context.
30771 elsif Present (Corresponding_Aspect (Prag)) then
30772 return Parent (Corresponding_Aspect (Prag));
30774 -- No candidate package [body] found
30779 end Find_Related_Package_Or_Body;
30785 function Get_Argument
30787 Context_Id : Entity_Id := Empty) return Node_Id
30789 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30792 -- Use the expression of the original aspect when analyzing the template
30793 -- of a generic unit. In both cases the aspect's tree must be decorated
30794 -- to save the global references in the generic context.
30796 if From_Aspect_Specification (Prag)
30797 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30799 return Corresponding_Aspect (Prag);
30801 -- Otherwise use the expression of the pragma
30803 elsif Present (Args) then
30804 return First (Args);
30811 -------------------------
30812 -- Get_Base_Subprogram --
30813 -------------------------
30815 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30817 -- Follow subprogram renaming chain
30819 if Is_Subprogram (Def_Id)
30820 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30821 N_Subprogram_Renaming_Declaration
30822 and then Present (Alias (Def_Id))
30824 return Alias (Def_Id);
30828 end Get_Base_Subprogram;
30830 -----------------------
30831 -- Get_SPARK_Mode_Type --
30832 -----------------------
30834 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30836 if N = Name_On then
30838 elsif N = Name_Off then
30841 -- Any other argument is illegal. Assume that no SPARK mode applies to
30842 -- avoid potential cascaded errors.
30847 end Get_SPARK_Mode_Type;
30849 ------------------------------------
30850 -- Get_SPARK_Mode_From_Annotation --
30851 ------------------------------------
30853 function Get_SPARK_Mode_From_Annotation
30854 (N : Node_Id) return SPARK_Mode_Type
30859 if Nkind (N) = N_Aspect_Specification then
30860 Mode := Expression (N);
30862 else pragma Assert (Nkind (N) = N_Pragma);
30863 Mode := First (Pragma_Argument_Associations (N));
30865 if Present (Mode) then
30866 Mode := Get_Pragma_Arg (Mode);
30870 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30872 if Present (Mode) then
30873 if Nkind (Mode) = N_Identifier then
30874 return Get_SPARK_Mode_Type (Chars (Mode));
30876 -- In case of a malformed aspect or pragma, return the default None
30882 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30887 end Get_SPARK_Mode_From_Annotation;
30889 ---------------------------
30890 -- Has_Extra_Parentheses --
30891 ---------------------------
30893 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30897 -- The aggregate should not have an expression list because a clause
30898 -- is always interpreted as a component association. The only way an
30899 -- expression list can sneak in is by adding extra parentheses around
30900 -- the individual clauses:
30902 -- Depends (Output => Input) -- proper form
30903 -- Depends ((Output => Input)) -- extra parentheses
30905 -- Since the extra parentheses are not allowed by the syntax of the
30906 -- pragma, flag them now to avoid emitting misleading errors down the
30909 if Nkind (Clause) = N_Aggregate
30910 and then Present (Expressions (Clause))
30912 Expr := First (Expressions (Clause));
30913 while Present (Expr) loop
30915 -- A dependency clause surrounded by extra parentheses appears
30916 -- as an aggregate of component associations with an optional
30917 -- Paren_Count set.
30919 if Nkind (Expr) = N_Aggregate
30920 and then Present (Component_Associations (Expr))
30923 ("dependency clause contains extra parentheses", Expr);
30925 -- Otherwise the expression is a malformed construct
30928 SPARK_Msg_N ("malformed dependency clause", Expr);
30938 end Has_Extra_Parentheses;
30944 procedure Initialize is
30947 Compile_Time_Warnings_Errors.Init;
30956 Dummy := Dummy + 1;
30959 -----------------------------
30960 -- Is_Config_Static_String --
30961 -----------------------------
30963 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30965 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30966 -- This is an internal recursive function that is just like the outer
30967 -- function except that it adds the string to the name buffer rather
30968 -- than placing the string in the name buffer.
30970 ------------------------------
30971 -- Add_Config_Static_String --
30972 ------------------------------
30974 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30981 if Nkind (N) = N_Op_Concat then
30982 if Add_Config_Static_String (Left_Opnd (N)) then
30983 N := Right_Opnd (N);
30989 if Nkind (N) /= N_String_Literal then
30990 Error_Msg_N ("string literal expected for pragma argument", N);
30994 for J in 1 .. String_Length (Strval (N)) loop
30995 C := Get_String_Char (Strval (N), J);
30997 if not In_Character_Range (C) then
30999 ("string literal contains invalid wide character",
31000 Sloc (N) + 1 + Source_Ptr (J));
31004 Add_Char_To_Name_Buffer (Get_Character (C));
31009 end Add_Config_Static_String;
31011 -- Start of processing for Is_Config_Static_String
31016 return Add_Config_Static_String (Arg);
31017 end Is_Config_Static_String;
31019 -------------------------------
31020 -- Is_Elaboration_SPARK_Mode --
31021 -------------------------------
31023 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
31026 (Nkind (N) = N_Pragma
31027 and then Pragma_Name (N) = Name_SPARK_Mode
31028 and then Is_List_Member (N));
31030 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31031 -- appears in the statement part of the body.
31034 Present (Parent (N))
31035 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
31036 and then List_Containing (N) = Statements (Parent (N))
31037 and then Present (Parent (Parent (N)))
31038 and then Nkind (Parent (Parent (N))) = N_Package_Body;
31039 end Is_Elaboration_SPARK_Mode;
31041 -----------------------
31042 -- Is_Enabled_Pragma --
31043 -----------------------
31045 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
31049 if Present (Prag) then
31050 Arg := First (Pragma_Argument_Associations (Prag));
31052 if Present (Arg) then
31053 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
31055 -- The lack of a Boolean argument automatically enables the pragma
31061 -- The pragma is missing, therefore it is not enabled
31066 end Is_Enabled_Pragma;
31068 -----------------------------------------
31069 -- Is_Non_Significant_Pragma_Reference --
31070 -----------------------------------------
31072 -- This function makes use of the following static table which indicates
31073 -- whether appearance of some name in a given pragma is to be considered
31074 -- as a reference for the purposes of warnings about unreferenced objects.
31076 -- -1 indicates that appearence in any argument is significant
31077 -- 0 indicates that appearance in any argument is not significant
31078 -- +n indicates that appearance as argument n is significant, but all
31079 -- other arguments are not significant
31080 -- 9n arguments from n on are significant, before n insignificant
31082 Sig_Flags : constant array (Pragma_Id) of Int :=
31083 (Pragma_Abort_Defer => -1,
31084 Pragma_Abstract_State => -1,
31085 Pragma_Ada_83 => -1,
31086 Pragma_Ada_95 => -1,
31087 Pragma_Ada_05 => -1,
31088 Pragma_Ada_2005 => -1,
31089 Pragma_Ada_12 => -1,
31090 Pragma_Ada_2012 => -1,
31091 Pragma_Ada_2020 => -1,
31092 Pragma_Aggregate_Individually_Assign => 0,
31093 Pragma_All_Calls_Remote => -1,
31094 Pragma_Allow_Integer_Address => -1,
31095 Pragma_Annotate => 93,
31096 Pragma_Assert => -1,
31097 Pragma_Assert_And_Cut => -1,
31098 Pragma_Assertion_Policy => 0,
31099 Pragma_Assume => -1,
31100 Pragma_Assume_No_Invalid_Values => 0,
31101 Pragma_Async_Readers => 0,
31102 Pragma_Async_Writers => 0,
31103 Pragma_Asynchronous => 0,
31104 Pragma_Atomic => 0,
31105 Pragma_Atomic_Components => 0,
31106 Pragma_Attach_Handler => -1,
31107 Pragma_Attribute_Definition => 92,
31108 Pragma_Check => -1,
31109 Pragma_Check_Float_Overflow => 0,
31110 Pragma_Check_Name => 0,
31111 Pragma_Check_Policy => 0,
31112 Pragma_CPP_Class => 0,
31113 Pragma_CPP_Constructor => 0,
31114 Pragma_CPP_Virtual => 0,
31115 Pragma_CPP_Vtable => 0,
31117 Pragma_C_Pass_By_Copy => 0,
31118 Pragma_Comment => -1,
31119 Pragma_Common_Object => 0,
31120 Pragma_CUDA_Execute => -1,
31121 Pragma_CUDA_Global => -1,
31122 Pragma_Compile_Time_Error => -1,
31123 Pragma_Compile_Time_Warning => -1,
31124 Pragma_Compiler_Unit => -1,
31125 Pragma_Compiler_Unit_Warning => -1,
31126 Pragma_Complete_Representation => 0,
31127 Pragma_Complex_Representation => 0,
31128 Pragma_Component_Alignment => 0,
31129 Pragma_Constant_After_Elaboration => 0,
31130 Pragma_Contract_Cases => -1,
31131 Pragma_Controlled => 0,
31132 Pragma_Convention => 0,
31133 Pragma_Convention_Identifier => 0,
31134 Pragma_Deadline_Floor => -1,
31135 Pragma_Debug => -1,
31136 Pragma_Debug_Policy => 0,
31137 Pragma_Default_Initial_Condition => -1,
31138 Pragma_Default_Scalar_Storage_Order => 0,
31139 Pragma_Default_Storage_Pool => 0,
31140 Pragma_Depends => -1,
31141 Pragma_Detect_Blocking => 0,
31142 Pragma_Disable_Atomic_Synchronization => 0,
31143 Pragma_Discard_Names => 0,
31144 Pragma_Dispatching_Domain => -1,
31145 Pragma_Effective_Reads => 0,
31146 Pragma_Effective_Writes => 0,
31147 Pragma_Elaborate => 0,
31148 Pragma_Elaborate_All => 0,
31149 Pragma_Elaborate_Body => 0,
31150 Pragma_Elaboration_Checks => 0,
31151 Pragma_Eliminate => 0,
31152 Pragma_Enable_Atomic_Synchronization => 0,
31153 Pragma_Export => -1,
31154 Pragma_Export_Function => -1,
31155 Pragma_Export_Object => -1,
31156 Pragma_Export_Procedure => -1,
31157 Pragma_Export_Value => -1,
31158 Pragma_Export_Valued_Procedure => -1,
31159 Pragma_Extend_System => -1,
31160 Pragma_Extensions_Allowed => 0,
31161 Pragma_Extensions_Visible => 0,
31162 Pragma_External => -1,
31163 Pragma_External_Name_Casing => 0,
31164 Pragma_Fast_Math => 0,
31165 Pragma_Favor_Top_Level => 0,
31166 Pragma_Finalize_Storage_Only => 0,
31168 Pragma_Global => -1,
31169 Pragma_Ident => -1,
31170 Pragma_Ignore_Pragma => 0,
31171 Pragma_Implementation_Defined => -1,
31172 Pragma_Implemented => -1,
31173 Pragma_Implicit_Packing => 0,
31174 Pragma_Import => 93,
31175 Pragma_Import_Function => 0,
31176 Pragma_Import_Object => 0,
31177 Pragma_Import_Procedure => 0,
31178 Pragma_Import_Valued_Procedure => 0,
31179 Pragma_Independent => 0,
31180 Pragma_Independent_Components => 0,
31181 Pragma_Initial_Condition => -1,
31182 Pragma_Initialize_Scalars => 0,
31183 Pragma_Initializes => -1,
31184 Pragma_Inline => 0,
31185 Pragma_Inline_Always => 0,
31186 Pragma_Inline_Generic => 0,
31187 Pragma_Inspection_Point => -1,
31188 Pragma_Interface => 92,
31189 Pragma_Interface_Name => 0,
31190 Pragma_Interrupt_Handler => -1,
31191 Pragma_Interrupt_Priority => -1,
31192 Pragma_Interrupt_State => -1,
31193 Pragma_Invariant => -1,
31194 Pragma_Keep_Names => 0,
31195 Pragma_License => 0,
31196 Pragma_Link_With => -1,
31197 Pragma_Linker_Alias => -1,
31198 Pragma_Linker_Constructor => -1,
31199 Pragma_Linker_Destructor => -1,
31200 Pragma_Linker_Options => -1,
31201 Pragma_Linker_Section => -1,
31203 Pragma_Lock_Free => 0,
31204 Pragma_Locking_Policy => 0,
31205 Pragma_Loop_Invariant => -1,
31206 Pragma_Loop_Optimize => 0,
31207 Pragma_Loop_Variant => -1,
31208 Pragma_Machine_Attribute => -1,
31210 Pragma_Main_Storage => -1,
31211 Pragma_Max_Entry_Queue_Depth => 0,
31212 Pragma_Max_Entry_Queue_Length => 0,
31213 Pragma_Max_Queue_Length => 0,
31214 Pragma_Memory_Size => 0,
31215 Pragma_No_Body => 0,
31216 Pragma_No_Caching => 0,
31217 Pragma_No_Component_Reordering => -1,
31218 Pragma_No_Elaboration_Code_All => 0,
31219 Pragma_No_Heap_Finalization => 0,
31220 Pragma_No_Inline => 0,
31221 Pragma_No_Return => 0,
31222 Pragma_No_Run_Time => -1,
31223 Pragma_No_Strict_Aliasing => -1,
31224 Pragma_No_Tagged_Streams => 0,
31225 Pragma_Normalize_Scalars => 0,
31226 Pragma_Obsolescent => 0,
31227 Pragma_Optimize => 0,
31228 Pragma_Optimize_Alignment => 0,
31229 Pragma_Ordered => 0,
31230 Pragma_Overflow_Mode => 0,
31231 Pragma_Overriding_Renamings => 0,
31234 Pragma_Part_Of => 0,
31235 Pragma_Partition_Elaboration_Policy => 0,
31236 Pragma_Passive => 0,
31237 Pragma_Persistent_BSS => 0,
31239 Pragma_Postcondition => -1,
31240 Pragma_Post_Class => -1,
31242 Pragma_Precondition => -1,
31243 Pragma_Predicate => -1,
31244 Pragma_Predicate_Failure => -1,
31245 Pragma_Preelaborable_Initialization => -1,
31246 Pragma_Preelaborate => 0,
31247 Pragma_Prefix_Exception_Messages => 0,
31248 Pragma_Pre_Class => -1,
31249 Pragma_Priority => -1,
31250 Pragma_Priority_Specific_Dispatching => 0,
31251 Pragma_Profile => 0,
31252 Pragma_Profile_Warnings => 0,
31253 Pragma_Propagate_Exceptions => 0,
31254 Pragma_Provide_Shift_Operators => 0,
31255 Pragma_Psect_Object => 0,
31257 Pragma_Pure_Function => 0,
31258 Pragma_Queuing_Policy => 0,
31259 Pragma_Rational => 0,
31260 Pragma_Ravenscar => 0,
31261 Pragma_Refined_Depends => -1,
31262 Pragma_Refined_Global => -1,
31263 Pragma_Refined_Post => -1,
31264 Pragma_Refined_State => -1,
31265 Pragma_Relative_Deadline => 0,
31266 Pragma_Remote_Access_Type => -1,
31267 Pragma_Remote_Call_Interface => -1,
31268 Pragma_Remote_Types => -1,
31269 Pragma_Rename_Pragma => 0,
31270 Pragma_Restricted_Run_Time => 0,
31271 Pragma_Restriction_Warnings => 0,
31272 Pragma_Restrictions => 0,
31273 Pragma_Reviewable => -1,
31274 Pragma_Secondary_Stack_Size => -1,
31275 Pragma_Share_Generic => 0,
31276 Pragma_Shared => 0,
31277 Pragma_Shared_Passive => 0,
31278 Pragma_Short_Circuit_And_Or => 0,
31279 Pragma_Short_Descriptors => 0,
31280 Pragma_Simple_Storage_Pool_Type => 0,
31281 Pragma_Source_File_Name => 0,
31282 Pragma_Source_File_Name_Project => 0,
31283 Pragma_Source_Reference => 0,
31284 Pragma_SPARK_Mode => 0,
31285 Pragma_Static_Elaboration_Desired => 0,
31286 Pragma_Storage_Size => -1,
31287 Pragma_Storage_Unit => 0,
31288 Pragma_Stream_Convert => 0,
31289 Pragma_Style_Checks => 0,
31290 Pragma_Subprogram_Variant => -1,
31291 Pragma_Subtitle => 0,
31292 Pragma_Suppress => 0,
31293 Pragma_Suppress_All => 0,
31294 Pragma_Suppress_Debug_Info => 0,
31295 Pragma_Suppress_Exception_Locations => 0,
31296 Pragma_Suppress_Initialization => 0,
31297 Pragma_System_Name => 0,
31298 Pragma_Task_Dispatching_Policy => 0,
31299 Pragma_Task_Info => -1,
31300 Pragma_Task_Name => -1,
31301 Pragma_Task_Storage => -1,
31302 Pragma_Test_Case => -1,
31303 Pragma_Thread_Local_Storage => -1,
31304 Pragma_Time_Slice => -1,
31306 Pragma_Type_Invariant => -1,
31307 Pragma_Type_Invariant_Class => -1,
31308 Pragma_Unchecked_Union => 0,
31309 Pragma_Unevaluated_Use_Of_Old => 0,
31310 Pragma_Unimplemented_Unit => 0,
31311 Pragma_Universal_Aliasing => 0,
31312 Pragma_Universal_Data => 0,
31313 Pragma_Unmodified => 0,
31314 Pragma_Unreferenced => 0,
31315 Pragma_Unreferenced_Objects => 0,
31316 Pragma_Unreserve_All_Interrupts => 0,
31317 Pragma_Unsuppress => 0,
31318 Pragma_Unused => 0,
31319 Pragma_Use_VADS_Size => 0,
31320 Pragma_Validity_Checks => 0,
31321 Pragma_Volatile => 0,
31322 Pragma_Volatile_Components => 0,
31323 Pragma_Volatile_Full_Access => 0,
31324 Pragma_Volatile_Function => 0,
31325 Pragma_Warning_As_Error => 0,
31326 Pragma_Warnings => 0,
31327 Pragma_Weak_External => 0,
31328 Pragma_Wide_Character_Encoding => 0,
31329 Unknown_Pragma => 0);
31331 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31337 function Arg_No return Nat;
31338 -- Returns an integer showing what argument we are in. A value of
31339 -- zero means we are not in any of the arguments.
31345 function Arg_No return Nat is
31350 A := First (Pragma_Argument_Associations (Parent (P)));
31364 -- Start of processing for Non_Significant_Pragma_Reference
31369 if Nkind (P) /= N_Pragma_Argument_Association then
31373 Id := Get_Pragma_Id (Parent (P));
31374 C := Sig_Flags (Id);
31389 return AN < (C - 90);
31395 end Is_Non_Significant_Pragma_Reference;
31397 ------------------------------
31398 -- Is_Pragma_String_Literal --
31399 ------------------------------
31401 -- This function returns true if the corresponding pragma argument is a
31402 -- static string expression. These are the only cases in which string
31403 -- literals can appear as pragma arguments. We also allow a string literal
31404 -- as the first argument to pragma Assert (although it will of course
31405 -- always generate a type error).
31407 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31408 Pragn : constant Node_Id := Parent (Par);
31409 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31410 Pname : constant Name_Id := Pragma_Name (Pragn);
31416 N := First (Assoc);
31423 if Pname = Name_Assert then
31426 elsif Pname = Name_Export then
31429 elsif Pname = Name_Ident then
31432 elsif Pname = Name_Import then
31435 elsif Pname = Name_Interface_Name then
31438 elsif Pname = Name_Linker_Alias then
31441 elsif Pname = Name_Linker_Section then
31444 elsif Pname = Name_Machine_Attribute then
31447 elsif Pname = Name_Source_File_Name then
31450 elsif Pname = Name_Source_Reference then
31453 elsif Pname = Name_Title then
31456 elsif Pname = Name_Subtitle then
31462 end Is_Pragma_String_Literal;
31464 ---------------------------
31465 -- Is_Private_SPARK_Mode --
31466 ---------------------------
31468 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31471 (Nkind (N) = N_Pragma
31472 and then Pragma_Name (N) = Name_SPARK_Mode
31473 and then Is_List_Member (N));
31475 -- For pragma SPARK_Mode to be private, it has to appear in the private
31476 -- declarations of a package.
31479 Present (Parent (N))
31480 and then Nkind (Parent (N)) = N_Package_Specification
31481 and then List_Containing (N) = Private_Declarations (Parent (N));
31482 end Is_Private_SPARK_Mode;
31484 -------------------------------------
31485 -- Is_Unconstrained_Or_Tagged_Item --
31486 -------------------------------------
31488 function Is_Unconstrained_Or_Tagged_Item
31489 (Item : Entity_Id) return Boolean
31491 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31492 -- Determine whether record type Typ has at least one unconstrained
31495 ---------------------------------
31496 -- Has_Unconstrained_Component --
31497 ---------------------------------
31499 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31503 Comp := First_Component (Typ);
31504 while Present (Comp) loop
31505 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31509 Next_Component (Comp);
31513 end Has_Unconstrained_Component;
31517 Typ : constant Entity_Id := Etype (Item);
31519 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31522 if Is_Tagged_Type (Typ) then
31525 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31528 elsif Is_Record_Type (Typ) then
31529 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31532 return Has_Unconstrained_Component (Typ);
31535 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31541 end Is_Unconstrained_Or_Tagged_Item;
31543 -----------------------------
31544 -- Is_Valid_Assertion_Kind --
31545 -----------------------------
31547 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31554 | Name_Static_Predicate
31555 | Name_Dynamic_Predicate
31560 | Name_Type_Invariant
31561 | Name_uType_Invariant
31565 | Name_Assert_And_Cut
31567 | Name_Contract_Cases
31569 | Name_Default_Initial_Condition
31571 | Name_Initial_Condition
31574 | Name_Loop_Invariant
31575 | Name_Loop_Variant
31576 | Name_Postcondition
31577 | Name_Precondition
31579 | Name_Refined_Post
31580 | Name_Statement_Assertions
31581 | Name_Subprogram_Variant
31588 end Is_Valid_Assertion_Kind;
31590 --------------------------------------
31591 -- Process_Compilation_Unit_Pragmas --
31592 --------------------------------------
31594 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31596 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31597 -- strange because it comes at the end of the unit. Rational has the
31598 -- same name for a pragma, but treats it as a program unit pragma, In
31599 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31600 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31601 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31602 -- the context clause to ensure the correct processing.
31604 if Has_Pragma_Suppress_All (N) then
31605 Prepend_To (Context_Items (N),
31606 Make_Pragma (Sloc (N),
31607 Chars => Name_Suppress,
31608 Pragma_Argument_Associations => New_List (
31609 Make_Pragma_Argument_Association (Sloc (N),
31610 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31613 -- Nothing else to do at the current time
31615 end Process_Compilation_Unit_Pragmas;
31617 --------------------------------------------
31618 -- Validate_Compile_Time_Warning_Or_Error --
31619 --------------------------------------------
31621 procedure Validate_Compile_Time_Warning_Or_Error
31625 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31626 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31627 Arg2 : constant Node_Id := Next (Arg1);
31629 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31630 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31633 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31635 if Compile_Time_Known_Value (Arg1x) then
31636 if Is_True (Expr_Value (Arg1x)) then
31638 -- We have already verified that the second argument is a static
31639 -- string expression. Its string value must be retrieved
31640 -- explicitly if it is a declared constant, otherwise it has
31641 -- been constant-folded previously.
31644 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31645 Str : constant String_Id :=
31646 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31647 Str_Len : constant Nat := String_Length (Str);
31649 Force : constant Boolean :=
31650 Prag_Id = Pragma_Compile_Time_Warning
31651 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31652 and then (Ekind (Cent) /= E_Package
31653 or else not In_Private_Part (Cent));
31654 -- Set True if this is the warning case, and we are in the
31655 -- visible part of a package spec, or in a subprogram spec,
31656 -- in which case we want to force the client to see the
31657 -- warning, even though it is not in the main unit.
31665 -- Loop through segments of message separated by line feeds.
31666 -- We output these segments as separate messages with
31667 -- continuation marks for all but the first.
31672 Error_Msg_Strlen := 0;
31674 -- Loop to copy characters from argument to error message
31678 exit when Ptr > Str_Len;
31679 CC := Get_String_Char (Str, Ptr);
31682 -- Ignore wide chars ??? else store character
31684 if In_Character_Range (CC) then
31685 C := Get_Character (CC);
31686 exit when C = ASCII.LF;
31687 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31688 Error_Msg_String (Error_Msg_Strlen) := C;
31692 -- Here with one line ready to go
31694 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31696 -- If this is a warning in a spec, then we want clients
31697 -- to see the warning, so mark the message with the
31698 -- special sequence !! to force the warning. In the case
31699 -- of a package spec, we do not force this if we are in
31700 -- the private part of the spec.
31703 if Cont = False then
31705 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31709 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31712 -- Error, rather than warning, or in a body, so we do not
31713 -- need to force visibility for client (error will be
31714 -- output in any case, and this is the situation in which
31715 -- we do not want a client to get a warning, since the
31716 -- warning is in the body or the spec private part).
31719 if Cont = False then
31721 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
31725 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
31729 exit when Ptr > Str_Len;
31734 -- Arg1x is not known at compile time, so possibly issue an error
31735 -- or warning. This can happen only if the pragma's processing
31736 -- was deferred until after the back end is run (see
31737 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31738 -- control switch applies to only the warning case.
31740 elsif Prag_Id = Pragma_Compile_Time_Error then
31741 Error_Msg_N ("condition is not known at compile time", Arg1x);
31743 elsif Warn_On_Unknown_Compile_Time_Warning then
31744 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31746 end Validate_Compile_Time_Warning_Or_Error;
31748 ------------------------------------
31749 -- Record_Possible_Body_Reference --
31750 ------------------------------------
31752 procedure Record_Possible_Body_Reference
31753 (State_Id : Entity_Id;
31757 Spec_Id : Entity_Id;
31760 -- Ensure that we are dealing with a reference to a state
31762 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31764 -- Climb the tree starting from the reference looking for a package body
31765 -- whose spec declares the referenced state. This criteria automatically
31766 -- excludes references in package specs which are legal. Note that it is
31767 -- not wise to emit an error now as the package body may lack pragma
31768 -- Refined_State or the referenced state may not be mentioned in the
31769 -- refinement. This approach avoids the generation of misleading errors.
31772 while Present (Context) loop
31773 if Nkind (Context) = N_Package_Body then
31774 Spec_Id := Corresponding_Spec (Context);
31776 if Present (Abstract_States (Spec_Id))
31777 and then Contains (Abstract_States (Spec_Id), State_Id)
31779 if No (Body_References (State_Id)) then
31780 Set_Body_References (State_Id, New_Elmt_List);
31783 Append_Elmt (Ref, To => Body_References (State_Id));
31788 Context := Parent (Context);
31790 end Record_Possible_Body_Reference;
31792 ------------------------------------------
31793 -- Relocate_Pragmas_To_Anonymous_Object --
31794 ------------------------------------------
31796 procedure Relocate_Pragmas_To_Anonymous_Object
31797 (Typ_Decl : Node_Id;
31798 Obj_Decl : Node_Id)
31802 Next_Decl : Node_Id;
31805 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31806 Def := Protected_Definition (Typ_Decl);
31808 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31809 Def := Task_Definition (Typ_Decl);
31812 -- The concurrent definition has a visible declaration list. Inspect it
31813 -- and relocate all canidate pragmas.
31815 if Present (Def) and then Present (Visible_Declarations (Def)) then
31816 Decl := First (Visible_Declarations (Def));
31817 while Present (Decl) loop
31819 -- Preserve the following declaration for iteration purposes due
31820 -- to possible relocation of a pragma.
31822 Next_Decl := Next (Decl);
31824 if Nkind (Decl) = N_Pragma
31825 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31828 Insert_After (Obj_Decl, Decl);
31830 -- Skip internally generated code
31832 elsif not Comes_From_Source (Decl) then
31835 -- No candidate pragmas are available for relocation
31844 end Relocate_Pragmas_To_Anonymous_Object;
31846 ------------------------------
31847 -- Relocate_Pragmas_To_Body --
31848 ------------------------------
31850 procedure Relocate_Pragmas_To_Body
31851 (Subp_Body : Node_Id;
31852 Target_Body : Node_Id := Empty)
31854 procedure Relocate_Pragma (Prag : Node_Id);
31855 -- Remove a single pragma from its current list and add it to the
31856 -- declarations of the proper body (either Subp_Body or Target_Body).
31858 ---------------------
31859 -- Relocate_Pragma --
31860 ---------------------
31862 procedure Relocate_Pragma (Prag : Node_Id) is
31867 -- When subprogram stubs or expression functions are involves, the
31868 -- destination declaration list belongs to the proper body.
31870 if Present (Target_Body) then
31871 Target := Target_Body;
31873 Target := Subp_Body;
31876 Decls := Declarations (Target);
31880 Set_Declarations (Target, Decls);
31883 -- Unhook the pragma from its current list
31886 Prepend (Prag, Decls);
31887 end Relocate_Pragma;
31891 Body_Id : constant Entity_Id :=
31892 Defining_Unit_Name (Specification (Subp_Body));
31893 Next_Stmt : Node_Id;
31896 -- Start of processing for Relocate_Pragmas_To_Body
31899 -- Do not process a body that comes from a separate unit as no construct
31900 -- can possibly follow it.
31902 if not Is_List_Member (Subp_Body) then
31905 -- Do not relocate pragmas that follow a stub if the stub does not have
31908 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31909 and then No (Target_Body)
31913 -- Do not process internally generated routine _Postconditions
31915 elsif Ekind (Body_Id) = E_Procedure
31916 and then Chars (Body_Id) = Name_uPostconditions
31921 -- Look at what is following the body. We are interested in certain kind
31922 -- of pragmas (either from source or byproducts of expansion) that can
31923 -- apply to a body [stub].
31925 Stmt := Next (Subp_Body);
31926 while Present (Stmt) loop
31928 -- Preserve the following statement for iteration purposes due to a
31929 -- possible relocation of a pragma.
31931 Next_Stmt := Next (Stmt);
31933 -- Move a candidate pragma following the body to the declarations of
31936 if Nkind (Stmt) = N_Pragma
31937 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31940 -- If a source pragma Warnings follows the body, it applies to
31941 -- following statements and does not belong in the body.
31943 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31944 and then Comes_From_Source (Stmt)
31948 Relocate_Pragma (Stmt);
31951 -- Skip internally generated code
31953 elsif not Comes_From_Source (Stmt) then
31956 -- No candidate pragmas are available for relocation
31964 end Relocate_Pragmas_To_Body;
31966 -------------------
31967 -- Resolve_State --
31968 -------------------
31970 procedure Resolve_State (N : Node_Id) is
31975 if Is_Entity_Name (N) and then Present (Entity (N)) then
31976 Func := Entity (N);
31978 -- Handle overloading of state names by functions. Traverse the
31979 -- homonym chain looking for an abstract state.
31981 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31982 pragma Assert (Is_Overloaded (N));
31984 State := Homonym (Func);
31985 while Present (State) loop
31986 if Ekind (State) = E_Abstract_State then
31988 -- Resolve the overloading by setting the proper entity of
31989 -- the reference to that of the state.
31991 Set_Etype (N, Standard_Void_Type);
31992 Set_Entity (N, State);
31993 Set_Is_Overloaded (N, False);
31995 Generate_Reference (State, N);
31999 State := Homonym (State);
32002 -- A function can never act as a state. If the homonym chain does
32003 -- not contain a corresponding state, then something went wrong in
32004 -- the overloading mechanism.
32006 raise Program_Error;
32011 ----------------------------
32012 -- Rewrite_Assertion_Kind --
32013 ----------------------------
32015 procedure Rewrite_Assertion_Kind
32017 From_Policy : Boolean := False)
32023 if Nkind (N) = N_Attribute_Reference
32024 and then Attribute_Name (N) = Name_Class
32025 and then Nkind (Prefix (N)) = N_Identifier
32027 case Chars (Prefix (N)) is
32034 when Name_Type_Invariant =>
32035 Nam := Name_uType_Invariant;
32037 when Name_Invariant =>
32038 Nam := Name_uInvariant;
32044 -- Recommend standard use of aspect names Pre/Post
32046 elsif Nkind (N) = N_Identifier
32047 and then From_Policy
32048 and then Serious_Errors_Detected = 0
32050 if Chars (N) = Name_Precondition
32051 or else Chars (N) = Name_Postcondition
32053 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
32055 ("\use Assertion_Policy and aspect names Pre/Post for "
32056 & "Ada2012 conformance?", N);
32062 if Nam /= No_Name then
32063 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
32065 end Rewrite_Assertion_Kind;
32073 Dummy := Dummy + 1;
32076 --------------------------------
32077 -- Set_Encoded_Interface_Name --
32078 --------------------------------
32080 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
32081 Str : constant String_Id := Strval (S);
32082 Len : constant Nat := String_Length (Str);
32087 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
32090 -- Stores encoded value of character code CC. The encoding we use an
32091 -- underscore followed by four lower case hex digits.
32097 procedure Encode is
32099 Store_String_Char (Get_Char_Code ('_'));
32101 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
32103 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
32105 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
32107 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
32110 -- Start of processing for Set_Encoded_Interface_Name
32113 -- If first character is asterisk, this is a link name, and we leave it
32114 -- completely unmodified. We also ignore null strings (the latter case
32115 -- happens only in error cases).
32118 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
32120 Set_Interface_Name (E, S);
32125 CC := Get_String_Char (Str, J);
32127 exit when not In_Character_Range (CC);
32129 C := Get_Character (CC);
32131 exit when C /= '_' and then C /= '$'
32132 and then C not in '0' .. '9'
32133 and then C not in 'a' .. 'z'
32134 and then C not in 'A' .. 'Z';
32137 Set_Interface_Name (E, S);
32145 -- Here we need to encode. The encoding we use as follows:
32146 -- three underscores + four hex digits (lower case)
32150 for J in 1 .. String_Length (Str) loop
32151 CC := Get_String_Char (Str, J);
32153 if not In_Character_Range (CC) then
32156 C := Get_Character (CC);
32158 if C = '_' or else C = '$'
32159 or else C in '0' .. '9'
32160 or else C in 'a' .. 'z'
32161 or else C in 'A' .. 'Z'
32163 Store_String_Char (CC);
32170 Set_Interface_Name (E,
32171 Make_String_Literal (Sloc (S),
32172 Strval => End_String));
32174 end Set_Encoded_Interface_Name;
32176 ------------------------
32177 -- Set_Elab_Unit_Name --
32178 ------------------------
32180 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32185 if Nkind (N) = N_Identifier
32186 and then Nkind (With_Item) = N_Identifier
32188 Set_Entity (N, Entity (With_Item));
32190 elsif Nkind (N) = N_Selected_Component then
32191 Change_Selected_Component_To_Expanded_Name (N);
32192 Set_Entity (N, Entity (With_Item));
32193 Set_Entity (Selector_Name (N), Entity (N));
32195 Pref := Prefix (N);
32196 Scop := Scope (Entity (N));
32197 while Nkind (Pref) = N_Selected_Component loop
32198 Change_Selected_Component_To_Expanded_Name (Pref);
32199 Set_Entity (Selector_Name (Pref), Scop);
32200 Set_Entity (Pref, Scop);
32201 Pref := Prefix (Pref);
32202 Scop := Scope (Scop);
32205 Set_Entity (Pref, Scop);
32208 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32209 end Set_Elab_Unit_Name;
32211 -----------------------
32212 -- Set_Overflow_Mode --
32213 -----------------------
32215 procedure Set_Overflow_Mode (N : Node_Id) is
32217 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
32218 -- Function to process one pragma argument, Arg
32220 -----------------------
32221 -- Get_Overflow_Mode --
32222 -----------------------
32224 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
32225 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
32228 if Chars (Argx) = Name_Strict then
32231 elsif Chars (Argx) = Name_Minimized then
32234 elsif Chars (Argx) = Name_Eliminated then
32238 raise Program_Error;
32240 end Get_Overflow_Mode;
32244 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32245 Arg2 : constant Node_Id := Next (Arg1);
32247 -- Start of processing for Set_Overflow_Mode
32250 -- Process first argument
32252 Scope_Suppress.Overflow_Mode_General :=
32253 Get_Overflow_Mode (Arg1);
32255 -- Case of only one argument
32258 Scope_Suppress.Overflow_Mode_Assertions :=
32259 Scope_Suppress.Overflow_Mode_General;
32261 -- Case of two arguments present
32264 Scope_Suppress.Overflow_Mode_Assertions :=
32265 Get_Overflow_Mode (Arg2);
32267 end Set_Overflow_Mode;
32269 -------------------
32270 -- Test_Case_Arg --
32271 -------------------
32273 function Test_Case_Arg
32276 From_Aspect : Boolean := False) return Node_Id
32278 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32284 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
32286 -- The caller requests the aspect argument
32288 if From_Aspect then
32289 if Present (Aspect)
32290 and then Nkind (Expression (Aspect)) = N_Aggregate
32292 Args := Expression (Aspect);
32294 -- "Name" and "Mode" may appear without an identifier as a
32295 -- positional association.
32297 if Present (Expressions (Args)) then
32298 Arg := First (Expressions (Args));
32300 if Present (Arg) and then Arg_Nam = Name_Name then
32308 if Present (Arg) and then Arg_Nam = Name_Mode then
32313 -- Some or all arguments may appear as component associatons
32315 if Present (Component_Associations (Args)) then
32316 Arg := First (Component_Associations (Args));
32317 while Present (Arg) loop
32318 if Chars (First (Choices (Arg))) = Arg_Nam then
32327 -- Otherwise retrieve the argument directly from the pragma
32330 Arg := First (Pragma_Argument_Associations (Prag));
32332 if Present (Arg) and then Arg_Nam = Name_Name then
32336 -- Skip argument "Name"
32340 if Present (Arg) and then Arg_Nam = Name_Mode then
32344 -- Skip argument "Mode"
32348 -- Arguments "Requires" and "Ensures" are optional and may not be
32351 while Present (Arg) loop
32352 if Chars (Arg) = Arg_Nam then
32363 --------------------------------------------
32364 -- Defer_Compile_Time_Warning_Error_To_BE --
32365 --------------------------------------------
32367 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32368 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32370 Compile_Time_Warnings_Errors.Append
32371 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32372 Scope => Current_Scope,
32375 -- If the Boolean expression contains T'Size, and we're not in the main
32376 -- unit being compiled, then we need to copy the pragma into the main
32377 -- unit, because otherwise T'Size might never be computed, leaving it
32380 if not In_Extended_Main_Code_Unit (N) then
32381 Insert_Library_Level_Action (New_Copy_Tree (N));
32383 end Defer_Compile_Time_Warning_Error_To_BE;
32385 ------------------------------------------
32386 -- Validate_Compile_Time_Warning_Errors --
32387 ------------------------------------------
32389 procedure Validate_Compile_Time_Warning_Errors is
32390 procedure Set_Scope (S : Entity_Id);
32391 -- Install all enclosing scopes of S along with S itself
32393 procedure Unset_Scope (S : Entity_Id);
32394 -- Uninstall all enclosing scopes of S along with S itself
32400 procedure Set_Scope (S : Entity_Id) is
32402 if S /= Standard_Standard then
32403 Set_Scope (Scope (S));
32413 procedure Unset_Scope (S : Entity_Id) is
32415 if S /= Standard_Standard then
32416 Unset_Scope (Scope (S));
32422 -- Start of processing for Validate_Compile_Time_Warning_Errors
32425 Expander_Mode_Save_And_Set (False);
32426 In_Compile_Time_Warning_Or_Error := True;
32428 for N in Compile_Time_Warnings_Errors.First ..
32429 Compile_Time_Warnings_Errors.Last
32432 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32435 Set_Scope (T.Scope);
32436 Reset_Analyzed_Flags (T.Prag);
32437 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32438 Unset_Scope (T.Scope);
32442 In_Compile_Time_Warning_Or_Error := False;
32443 Expander_Mode_Restore;
32444 end Validate_Compile_Time_Warning_Errors;